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]]
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]]
You can also use GraphComputation`SourceVertexList
and GraphComputation`SinkVertexList
for GeneralUtilities`GraphSources
and GeneralUtilities`GraphSinks
, respectively.
g = Graph[edges, VertexLabels -> Automatic]
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]]}
]
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]
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"
]
]
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
]