6
$\begingroup$

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]

enter image description here

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]} } enter image description here

In the next iteration step it should give

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

{ {DirectedEdge[2, 3]} ,

{DirectedEdge[5, 6]} ,

{DirectedEdge[3, 5]} } enter image description here

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]

enter image description here

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

$\endgroup$
  • $\begingroup$ shouldn't the last step give { {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }? $\endgroup$ – kglr Nov 7 '18 at 22:03
  • $\begingroup$ @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. $\endgroup$ – Kagaratsch Nov 7 '18 at 22:33
5
$\begingroup$
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.

$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Kagaratsch Nov 7 '18 at 22:26
  • $\begingroup$ @Kagaratsch, not sure I understand el = { {1->2} , {2->3} , {4->3} , {5->4} }, but GeneralUtilities`GraphSinks @Flatten[el] gives {3}. $\endgroup$ – kglr Nov 7 '18 at 22:35
  • $\begingroup$ 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. $\endgroup$ – Kagaratsch Nov 7 '18 at 22:37
  • $\begingroup$ @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. $\endgroup$ – kglr Nov 7 '18 at 22:50
  • $\begingroup$ Added an edit to the question. $\endgroup$ – Kagaratsch Nov 7 '18 at 23:11
4
$\begingroup$
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.

$\endgroup$
3
$\begingroup$

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

$\endgroup$
2
$\begingroup$

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.