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}]