How to detect chains (sequence of degree 2 vertices ) in a graph?

Question

I am interested in finding the positions of "chains" (sequences of vertex degree 2 vertices) in a graph. I plan on collapsing these chains later to vertices with labels indicating that they are collapsed chains.

For example, I would like the following input-output.

Input:

Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3,   
3 \[DirectedEdge] 4, 4 \[DirectedEdge] 5, 6 \[DirectedEdge] 7, 
7 \[DirectedEdge] 8, 5 \[DirectedEdge] 8, 8 \[DirectedEdge] 9}]

Output:

{"Chain1" -> Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 
3 \[DirectedEdge] 4, 4 \[DirectedEdge] 5, 5 \[DirectedEdge] 
6}], 
"Chain2" -> Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3}], 
HighlightGraph[
Graph[{Labeled[1, "Chain1"], Labeled[3, "Chain2"]}, {1 -> 2, 3 
-> 2,
2 -> 4}], {1, 3}]}

Why do you want to do that ?

I want to make a code that creates a symbolic expression for the output of an artificial neural network (I am interested if anyone has a code that already does that).

I already made a code that works with simple feedforward networks (NetChain) that contain only ElementwiseLayer and LinearLayer.

I would like to use my code for NetChains to replace any chain subgraph in NetGraph with its symbolic functional equivalent and then use these intermediate expressions to compute the full symbolic expression of a network. A typical example would be to replace a network that adds the results of two NetChains by first finding the expressions for the NetChains and then simply adding them.

Edit 1

In the output example given I would like the two first elements in Chain1 and Chain2 to retain the names of the vertices. The length of the chain is not enough for my purpose.

Edit 2

Procedure incorporating the methods below

Note: There are 2 conventions, the last one using @Szabolcs's answer is currently incomplete for the problem at hand but still provides a solution for many cases.

The answers from @Szabolcs and @lericr offer different solutions on how to collapse a chain within a graph. Should the chain be collapsed to a vertex or an edge? Which vertex should we collapse the chain to? The first, the last? To clarify what I mean we may look at the following input-output examples.

Input:

Graph[{1 -> 2, 2 -> 3, 3 -> 4, 5 -> 4, 4 -> 8, 8 -> 9, 9 -> 10, 
10 -> 11, 11 -> 12, 12 -> 13, 13 -> 14, 11 -> 15, 15 -> 16, 
15 -> 17}, ImageSize -> Small, VertexLabels -> Automatic]

Output using the method from @lericr:

Output using the method from @Szabolcs:

/////////////////

Discussion on the differences between the outputs:

Notice that in the first output vertex 8 represents the collapsed chain whereas in the second output the collapsed chain is represented by the edge 4->11. Notice as well that in the first output, the vertex that represents a chain is always the first element in the chain (with respect to the graph arrow flow). This might be natural for a directed graph but might be difficult to work with when using undirected graphs. Indeed, in the first output graph, vertex 1 is far from vertex 4 in the original graph whereas vertex 12 is close to vertex 11. This could lead to inconsistencies in some applications while being useful when working with directed graphs in others. The second output graph is perhaps easier to work with in general. Moreover, @Szabolcs one function solution might be easier to use in most graph-chain related problems which is why I accepted that user's solution.

//////////////////

In the following, I will use the answers below to provide a solution for both conventions. First, however, I provide below the code for obtaining the chains which is used in both cases.

Following the suggestion of @Szabolcs, the list of collapsed chains can be obtained using**(see footnote):

