# Iteratively strip off simply connected edges in graph?

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]} }

• shouldn't the last step give { {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }? – kglr Nov 7 '18 at 22:03
• @kglr I'd like all edges to be unique, without double counting. If an edge triggers for incoming classification, it is spent and is not available to be classified as outgoing any more. – Kagaratsch Nov 7 '18 at 22:33

sourceEdges = IncidenceList[#, GeneralUtilitiesGraphSources @ # ]&;
simpleSinks = Select[GeneralUtilitiesGraphSinks[#],
Function[v, VertexInDegree[#, v] <= 1]] &;
sinkEdges = Complement[IncidenceList[#, simpleSinks @ #], sourceEdges @ #] &;
rest = Complement[#, sourceEdges @ #, sinkEdges @ #] &;
f = Rest @ NestWhileList[{sourceEdges @ #[], sinkEdges @ #[], rest @ #[]}&,
{{}, {}, #}, #[] =!= {}&]&;


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 GraphComputationSourceVertexList and GraphComputationSinkVertexList for GeneralUtilitiesGraphSources and GeneralUtilitiesGraphSinks, respectively.

• I wonder if GeneralUtilities'GraphSinks would trigger on {2->3} and {4->3} in a situation like { {1->2} , {2->3} , {4->3} , {5->4} }, where {2->3} and {4->3} do point to a sink but are not simply connected to the rest of the graph? Asking, since I'd actually like to avoid this in my case. – Kagaratsch Nov 7 '18 at 22:26
• @Kagaratsch, not sure I understand el = { {1->2} , {2->3} , {4->3} , {5->4} }, but GeneralUtilitiesGraphSinks @Flatten[el] gives {3}. – kglr Nov 7 '18 at 22:35
• I see, that is what I was afraid of. In my application case I am only looking for sources and sinks which are simply connected to the rest of the graph. – Kagaratsch Nov 7 '18 at 22:37
• @Kagaratsch, sounds like the example in your question does not reflect your requirements accurately. Adding the example in your comment to your post with some explanation would be useful. – kglr Nov 7 '18 at 22:50
• Added an edit to the question. – Kagaratsch Nov 7 '18 at 23:11
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[] (* removed vertices *)
r[] (* removed edges *)
r[] //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"
]
] 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.