VertexContract and contraction of vertices of degree 2

Question

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.

Answer 1

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

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

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

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

Answer 2

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

Answer 3

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