Xtykutl

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

]

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.