6
$\begingroup$

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

enter image description here

edges2 = {1 <-> 9, 1 <-> 8, 1 <-> 5, 5 <-> 6, 5 <-> 7};
graphB = Graph[edges2, VertexLabels -> "Name"]

enter image description here

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?

$\endgroup$
  • $\begingroup$ Please, show your code for your attempt(s). Do you really expect readers to manually input example graphs to try out ideas? $\endgroup$ – ciao Jul 30 '15 at 22:21
  • $\begingroup$ @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. $\endgroup$ – andandandand Jul 30 '15 at 22:27
7
$\begingroup$

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}][[1]];
  VertexContract[graph, loc]];

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

To use it, we can use FixedPoint:

FixedPoint[contract, graphA]

enter image description here

To see how it progress, we can use FixedPointList:

FixedPointList[contract, graphA]

enter image description here

On more complicated graphs:

FixedPointList[contract, RandomGraph[{10, 11}, VertexLabels -> "Name"]]

enter image description here

$\endgroup$
3
$\begingroup$

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

Mathematica graphics

$\endgroup$
  • $\begingroup$ Very nice. I hope your solution took you less time than mine took me.... $\endgroup$ – kale Aug 1 '15 at 2:12

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.