# Delete vertices of degree 2 and rewire graph

I want to delete all vertices of degree 2 from a graph and rewire it.

Given a graph like graphA, I want to obtain graphB.

edges1 = {1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 5 <-> 7,
1 <-> 9, 1 <-> 8};
graphA = Graph[edges1, VertexLabels -> "Name"] edges2 = {1 <-> 9, 1 <-> 8, 1 <-> 5, 5 <-> 6, 5 <-> 7};
graphB = Graph[edges2, VertexLabels -> "Name"] I have this simple algorithm, which I find easy to implement using a for loop in Python or Java.

1. Get indices of all nodes with degree = 2.
2. Pick a node of degree = 2 (call it N) and get its end points X and Y.
3. Rewire X to Y, delete N
4. Repeat 1 until there are no more nodes of degree 2

I know using a for loop would be painfully slow in big graphs. So what's the Mathematica-savvy way of doing this?

• Please, show your code for your attempt(s). Do you really expect readers to manually input example graphs to try out ideas? – ciao Jul 30 '15 at 22:21
• @ciao: "Do you really expect readers to manually input example graphs to try out ideas?" ExampleData["NetworkGraph"] has a large collection of graphs, "FamilyGathering" and "ZacharyKarateClub" seem ok for this. I don't show code to implement this because I only know for loop-based ways of doing this, which is what I want to avoid. – andandandand Jul 30 '15 at 22:27

I've never played with Graphs much in Mathematica. Call it laziness, whatever, but I just never had a need. So, what better time to learn?

Here's how I approached it.

First we define a function that uses VertexContract to "rewire" the graph at every degree 2 vertices. Since this will be iterative, we only want it to act when the graph still contains a vertices with degree 2.

contract[graph_] /; MemberQ[VertexDegree[graph], 2] :=
Module[{vd = VertexDegree[graph], vl = VertexList[graph], loc},
loc = Cases[EdgeList[graph], UndirectedEdge[a___, b : vl[[First@FirstPosition[vd, 2]]], c___] :> {a, b, c}][];
VertexContract[graph, loc]];

contract[graph_] := Graph[EdgeList[graph], VertexLabels -> "Name"];


To use it, we can use FixedPoint:

FixedPoint[contract, graphA] To see how it progress, we can use FixedPointList:

FixedPointList[contract, graphA] On more complicated graphs:

FixedPointList[contract, RandomGraph[{10, 11}, VertexLabels -> "Name"]] The following works on v9 and makes use of the Orderless attribute, which for unknown reasons isn't attached to UndirectedEdge by default

reduceG[g_Graph] := Module[{t, el, newEl, ue, p},
SetAttributes[ue, Orderless];
NestWhile[(
t = VertexList[#][[p[[1, 1]]]];
el = ue @@@ EdgeList[#];
newEl = el /. {x___, ue[t, a_], y___, ue[t, b_], z___} :> Union@{x, y, z, ue[a, b]};
Graph[newEl /. ue :> UndirectedEdge, VertexLabels -> "Name"]) &,
g,
(p = Position[VertexDegree[#], 2, 1, 1]) != {} &]
]

reduceG[Graph[edges1]] • Very nice. I hope your solution took you less time than mine took me.... – kale Aug 1 '15 at 2:12