2
$\begingroup$

I want to take this graph

enter image description here

and convert it into this graph

enter image description here

by repeatedly substituting each of its nodes according to this rule

enter image description here

After loading the initial graph and the substitution rule

ic = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 3 <-> 2, 3 <-> 4, 4 <-> 2}, 
  GraphLayout -> "RadialDrawing"]

enter image description here

I tried fiddling with NestGraph

NestGraph[substitution, ic, 1, DirectedEdges -> False]

and got this:

enter image description here

How can I programmatically specify the proper rewiring?

$\endgroup$
7
$\begingroup$

I have used the functions EdgeDelete and EdgeAdd to expand the graph. The code generates new vertex names by incrementing the largest vertex name in the graph.

nextVertexNames[g_] := Max[VertexList[g]] + {{1, 2, 3}, {4, 5, 6}}
replaceTripod[g_, v_] := Module[{
   oldNeighbors = DeleteCases[VertexComponent[g, v, 1], v], 
   newNeighbors = nextVertexNames[g], go = g
   },
  EdgeAdd[
   EdgeDelete[go, v <-> _],
   Flatten@{
     UndirectedEdge[v, #] & /@ First[newNeighbors],
     UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
     UndirectedEdge @@@ Thread[{Last@newNeighbors, oldNeighbors}]}
   ]
  ]
replaceTripods[g_] := 
  Fold[replaceTripod, g, 
   Extract[VertexList[g], Position[VertexDegree[g], 3]]];

For your case, use replaceTripods[g] to replace all tripods in the graph g.

Update As kindly suggested by halmir below, the resulting graph can be displayed just as in your example using the option GraphLayout -> "TutteEmbedding".

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 2 <-> 3, 2 <-> 4, 3 <-> 4}, 
   VertexLabels -> "Name", GraphLayout -> "TutteEmbedding"];
replaceTripods[g]

enter image description here

$\endgroup$
  • $\begingroup$ I can see your answer produced the solution by using GraphLayout -> "TutteEmbedding" $\endgroup$ – halmir Aug 10 '15 at 4:43
1
$\begingroup$

This may or may not do what you want. I don't know about making the layout nice, I'm afraid. The function newvertex returns n names which are not used as a vertex in the graph. Then expandVertex takes a vertex name and expands about that vertex in the manner stated. Alternatively, supply a list of names to have the expansion done on each in turn, or supply no names at all to have every valid vertex expanded in that way.

newvertex[g_, n_] := Max@VertexList[g] + Range[n]

expandVertex[g_, v_] /; VertexDegree[g, v] != 3 := g

expandVertex[g_, v_] := 
 With[{new = newvertex[g, 6]}, 
  With[{r = new[[1]], s = new[[2]], t = new[[3]], st = new[[4]], 
        rs = new[[5]], rt = new[[6]]}, 
   EdgeList[g] /. 
    {xx___, a_ <-> v | v <-> a_, yy___, b_ <-> v | v <-> b_, 
     zz___, d_ <-> v | v <-> d_, aa___}
    :>
   {xx, yy, zz, aa, 
    a <-> r, b <-> s, d <-> t, t <-> st, s <-> st, r <-> rs, 
    s <-> rs, r <-> rt, t <-> rt, rt <-> v, st <-> v, rs <-> v}]] 
// Graph[VertexList[g], #, VertexLabels -> "Name", GraphLayout -> "PlanarEmbedding"] &

expandVertex[g_, v_List] := Fold[expandVertex[#1, #2] &, g, v]

expandVertex[g_] := expandVertex[g, VertexList[g]]

Your example would be expandVertex[ic].

It works by a very inefficient pattern match, checking that the input is a vertex of degree 3 and then constructing the appropriate edges.

This relies on the vertex names of the graph being integers (or, I suppose, real numbers), I'm afraid. It can be a real pain to work with arbitrary vertex names.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.