# VertexContract and contraction of vertices of degree 2

There are several questions that seem close to this, but I haven't found any that are precisely what I need, which is called "path contraction."

Consider this graph:

mygraph =
Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3,
3 \[UndirectedEdge] 4, 4 \[UndirectedEdge] 5,
2 \[UndirectedEdge] 6},
VertexLabels -> "Name"]


I would like to eliminate all vertices that have a degree $$2$$... that is, vertices that are merely part of a linear path (in this case, vertices 3 and 4). My goal is to get the following graph:

I can find the vertices that have degree $$2$$ that should be deleted:

Select[VertexList[mygraph], VertexDegree[mygraph, #] == 2 &]


(* {3,4} *)

But when I try to delete these two (and preserve connectivity), I get this:

VertexContract[mygraph, {3, 4}]


which has the undesired remaining vertex between $$2$$ and $$5$$. I really want to contract vertices 3 and 4 and 5, but keep 5 labeled (and in its location).

Is there a single function that computes the graph I seek? Or is there an elegant way to compute it?

I'd also like to preserve the vertex coordinates of the remaining original vertices (e.g., 1,2,5,6). In short, I want to replace chains of edges by a single edge.

Note that for a general graph, the result is not a spanning tree. After all, I could have two densely connected subgraphs connected only by a chain of three edges. I'd like to replace that chain by a single edge connecting the two subgraphs.

• I cannot find the thread but I definitely remember showing IGSmoothen to you when you were asking for visualizing some huge Collatz graph. – Szabolcs Mar 26 at 7:51
• If you can find that Collatz thing, can you please link to it? If I misremember and the discussion was with someone else, I apologize. – Szabolcs Mar 26 at 8:23

An interesting question! Here is how I would approach it:

1. Create a random graph and highlighted the vertexes of degree 2:
g = RandomGraph[{30, 40}]
degree2[g_Graph] := Select[VertexList[g], VertexDegree[g, #] == 2 &]
HighlightGraph[g, degree2[g]]


1. Generate a list of connected components among the vertexes of degree 2. As you can see, there are 5 individual vertexes that need to be removed individually, and 2 that need to be removed together.
components2[g_Graph] := ConnectedComponents[Subgraph[g, degree2[g]]]
Subgraph[g, components2[g]]


1. Next, in order to use VertexContract, as explained by Vitaly, we need to add one of the vertexes connected to each component:
contractComponent[g_Graph, l_List] :=
Prepend[l,
RandomChoice@Complement[VertexList@NeighborhoodGraph[g, l, 1], l]]


Let's visualize what we have so far:

HighlightGraph[g,
Flatten[contractComponent[g, #] & /@ components2[g]]]


1. The only thing left is to contract all these components one by one:
Fold[VertexContract, g, contractComponent[g, #] & /@ components2[g]]


Note: This does not preserve the coordinates of the vertexes, but it can be easily done and is left as an exercise to the reader :).

Update. 5. Which is actually easier that it sounds:

graphVertexCoordinates[g_] := (# -> PropertyValue[{g, #}, VertexCoordinates]) & /@
VertexList[g]
remove2s[g_Graph] :=
Graph[Fold[VertexContract, g,
contractComponent[g, #] & /@ components2[g]],
VertexCoordinates -> graphVertexCoordinates[g]]
remove2s[g]


• Very very nice. I was stuck (on my own) with the appending of the "right" or "correct" end to the path, but you saw that it didn't matter which "end" you picked, given that the process would be iterated (folded). Thanks so much ($\checkmark$). I think Wolfram should add PathContract into its next release. – David G. Stork Mar 26 at 5:17
• No worries! I've also added a simple one-liner to also preserve the original coordinates. – Victor K. Mar 26 at 5:18
ClearAll[aL, vContract]
aL[d_:2] := {#2, Select[Function[x, VertexDegree[#, x] == d]] @ AdjacencyList[##]} &;

vContract[d_:2][g_] := Fold[VertexContract, g,
aL[d][g, #] & /@ Select[VertexDegree[g, #] != d &][VertexList[g]]]

Graph[vContract[][mygraph], VertexLabels -> {_ -> "Name"},
VertexCoordinates -> {v_ :> GraphEmbedding[mygraph][[v]]}]


SeedRandom[1]
rg = RandomGraph[{50, 70}, VertexLabels -> "Name"];

Row[{HighlightGraph[rg, v_ /; VertexDegree[rg, v] == 2, ImageSize -> 400],
Graph[vContract[][rg], ImageSize -> 400, VertexLabels -> {_ -> "Name"},
VertexCoordinates -> {v_ :> GraphEmbedding[rg][[v]]}]},
Spacer[15]]


Successively contract vertices with VertexDegree 1:

d = 1;
Row[{HighlightGraph[rg, v_ /; VertexDegree[rg, v] == d, ImageSize -> 400],
Graph[vContract[d][rg], ImageSize -> 400,
VertexLabels -> {_ -> "Name"},
VertexCoordinates -> {v_ :> GraphEmbedding[rg][[v]]}]}, Spacer[15]]


With d = 3 we get

IGSmoothen from the IGraph/M package does precisely what you are asking for. It will also add up the weights of merged edges.

It will be by far the fastest and simplest solution. Note that IGSmoothen takes linear time, unlike some of the other proposed solutions.

### Example

Needs["IGraphM"]


Create a graph:

g = IGGiantComponent@RandomGraph[{100, 100}]


These vertices will be smoothened out:

HighlightGraph[g, Pick[VertexList[g], VertexDegree[g], 2]]


Smoothen the graph:

IGSmoothen[g]


Smoothen the graph while preserving the original vertex coordinates:

vertexAssoc[fun_][g_] := AssociationThread[VertexList[g], fun[g]]

IGSmoothen[g] // IGVertexMap[vertexAssoc[GraphEmbedding][g], VertexCoordinates -> VertexList]


Compare smoothened to original, with preserved vertex coordinates:

FlipView[{%, g}]


• FlipView is amazing! How did you guys learn all these tricks?! – Victor K. Mar 26 at 8:10
• @VictorK. If you do any image processing, FlipView becomes indispensable. It's probably the first time I use it for graphs. – Szabolcs Mar 26 at 8:23
• @Szabolcs: This is very cool but as I post in the linked question, somehow even your nice code scrambles the locations of the vertices (or the edges) in a graph defined by MorphologicalGraph. How do I fix that? mathematica.stackexchange.com/questions/217126/… – David G. Stork Mar 26 at 17:10
• @DavidG.Stork If you have an example of a Graph on which this code does not work, please upload it somewhere. – Szabolcs Mar 26 at 18:32
• @Szabolcs: You can download the craquelure image from this page (mathematica.stackexchange.com/questions/217126/…) and run: MorphologicalGraph@ ColorReplace[VermeerCraquelure, {White -> Black, Black -> White}]` to get the graph that (somehow) doesn't work. (I now suspect that the image processing should be altered before computing the MorphologicalGraph, but we'll see...). Thanks for your help! – David G. Stork Mar 26 at 18:55