7
$\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?

Improve this question
$\endgroup$
2
  • $\begingroup$ Please, show your code for your attempt(s). Do you really expect readers to manually input example graphs to try out ideas? $\endgroup$ Commented Jul 30, 2015 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$ Commented Jul 30, 2015 at 22:27

2 Answers 2

Reset to default
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

Improve this answer
$\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

Improve this answer
$\endgroup$
1
  • $\begingroup$ Very nice. I hope your solution took you less time than mine took me.... $\endgroup$ Commented Aug 1, 2015 at 2:12

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.