Iteratively strip off simply connected edges in graph?

sourceEdges = IncidenceList[#, GeneralUtilities`GraphSources @ # ]&;
simpleSinks = Select[GeneralUtilities`GraphSinks[#], 
    Function[v, VertexInDegree[#, v] <= 1]] &;
sinkEdges = Complement[IncidenceList[#, simpleSinks @ #], sourceEdges @ #] &;
rest = Complement[#, sourceEdges @ #, sinkEdges @ #] &;
f = Rest @ NestWhileList[{sourceEdges @ #[[3]], sinkEdges @ #[[3]], rest @ #[[3]]}&,
 {{}, {}, #}, #[[3]] =!= {}&]&;

Examples:

edges1 = {DirectedEdge[1, 2], DirectedEdge[2, 3], DirectedEdge[4, 3], DirectedEdge[3, 5],
  DirectedEdge[5, 6], DirectedEdge[6, 7]};
f @ edges1

{{{1 -> 2, 4 -> 3}, {6 -> 7}, {2 -> 3, 3 -> 5, 5 -> 6}},
{{2 -> 3}, {5 -> 6}, {3 -> 5}},
{{3 -> 5}, {}, {}}}

g1 = Graph[edges1, VertexSize -> Large, 
   VertexLabels -> Placed["Name", Center], ImageSize -> {200, 300}];
Row[HighlightGraph[g1, #, PlotLabel -> Column[#]] & /@ f[edges1]]

enter image description here

edges2 = {DirectedEdge[1, 2], DirectedEdge[2, 3], DirectedEdge[4, 3], 
   DirectedEdge[5, 4]} ;
f @ edges2

{{{1 -> 2, 5 -> 4}, {}, {2 -> 3, 4 -> 3}},
{{2 -> 3, 4 -> 3}, {}, {}}}

g2 = Graph[edges2, VertexSize -> Large, 
   VertexLabels -> Placed["Name", Center], ImageSize -> {200, 300}];
Row[HighlightGraph[g2, #, PlotLabel -> Column[#]] & /@ f[edges2]]

enter image description here

You can also use GraphComputation`SourceVertexList and GraphComputation`SinkVertexList for GeneralUtilities`GraphSources and GeneralUtilities`GraphSinks, respectively.


g = Graph[edges, VertexLabels -> Automatic]

enter image description here

source[g_?GraphQ] := Pick[VertexList[g], VertexInDegree[g], 0]
sink[g_?GraphQ] := Pick[VertexList[g], VertexOutDegree[g], 0]

strip[g_] :=
 With[{so = source[g], si = sink[g]},
  {Flatten[IncidenceList[g, #] & /@ so], 
   Flatten[IncidenceList[g, #] & /@ si], 
   VertexDelete[g, Join[so, si]]}
 ]

enter image description here

There are minor issues, such as returning an edge twice at the last step, but that should be easy (if tedious) to fix.


If you have a large graph, it will be faster to work with the vertex-edge incidence matrix instead of Graph objects. The edges you want to strip off will have either a 1 or a -1 depending on the direction of the directed edge. So, the simple edges you want to strip off will have a vertex with only a single 1 or -1 in the row. Let's take your example:

m = IncidenceMatrix[edges];
m //MatrixForm //TeXForm

$\left( \begin{array}{cccccc} -1 & 0 & 0 & 0 & 0 & 0 \\ 1 & -1 & 0 & 0 & 0 & 0 \\ 0 & 1 & 1 & -1 & 0 & 0 \\ 0 & 0 & -1 & 0 & 0 & 0 \\ 0 & 0 & 0 & 1 & -1 & 0 \\ 0 & 0 & 0 & 0 & 1 & -1 \\ 0 & 0 & 0 & 0 & 0 & 1 \\ \end{array} \right)$

The vertices that can be removed can be obtained with:

v = Clip[Unitize[m] . ConstantArray[1, Length @ First @ m], {1, 1}, {0, 0}]

{1, 0, 0, 1, 0, 0, 1}

The corresponding edges can be found with:

e = Unitize[v . Unitize[m]]

{1, 0, 1, 0, 0, 1}

The kind of edge can be determined using:

v . Mod[m, 3] . DiagonalMatrix[e]

{2, 0, 2, 0, 0, 1}

where 1 is an outgoing edge, 2 is an incoming edge, and 3 would be both an incoming and outgoing edge.

The matrix after removing the above vertices and edges can be found from:

m . DiagonalMatrix[1 - e] //MatrixForm //TeXForm

$\left( \begin{array}{cccccc} 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & -1 & 0 & 0 & 0 & 0 \\ 0 & 1 & 0 & -1 & 0 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 1 & -1 & 0 \\ 0 & 0 & 0 & 0 & 1 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ \end{array} \right)$

Here is a function that does one iteration:

iter[m_] := Module[{u = Unitize[m], o, v, e},
    o = ConstantArray[1, Length @ First @ u];
    v = Clip[u . o, {1, 1}, {0, 0}];
    e = Unitize[v . Unitize[m]];
    {
        v,
        v . Mod[m, 3] . SparseArray[Band[{1,1}] -> e],
        m . SparseArray[Band[{1,1}] -> 1 - e]
    }
]

For example:

r = iter[m];
r[[1]] (* removed vertices *)
r[[2]] (* removed edges *)
r[[3]] //MatrixForm //TeXForm

{1, 0, 0, 1, 0, 0, 1}

{2, 0, 2, 0, 0, 1}

$\left( \begin{array}{cccccc} 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & -1 & 0 & 0 & 0 & 0 \\ 0 & 1 & 0 & -1 & 0 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 1 & -1 & 0 \\ 0 & 0 & 0 & 0 & 1 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ \end{array} \right)$

Putting the above together:

res = NestWhileList[iter @* Last, iter[m], Positive @* Total @* First]

enter image description here

Deciding which edges are outgoing and incoming can be done with:

KeyDrop[
    GroupBy[Thread[edges -> res[[1, 2]]], Last -> First],
    0
]

<|2 -> {1 \[DirectedEdge] 2, 4 \[DirectedEdge] 3}, 1 -> {6 \[DirectedEdge] 7}|>

Converting the SparseArray back to a graph (the removed edges/vertices need to be eliminated from the sparse array) can be done with:

With[
    {
    v = Pick[Range @ Length @ res[[1, 1]], res[[1, 1]], 0],
    e = Pick[Range @ Length @ res[[1, 2]], res[[1, 2]], 0]
    },

    IncidenceGraph[
        v,
        res[[1, 3]][[v, e]],
        VertexLabels->"Name"
    ]
]

enter image description here

Your second example:

edges = {DirectedEdge[1, 2], DirectedEdge[2, 3], DirectedEdge[4, 3], DirectedEdge[5, 4]};
NestWhileList[
    iter @* Last,
    iter @ IncidenceMatrix[edges], 
    Positive @* Total @* First
]

enter image description here