9
$\begingroup$

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

basic graph

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:

enter image description here

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

enter image description here

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.

$\endgroup$
  • $\begingroup$ I cannot find the thread but I definitely remember showing IGSmoothen to you when you were asking for visualizing some huge Collatz graph. $\endgroup$ – Szabolcs Mar 26 at 7:51
  • $\begingroup$ 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. $\endgroup$ – Szabolcs Mar 26 at 8:23
6
$\begingroup$

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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]

enter image description here

| improve this answer | |
$\endgroup$
  • 2
    $\begingroup$ 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. $\endgroup$ – David G. Stork Mar 26 at 5:17
  • $\begingroup$ No worries! I've also added a simple one-liner to also preserve the original coordinates. $\endgroup$ – Victor K. Mar 26 at 5:18
6
$\begingroup$
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]]}]

enter image description here

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

enter image description here

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

enter image description here

With d = 3 we get

enter image description here

| improve this answer | |
$\endgroup$
4
$\begingroup$

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

enter image description here

These vertices will be smoothened out:

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

enter image description here

Smoothen the graph:

IGSmoothen[g]

enter image description here

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]

enter image description here

Compare smoothened to original, with preserved vertex coordinates:

FlipView[{%, g}]

enter image description here

| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ FlipView is amazing! How did you guys learn all these tricks?! $\endgroup$ – Victor K. Mar 26 at 8:10
  • 1
    $\begingroup$ @VictorK. If you do any image processing, FlipView becomes indispensable. It's probably the first time I use it for graphs. $\endgroup$ – Szabolcs Mar 26 at 8:23
  • $\begingroup$ @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/… $\endgroup$ – David G. Stork Mar 26 at 17:10
  • $\begingroup$ @DavidG.Stork If you have an example of a Graph on which this code does not work, please upload it somewhere. $\endgroup$ – Szabolcs Mar 26 at 18:32
  • $\begingroup$ @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! $\endgroup$ – David G. Stork Mar 26 at 18:55

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.