Dfyjkt

Consider a set of edges composing a directed graph. For example:

edges = DirectedEdge[1, 2], DirectedEdge[2, 3], DirectedEdge[4, 3], DirectedEdge[3, 5], DirectedEdge[5, 6], DirectedEdge[6, 7];
Graph[edges]

I would like to have a function stripOff that iteratively strips off the outer edges that are simply connected to the rest, and returns them together with the remaining graph:

incoming1, outgoing1, remains1= stripOff[edges]
Graph[remains1]

DirectedEdge[1, 2],DirectedEdge[4, 3] ,

DirectedEdge[6, 7] ,

DirectedEdge[2, 3], DirectedEdge[3, 5], DirectedEdge[5, 6]

In the next iteration step it should give

incoming2, outgoing2, remains2= stripOff[remains1]
Graph[remains2]

DirectedEdge[2, 3] ,

DirectedEdge[5, 6] ,

DirectedEdge[3, 5]

And finally in the last iteration step

incoming3, outgoing3, remains3= stripOff[remains2]

DirectedEdge[3, 5] ,

,

Is there a quick way to construct such a stripOff function in mathematica? Thanks for any suggestion!

EDIT:

Note that I am trying to iteratively strip off external legs of the graph, which are connected to a vertex only on one side, not on both.

Even though the graph

edges = DirectedEdge[1, 2], DirectedEdge[2, 3], DirectedEdge[4, 3], DirectedEdge[5, 4];
Graph[edges]

contains a sink in the middle, the function should not cut the graph in two, but only strip off outer legs:

incoming, outgoing, remains= stripOff[edges]

DirectedEdge[1, 2], DirectedEdge[5, 4] ,

,

DirectedEdge[2, 3], DirectedEdge[4, 3]

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(
beginarraycccccc
-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 \
endarray
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(
beginarraycccccc
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 \
endarray
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(
beginarraycccccc
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 \
endarray
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
]

What you're looking for is called a "kcore" of the graph: the set of vertices with at least k edges to other vertices of the core.

Mathematica has a function that will find this for you:
https://reference.wolfram.com/language/ref/KCoreComponents.html
https://reference.wolfram.com/language/example/FindTheKCoreComponentsOfAGraph.html

To find the removed edges (if the iteration in which they are removed is not important), simply iterate over the original edge list and count those which are not attached to a vertex in the 2-core.