# Recursive graph expansion and rewiring

I want to take this graph

and convert it into this graph

by repeatedly substituting each of its nodes according to this rule

ic = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 3 <-> 2, 3 <-> 4, 4 <-> 2}, I tried fiddling with NestGraph

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


and got this: How can I programmatically specify the proper rewiring?

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
},
EdgeDelete[go, v <-> _],
Flatten@{
UndirectedEdge[v, #] & /@ First[newNeighbors],
UndirectedEdge @@@ Partition[Riffle @@ newNeighbors, {2}, 1, 1],
]
]
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] • I can see your answer produced the solution by using GraphLayout -> "TutteEmbedding" – halmir Aug 10 '15 at 4:43

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[], s = new[], t = new[], st = new[],
rs = new[], rt = new[]},
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.