Iteratively strip off simply connected edges in graph?
up vote
6
down vote
favorite
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]} }
list-manipulation function-construction graphs-and-networks
add a comment |
up vote
6
down vote
favorite
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]} }
list-manipulation function-construction graphs-and-networks
shouldn't the last step give{ {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }
?
– kglr
Nov 7 at 22:03
@kglr I'd like all edges to be unique, without double counting. If an edge triggers forincoming
classification, it is spent and is not available to be classified asoutgoing
any more.
– Kagaratsch
Nov 7 at 22:33
add a comment |
up vote
6
down vote
favorite
up vote
6
down vote
favorite
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]} }
list-manipulation function-construction graphs-and-networks
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]} }
list-manipulation function-construction graphs-and-networks
list-manipulation function-construction graphs-and-networks
edited Nov 7 at 23:59
asked Nov 7 at 21:00
Kagaratsch
4,53631246
4,53631246
shouldn't the last step give{ {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }
?
– kglr
Nov 7 at 22:03
@kglr I'd like all edges to be unique, without double counting. If an edge triggers forincoming
classification, it is spent and is not available to be classified asoutgoing
any more.
– Kagaratsch
Nov 7 at 22:33
add a comment |
shouldn't the last step give{ {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }
?
– kglr
Nov 7 at 22:03
@kglr I'd like all edges to be unique, without double counting. If an edge triggers forincoming
classification, it is spent and is not available to be classified asoutgoing
any more.
– Kagaratsch
Nov 7 at 22:33
shouldn't the last step give
{ {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }
?– kglr
Nov 7 at 22:03
shouldn't the last step give
{ {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }
?– kglr
Nov 7 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 at 22:33
@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 at 22:33
add a comment |
4 Answers
4
active
oldest
votes
up vote
5
down vote
accepted
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.
I wonder ifGeneralUtilities'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 at 22:26
@Kagaratsch, not sure I understandel = { {1->2} , {2->3} , {4->3} , {5->4} }
, butGeneralUtilities`GraphSinks @Flatten[el]
gives{3}
.
– kglr
Nov 7 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 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 at 22:50
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
add a comment |
up vote
4
down vote
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.
add a comment |
up vote
3
down vote
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
]
add a comment |
up vote
2
down vote
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.
New contributor
add a comment |
4 Answers
4
active
oldest
votes
4 Answers
4
active
oldest
votes
active
oldest
votes
active
oldest
votes
up vote
5
down vote
accepted
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.
I wonder ifGeneralUtilities'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 at 22:26
@Kagaratsch, not sure I understandel = { {1->2} , {2->3} , {4->3} , {5->4} }
, butGeneralUtilities`GraphSinks @Flatten[el]
gives{3}
.
– kglr
Nov 7 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 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 at 22:50
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
add a comment |
up vote
5
down vote
accepted
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.
I wonder ifGeneralUtilities'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 at 22:26
@Kagaratsch, not sure I understandel = { {1->2} , {2->3} , {4->3} , {5->4} }
, butGeneralUtilities`GraphSinks @Flatten[el]
gives{3}
.
– kglr
Nov 7 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 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 at 22:50
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
add a comment |
up vote
5
down vote
accepted
up vote
5
down vote
accepted
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.
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.
edited Nov 8 at 1:06
answered Nov 7 at 22:11
kglr
170k8193397
170k8193397
I wonder ifGeneralUtilities'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 at 22:26
@Kagaratsch, not sure I understandel = { {1->2} , {2->3} , {4->3} , {5->4} }
, butGeneralUtilities`GraphSinks @Flatten[el]
gives{3}
.
– kglr
Nov 7 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 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 at 22:50
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
add a comment |
I wonder ifGeneralUtilities'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 at 22:26
@Kagaratsch, not sure I understandel = { {1->2} , {2->3} , {4->3} , {5->4} }
, butGeneralUtilities`GraphSinks @Flatten[el]
gives{3}
.
– kglr
Nov 7 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 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 at 22:50
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
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 at 22:26
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 at 22:26
@Kagaratsch, not sure I understand
el = { {1->2} , {2->3} , {4->3} , {5->4} }
, but GeneralUtilities`GraphSinks @Flatten[el]
gives {3}
.– kglr
Nov 7 at 22:35
@Kagaratsch, not sure I understand
el = { {1->2} , {2->3} , {4->3} , {5->4} }
, but GeneralUtilities`GraphSinks @Flatten[el]
gives {3}
.– kglr
Nov 7 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 at 22:37
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 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 at 22:50
@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 at 22:50
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
Added an edit to the question.
– Kagaratsch
Nov 7 at 23:11
add a comment |
up vote
4
down vote
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.
add a comment |
up vote
4
down vote
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.
add a comment |
up vote
4
down vote
up vote
4
down vote
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.
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.
answered Nov 7 at 21:44
Szabolcs
156k13425914
156k13425914
add a comment |
add a comment |
up vote
3
down vote
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
]
add a comment |
up vote
3
down vote
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
]
add a comment |
up vote
3
down vote
up vote
3
down vote
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
]
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
]
answered Nov 8 at 2:21
Carl Woll
64.6k284168
64.6k284168
add a comment |
add a comment |
up vote
2
down vote
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.
New contributor
add a comment |
up vote
2
down vote
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.
New contributor
add a comment |
up vote
2
down vote
up vote
2
down vote
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.
New contributor
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.
New contributor
edited Nov 8 at 15:27
New contributor
answered Nov 8 at 15:21
geofurb
212
212
New contributor
New contributor
add a comment |
add a comment |
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f185556%2fiteratively-strip-off-simply-connected-edges-in-graph%23new-answer', 'question_page');
}
);
Post as a guest
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
shouldn't the last step give
{ {DirectedEdge[3, 5]} ,{DirectedEdge[3, 5]} , { } }
?– kglr
Nov 7 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 asoutgoing
any more.– Kagaratsch
Nov 7 at 22:33