# Label Product of a Graph with itself

Defn Let $$\mathcal{G}=(\mathcal{V},\mathcal{E})$$ and $$\mathcal{G}' = (\mathcal{V}', \mathcal{E}')$$ be two labeled graphs with alphabet $$\mathcal{A}$$. The labeled graph product $$\mathcal{G} * \mathcal{G}'$$ is defined as follows:

• The vertex set of $$\mathcal{G} * \mathcal{G}'$$ is the Cartesian product $$\mathcal{V} \times \mathcal{V}'$$.
• Given $$(g, g')$$ and $$(h, h') \in \mathcal{V} \times \mathcal{V}'$$ and $$a \in \mathcal{A}$$, there is a labeled edge $$(g,g') \overset{a}{\longrightarrow} (h,h')$$ if and only if there is an edge $$g \overset{a}{\longrightarrow} h$$ in $$\mathcal{G}$$ and an edge $$g' \overset{a}{\longrightarrow} h'$$ in $$\mathcal{G}'$$.

Given a labeled graph $$\mathcal{G}$$, I am trying to efficiently implement the labeled graph product $$\mathcal{G}*\mathcal{G}$$. If it helps, the graphs I'm concerned with will always have the following properties:

• $$\mathcal{G}$$ will be right-resolving (aka a Shannon graph), that is, all edges leaving a given vertex bear distinct labels.
• For each label $$a \in \mathcal{A}$$ and each vertex $$v \in \mathcal{V}$$, there is an edge leaving $$v$$ with label $$a$$, i.e., $$v \overset{a}{\longrightarrow} \dots$$.

For example, consider the graph

graph= {{1 -> 3, "a"}, {1 -> 5, "b"}, {2 -> 1, "a"}, {3 -> 2, "a"}, {3 -> 4, "b"}, {4 -> 1, "a"}, {5 -> 6, "a"}, {5 -> 4, "b"}, {6 -> 1,"a"}, {0 -> 0, "a"}, {0 -> 0, "b"}, {2 -> 0, "b"}, {4 -> 0,  "b"}, {6 -> 0, "b"}}


I have approached this problem by first defining a function that, given a vertex and a label, returns the target of the corresponding edge:

 leavingEdgeTarget[vertex_, edgeLabel_, graph_] := Select[Select[graph, #[[1, 1]] == vertex &], #[] == edgeLabel &][[ 1, 1, 2]]


and then using the following function:

 labelProduct[graph_] := With[
{vertexList = VertexList@Graph@graph[[All, 1]],
alphabet = Union@graph[[All, 2]]},
Flatten[#, 2] &@
ParallelTable[{{v1,v2} ->
{leavingEdgeTarget[v1, label,graph],
leavingEdgeTarget[v2, label, graph]},
label},
{v1, vertexList},
{v2, vertexList},
{label, alphabet}
]
]


So for example, labelProduct[graph] returns the following graph with 49 vertices and 98 edges:

{{{1,1}->{3,3},"a"}, {{1,1}->{5,5}, "b"}, {{1,3}->{3,2},"a"},...,{{0,0}->{0,0},"b"}}


### Q: How can I speed this up?

For small graphs, this runs reasonably fast (and seems to get a very nice speedup from the use of ParallelTable). However, it starts to take quite a while for larger graphs (100+ vertices). Consider the graph

SeedRandom;
n = 100;
randomGraph =
Flatten[#, 1]&@
Table[{i -> RandomInteger[{1, n}], label},
{i, 1, n},
{label, Range}
];


On my machine (32GB memory, 8 logical cores @3.7GHz) I get the following values for labelProduct[randomGraph];//AbsoluteTiming different values of n:

  n   AbsoluteTiming
10   0.022
20   0.072
50   0.600
100   4.418
150  14.524
200  34.193
250  66.879
500  529.8=8m49.8s


I can achieve a small timing benefit by only generating the edges $$(i,j)\overset{a}{\longrightarrow}(i', j')$$ with $$i \leq j$$ and then find the remaining edges in the label product by noting that there is also an edge $$(j,i)\overset{a}{\longrightarrow}(j',i')$$, but this only has a speedup by a factor of roughly $$1/2$$.

Why not just group vertices by their labels, and then use Tuples to generate the new vertices? For example:

grp = GroupBy[graph, Last -> First, Replace[Tuples[#,2], t_ :> Thread[t, Rule], {1}]&]


<|"a" -> {{1, 1} -> {3, 3}, {1, 2} -> {3, 1}, {1, 3} -> {3, 2}, {1, 4} -> {3, 1}, {1, 5} -> {3, 6}, {1, 6} -> {3, 1}, {1, 0} -> {3, 0}, {2, 1} -> {1, 3}, {2, 2} -> {1, 1}, {2, 3} -> {1, 2}, {2, 4} -> {1, 1}, {2, 5} -> {1, 6}, {2, 6} -> {1, 1}, {2, 0} -> {1, 0}, {3, 1} -> {2, 3}, {3, 2} -> {2, 1}, {3, 3} -> {2, 2}, {3, 4} -> {2, 1}, {3, 5} -> {2, 6}, {3, 6} -> {2, 1}, {3, 0} -> {2, 0}, {4, 1} -> {1, 3}, {4, 2} -> {1, 1}, {4, 3} -> {1, 2}, {4, 4} -> {1, 1}, {4, 5} -> {1, 6}, {4, 6} -> {1, 1}, {4, 0} -> {1, 0}, {5, 1} -> {6, 3}, {5, 2} -> {6, 1}, {5, 3} -> {6, 2}, {5, 4} -> {6, 1}, {5, 5} -> {6, 6}, {5, 6} -> {6, 1}, {5, 0} -> {6, 0}, {6, 1} -> {1, 3}, {6, 2} -> {1, 1}, {6, 3} -> {1, 2}, {6, 4} -> {1, 1}, {6, 5} -> {1, 6}, {6, 6} -> {1, 1}, {6, 0} -> {1, 0}, {0, 1} -> {0, 3}, {0, 2} -> {0, 1}, {0, 3} -> {0, 2}, {0, 4} -> {0, 1}, {0, 5} -> {0, 6}, {0, 6} -> {0, 1}, {0, 0} -> {0, 0}}, "b" -> {{1, 1} -> {5, 5}, {1, 3} -> {5, 4}, {1, 5} -> {5, 4}, {1, 0} -> {5, 0}, {1, 2} -> {5, 0}, {1, 4} -> {5, 0}, {1, 6} -> {5, 0}, {3, 1} -> {4, 5}, {3, 3} -> {4, 4}, {3, 5} -> {4, 4}, {3, 0} -> {4, 0}, {3, 2} -> {4, 0}, {3, 4} -> {4, 0}, {3, 6} -> {4, 0}, {5, 1} -> {4, 5}, {5, 3} -> {4, 4}, {5, 5} -> {4, 4}, {5, 0} -> {4, 0}, {5, 2} -> {4, 0}, {5, 4} -> {4, 0}, {5, 6} -> {4, 0}, {0, 1} -> {0, 5}, {0, 3} -> {0, 4}, {0, 5} -> {0, 4}, {0, 0} -> {0, 0}, {0, 2} -> {0, 0}, {0, 4} -> {0, 0}, {0, 6} -> {0, 0}, {2, 1} -> {0, 5}, {2, 3} -> {0, 4}, {2, 5} -> {0, 4}, {2, 0} -> {0, 0}, {2, 2} -> {0, 0}, {2, 4} -> {0, 0}, {2, 6} -> {0, 0}, {4, 1} -> {0, 5}, {4, 3} -> {0, 4}, {4, 5} -> {0, 4}, {4, 0} -> {0, 0}, {4, 2} -> {0, 0}, {4, 4} -> {0, 0}, {4, 6} -> {0, 0}, {6, 1} -> {0, 5}, {6, 3} -> {0, 4}, {6, 5} -> {0, 4}, {6, 0} -> {0, 0}, {6, 2} -> {0, 0}, {6, 4} -> {0, 0}, {6, 6} -> {0, 0}}|>

Then, your desired edges can be obtained with:

gproduct = Catenate @ KeyValueMap[Function[{k, v}, Thread[{v,k}]]] @ grp


{{{1, 1} -> {3, 3}, "a"}, {{1, 2} -> {3, 1}, "a"}, {{1, 3} -> {3, 2}, "a"}, {{1, 4} -> {3, 1}, "a"}, {{1, 5} -> {3, 6}, "a"}, {{1, 6} -> {3, 1}, "a"}, {{1, 0} -> {3, 0}, "a"}, {{2, 1} -> {1, 3}, "a"}, {{2, 2} -> {1, 1}, "a"}, {{2, 3} -> {1, 2}, "a"}, {{2, 4} -> {1, 1}, "a"}, {{2, 5} -> {1, 6}, "a"}, {{2, 6} -> {1, 1}, "a"}, {{2, 0} -> {1, 0}, "a"}, {{3, 1} -> {2, 3}, "a"}, {{3, 2} -> {2, 1}, "a"}, {{3, 3} -> {2, 2}, "a"}, {{3, 4} -> {2, 1}, "a"}, {{3, 5} -> {2, 6}, "a"}, {{3, 6} -> {2, 1}, "a"}, {{3, 0} -> {2, 0}, "a"}, {{4, 1} -> {1, 3}, "a"}, {{4, 2} -> {1, 1}, "a"}, {{4, 3} -> {1, 2}, "a"}, {{4, 4} -> {1, 1}, "a"}, {{4, 5} -> {1, 6}, "a"}, {{4, 6} -> {1, 1}, "a"}, {{4, 0} -> {1, 0}, "a"}, {{5, 1} -> {6, 3}, "a"}, {{5, 2} -> {6, 1}, "a"}, {{5, 3} -> {6, 2}, "a"}, {{5, 4} -> {6, 1}, "a"}, {{5, 5} -> {6, 6}, "a"}, {{5, 6} -> {6, 1}, "a"}, {{5, 0} -> {6, 0}, "a"}, {{6, 1} -> {1, 3}, "a"}, {{6, 2} -> {1, 1}, "a"}, {{6, 3} -> {1, 2}, "a"}, {{6, 4} -> {1, 1}, "a"}, {{6, 5} -> {1, 6}, "a"}, {{6, 6} -> {1, 1}, "a"}, {{6, 0} -> {1, 0}, "a"}, {{0, 1} -> {0, 3}, "a"}, {{0, 2} -> {0, 1}, "a"}, {{0, 3} -> {0, 2}, "a"}, {{0, 4} -> {0, 1}, "a"}, {{0, 5} -> {0, 6}, "a"}, {{0, 6} -> {0, 1}, "a"}, {{0, 0} -> {0, 0}, "a"}, {{1, 1} -> {5, 5}, "b"}, {{1, 3} -> {5, 4}, "b"}, {{1, 5} -> {5, 4}, "b"}, {{1, 0} -> {5, 0}, "b"}, {{1, 2} -> {5, 0}, "b"}, {{1, 4} -> {5, 0}, "b"}, {{1, 6} -> {5, 0}, "b"}, {{3, 1} -> {4, 5}, "b"}, {{3, 3} -> {4, 4}, "b"}, {{3, 5} -> {4, 4}, "b"}, {{3, 0} -> {4, 0}, "b"}, {{3, 2} -> {4, 0}, "b"}, {{3, 4} -> {4, 0}, "b"}, {{3, 6} -> {4, 0}, "b"}, {{5, 1} -> {4, 5}, "b"}, {{5, 3} -> {4, 4}, "b"}, {{5, 5} -> {4, 4}, "b"}, {{5, 0} -> {4, 0}, "b"}, {{5, 2} -> {4, 0}, "b"}, {{5, 4} -> {4, 0}, "b"}, {{5, 6} -> {4, 0}, "b"}, {{0, 1} -> {0, 5}, "b"}, {{0, 3} -> {0, 4}, "b"}, {{0, 5} -> {0, 4}, "b"}, {{0, 0} -> {0, 0}, "b"}, {{0, 2} -> {0, 0}, "b"}, {{0, 4} -> {0, 0}, "b"}, {{0, 6} -> {0, 0}, "b"}, {{2, 1} -> {0, 5}, "b"}, {{2, 3} -> {0, 4}, "b"}, {{2, 5} -> {0, 4}, "b"}, {{2, 0} -> {0, 0}, "b"}, {{2, 2} -> {0, 0}, "b"}, {{2, 4} -> {0, 0}, "b"}, {{2, 6} -> {0, 0}, "b"}, {{4, 1} -> {0, 5}, "b"}, {{4, 3} -> {0, 4}, "b"}, {{4, 5} -> {0, 4}, "b"}, {{4, 0} -> {0, 0}, "b"}, {{4, 2} -> {0, 0}, "b"}, {{4, 4} -> {0, 0}, "b"}, {{4, 6} -> {0, 0}, "b"}, {{6, 1} -> {0, 5}, "b"}, {{6, 3} -> {0, 4}, "b"}, {{6, 5} -> {0, 4}, "b"}, {{6, 0} -> {0, 0}, "b"}, {{6, 2} -> {0, 0}, "b"}, {{6, 4} -> {0, 0}, "b"}, {{6, 6} -> {0, 0}, "b"}}

which is the same as your result up to ordering.

• Wow! Very nice...I may need to finally figure out associations. Getting a timing value of 0.75 for n=500 instead of 8.5minutes. Thank you!! – erfink Oct 5 '18 at 20:57

I am not 100% sure whether my thinking is correct. But let's see.

SeedRandom;
n = 100;
G = Flatten[#, 1] &@ Table[{i -> RandomInteger[{1, n}], label}, {i, 1, n}, {label,Range}];
H = Flatten[#, 1] &@ Table[{i -> RandomInteger[{1, n}], label}, {i, 1, n}, {label, Range}];


Personally, I don't like lists of rules. I prefer packed arrays for their efficiency. Moreover, I'd like to have the labels in front for later use. So, let's reorder.

Gpat = DeveloperToPackedArray[Block[{Rule = Sequence}, G]][[All, {3, 1, 2}]];
Hpat = DeveloperToPackedArray[Block[{Rule = Sequence}, H]][[All, {3, 1, 2}]];


Now let's create some "adjacency matrices".

m = Max[Max[Gpat[[All, 1]]], Max[Hpat[[All, 1]]]];
Gn = Max[Gpat[[All, 2 ;;]]];
Hn = Max[Hpat[[All, 2 ;;]]];
GA = SparseArray[Gpat -> 1, {m, Gn, Gn}];
HA = SparseArray[Hpat -> 1, {m, Hn, Hn}];


More precisely, GA[[i]] is the adjacency matrix of the subgraph of G that consists precisely of those edges with label i. Same for HA[[i]]. In my understanding, the respective adjacency matrix HA[[i]] of the labeled product graph is essentially the Kronecker product of GA[[i]] with HA[[i]]. So, let's generate it, extract its "NonzeroPositions" (these correspond to labeled edges in the new graph) and reorder again in order to obtain a list with entries of the form {{i1,i2}->{j1,j2}, label}.

GHA = ArrayReshape[

My Haswell Quad Core laptop performs this task in 0.0346 seconds. However, 0.0313 seconds (more than 90%!) are used just for transforming from and into the inefficient data format (list of rules). So, the actual computation needs less than 0.0033 seconds. For n = 500, the pure computation needs 0.113 seconds while the final transformation into GH takes 0.926 seconds.