chains=WeaklyConnectedGraphComponents[Subgraph[inputgraph, _? 
(VertexDegree[testGraph2, #] < 3 &)] // EdgeList]

Output:

The slightly longer method used by @lericr might require less computer time since it does not use patterns but I have not checked.

///////////////

** footnote : The list chains is equivalent to @lericr's chainSubgraphs I believe. Also, EdgeList was used to remove any lone wolf vertices from the disconnected graphs. Equivalently one could also use VertexDelete as in @lericr's answer:

WeaklyConnectedGraphComponents[
VertexDelete[inputgraph, _?(VertexDegree[inputgraph, #] > 2 &)] 
// EdgeList]

This VertexDelete code has about the same speed as the Subgraph one when using the input examples above.

---

Vertex collapsed-chain convention

I would like to mention that @lericr's answer is fairly simple and uses only Mathematica built-in functions whereas the @Szabolcs method requires installing a package (the page provided in @Szabolcs answer makes the installation a very easy copy-paste-enter using Mathematica).

In the vertex convention, the collapsed chains in the output graph are identified by the first vertex in each chain. These may be extracted using:

chainNodes=TreeData /@ GraphTree /@ chains

Or the method used by @Ben Izd:

chainNodes=Last /@ (VertexInComponent[#, Last@VertexList[#]] &) 
/@ chains

which is a bit longer to write and more difficult to understand and remember but it was about 200 times faster in my tests involving chains containing over a hundred vertices. Of course, this remark is important only for graphs containing many long chains.

The outputgraph is obtained easily using

VertexContract[inputgraph,chains]

Then we may use @Ben Izd's answer where I included the option to highlight the collapsed chains:

labels = Array["Chain" ~~ ToString[#] &, Length @ chainNodes];

AnnotationValue[{outputgraph, chainNodes}, VertexLabels] = labels;

Append[MapThread[Rule, {labels, chains}], HighlightGraph[Outputgraph, chainNodes]]

which leads to the desired result:

---

Edge collapsed-chain convention

Note: currently incomplete but provides a solution for many cases.

The method provided by @Szabolcs requires installing a package but the page provided in @Szabolcs answer makes the installation a very easy copy-paste-enter using Mathematica.

The output graph does not require computing the chains and is thus a much quicker solution when full knowledge of the chain content is not required.

If IGraph/M is not installed, please check @Szabolcs's answer.

The output graph is obtained using :

outputgraph=IGSmoothen[inputgraph]

If one only wishes to identify which edges correspond to collapsed chains, independently of which collapsed edge corresponds to which edge, then it is sufficient to use

outputgraph=IGSmoothen[inputgraph,EdgeLabels -> "EdgeWeight"]

where the edge weight of a collapsed chain is equal to the total number of edges**(see footnote). If the user wishes to have a more visual representation where the edges corresponding to collapsed chains are highlighted then one may use:

HighlightGraph[outputgraph, 
GraphDifference[outputgraph,inputgraph] //EdgeList]

If the user needs to identify which edge corresponds to which chain then further work is needed.

////////////////

Discussion on the convention for identifying collapsed chain edges with their chains

One may identify collapsed-chain edges with the original chains by looking at the last, or outflowing, vertex of a collapsed chain (for example vertex 11 in the above output example). These vertices are not vertices of the chains but correspond to the next, or outflowing, a vertex that comes right after the last vertex of a chain in the original input graph (for example 11 in the collapsed chain comes after 10 which is the last vertex in the chain 8->9->10). The last vertex rather than the first vertex is needed due to problems at the boundary of a graph (see for example the chain 1->2->3). Hence a natural identification, or association, can be made between the outflowing vertex of a collapsed chain and the chain it represents. This should be straightforward to implement but I do not have much time currently.

/////////////////////

////////////////////

**footnote: See @Szabolcs's answer for an image showing that the weights are also numerical (like 4. instead of 4)).

Answer 1

Take a look at IGSmoothen from the IGraph/M package. It contracts degree-2 vertices while retaining information about how long the "chain" was though the EdgeWeight attribute.

g = Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 
    3 \[DirectedEdge] 4, 4 \[DirectedEdge] 5, 6 \[DirectedEdge] 7, 
    7 \[DirectedEdge] 8, 5 \[DirectedEdge] 8, 8 \[DirectedEdge] 9}];


IGSmoothen[g, EdgeLabels -> "EdgeWeight", VertexLabels -> Automatic]

Answer 2

Let's say that a vertext is a member of a chain if its out-degree and in-degree are both less than 2. Then one approach would be to remove all non-chain vertices and then manipulate the resulting (perhaps disconnected) graph in various ways. Let's start by finding the non-chain vertices (I'm calling your original graph testGraph:

nonChainVertices = 
  Pick[
    VertexList[testGraph],
    Or@@@
      Map[
        GreaterThan[1],
        Transpose[{VertexInDegree[testGraph],VertexOutDegree[testGraph]}],
        {-1}]]
(* {8} *)

Now we delete them:

chainGraph = VertexDelete[testGraph, nonChainVertices]

Now let's keep track of vertices in chains:

chains = WeaklyConnectedComponents[chainGraph]
(* {{2,1,3,4,5},{6,7},{9}} *)

We can get the chains as their own graphs:

chainSubgraphs = Subgraph[testGraph, #] & /@ chains

You may want to discard the single vertex chain.

You can create a new graph from the original with the chains collapsed:

VertexContract[testGraph, chains]

You provided some labeling conventions in your post, but it's not clear to me that those were actual requirements--it seemed like you had other ideas for further processing, so I'll leave that up to you. At this point you have vertices grouped into chains, subgraphs representing the chains, and a collapsed graph.

Answer 3

I'm sure you'll find better approaches, here is a simple one:

Assuming we have our graph in variable g:

g = Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 
    3 \[DirectedEdge] 4, 4 \[DirectedEdge] 5, 6 \[DirectedEdge] 7, 
    7 \[DirectedEdge] 8, 5 \[DirectedEdge] 8, 8 \[DirectedEdge] 9}];

You can find vertices that have VertexOutDegree == 1 and are connected to VertexOutDegree == 1 && VertexInDegree == 1 with EdgeList:

allEdges = 
  EdgeList[g, _?(VertexOutDegree[g, #] == 
        1 &) \[DirectedEdge] _?(VertexOutDegree[g, #] == 1 && 
        VertexInDegree[g, #] == 1 &)]

(* Out (simplified): {1 - 2, 2 - 3, 3 - 4, 4 - 5, 6 - 7} *)

Now we group them by their root using VertexInComponent:

groupedEdges = GatherBy[allEdges, Last @ VertexInComponent[g, First @ #] &]

(* Out (simplified): {{1 - 2, 2 - 3, 3 - 4, 4 - 5}, {6 - 7}} *)

Then you can trace down to find the last node in the chain:

targetNodes = 
  TakeSmallestBy[#, Length@VertexOutComponent[g, Last @ #] &, 1][[1, 
      2]] & /@ groupedEdges

(* Out: {5, 7} *)

Delete vertices (while keeping the last nodes), create labels, and assign them:

g2 = VertexDelete[g, Complement[VertexList @ Catenate @ groupedEdges, targetNodes]];

labels = Array["Chain" ~~ ToString[#] &, Length @ targetNodes];

AnnotationValue[{g2, targetNodes}, VertexLabels] = labels;

Append[MapThread[Rule, {labels, Graph /@ groupedEdges}], g2]

Output: