Mathematica 9 is now available
Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2007

[Date Index] [Thread Index] [Author Index]

Search the Archive

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



  • Prev by Date: Re: Zoom2D
  • Next by Date: Re: How to use Fourier (fft) to solve eplliptic partial differential
  • Previous by thread: Re: Creating and installing one's own packages?
  • Next by thread: Re: How to use Fourier (fft) to solve eplliptic partial differential