rank-1 decomposition for GraphPlot vertex positioning
- To: mathgroup at smc.vnet.net
- Subject: [mg82697] rank-1 decomposition for GraphPlot vertex positioning
- From: Yaroslav Bulatov <yaroslavvb at gmail.com>
- Date: Mon, 29 Oct 2007 05:30:17 -0500 (EST)
Here's a way to improve presentation of highly regular vertex-
transitive graphs, which might be of interest to mathgroup readers:
If you have a highly structured vertex transitive graph which doesn't
look very structured when visualized with GraphPlot, take a rank-1
decomposition of the adjacency matrix. If graphs corresponding to
resulting rank-1 matrices are isomorphic to each other, this suggests
a natural grouping of nodes. To (visually) see if they are isomorphic,
do the following on adjacency matrix adj -
{u, d, v} = {#1, Diagonal[#2], #3} & @@ (SingularValueDecomposition[
adj]);
rank1mats = Table[d[[i]]*Outer[Times, u[[All, i]], v[[All, i]]], {i,
1, 6}];
GraphPlot/@rank1mats
(warning, rank-1 decomposition could have negative valued matrices
even for vertex transitive adj.matrices)
For a graph with no self-loops, rank-1 adjacency matrix means it is
bipartite, vertex transitive within each part, and all arrows are
going in the same direction. So you could use VertexCoordinateRules to
place all nodes in a source partition of each rank-1 subgraph close
together in the original graph.
A complete example is below, you will see 3 plots -- original graph
plot, the structure suggested by rank-1 decomposition of the adjacency
matrix, and complete graph with vertices rearranged to respect that
structure. Motivation for this particular graph is here
http://yaroslavvb.blogspot.com/2007/10/ive-recently-gone-to-northwest.html
swap[l_, p_Integer] :=
Module[{ll = l}, ll[[{2 p - 1, 2 p}]] = ll[[{2 p, 2 p - 1}]]; ll];
swap[l_, p_List] :=
Fold[swap[#1, #2] &, l, Position[p, True] // Flatten]
thorp[l_] := Module[{k, ll}, k = Length[l]/2;
ll = Riffle[l[[;; k]], l[[k + 1 ;;]]];
FromDigits[swap[ll, #]] & /@ Tuples[{False, True}, k]]
thorpEdges =
Thread[FromDigits[#] -> thorp[#]] & /@ Permutations[Range[4]] //
Flatten;
graph1 = GraphPlot[thorpEdges, DirectedEdges -> True];
edges2mat[edges_, size_] :=
Module[{perms = Permutations[Range[size]]},
Array[If[
MemberQ[edges,
FromDigits[perms[[#1]]] -> FromDigits[perms[[#2]]]], 1,
0] &, {Length[perms], Length[perms]}]];
thorpMat = edges2mat[thorpEdges, 4];
{u, d, v} = {#1, Diagonal[#2], #3} & @@ (SingularValueDecomposition[
thorpMat]);
rank1mats =
Table[d[[i]]*Outer[Times, u[[All, i]], v[[All, i]]], {i, 1, 6}];
outNodes[mat_] :=
MemberQ[#, 1] & /@ mat // Position[#, True] & // Flatten;
partitions = outNodes[#] & /@ rank1mats;
mergeGraph[adjMat_, partitions_] :=
Module[{l = Length[partitions]},
Table[Unitize[
Total[adjMat[[partitions[[i]], partitions[[j]]]], 2]], {i, 1,
l}, {j, 1, l}]];
graph2 = mergeGraph[thorpMat, partitions] //
GraphPlot[#, DirectedEdges -> True] &;
p2 = Permutations[partitions][[66]];
rules[i_] :=
Thread[p2[[i]] ->
Table[{Cos[i 2 Pi/6], Sin[i 2 Pi/6]} +
2/20 {Cos[j 2 Pi/4], Sin[j 2 Pi/4]}, {j, 1, 4}]];
allrules = rules[#] & /@ Range[6] // Flatten;
graph3 = GraphPlot[thorpMat, DirectedEdges -> True,
VertexCoordinateRules -> allrules];
GraphicsColumn[{graph1, graph2, graph3}]