Recursive graph expansion and rewiring

Question

I want to take this graph

and convert it into this graph

by repeatedly substituting each of its nodes according to this rule

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

I tried fiddling with NestGraph

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

and got this:

How can I programmatically specify the proper rewiring?

Answer 1

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]

Answer 2

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.