# How can I reduce a directed graph to only its "junctions"?

I'd like to take a directed graph, e.g.

input = {
13 -> 7, 7 -> 0, 0 -> 16, 16 -> 2, 2 -> 15,
10 -> 5, 5 -> 12, 12 -> 18, 18 -> 15,
17 -> 18,
15 -> 6, 6 -> 8, 8 -> 4,
9 -> 8,
4 -> 19, 19 -> 11, 11 -> 1, 1 -> 20, 20 -> 3, 3 -> 4,
14 -> 19};
GraphPlot[input, VertexLabeling -> True] ...and reduce it to only the "junctions," e.g.

output = {
13 -> 15,
10 -> 18,
18 -> 15,
17 -> 18,
15 -> 8,
8 -> 4,
9 -> 8,
4 -> 19,
19 -> 4,
14 -> 19};
GraphPlot[output, VertexLabeling -> True] In the end, I'd also like to label the edges with the number of nodes that were "omitted" during the reduction, e.g. 4, between 13 and 15. It should be mentioned that the input is guaranteed to be a sinkless finite digraph.

I've been writing a (naive) algorithim that simply traverses nodes until reaching a visited node, to generate "paths," segmenting these paths when another path joins to it in the middle. This generates a list of all the segments, e.g.

segments = {
{13, 7, 0, 16, 2, 15},
{10, 5, 12, 18},
{18, 15},
{17, 18},
{15, 6, 8},
{9, 8},
{8, 4},
{4, 19},
{14, 19},
{19, 11, 1, 20, 3, 4}
}


Then, it's easy to construct the graph I desire by reducing each list to First@#->Last@#, while storing Length@#-2 as an edge weight.

My function is nearing completion, but I'm beginning to wonder if there isn't an easier, built-in way to do this in $Mathematica$. I've browsed through Graphs And Networks, in particular "Computation on Graphs," but I don't see anything that fits what I'm trying to do. I could be missing terminology, however.

Does someone know of a more elegant way to achieve my aim, than my algorithm?

• You should use Graph instead of GraphPlot to display the direction of the edges. So Graph[output, VertexLabels ->"Name"] May 29, 2016 at 13:15
• Or you may use DirectedEdges -> True with GraphPlot. May 29, 2016 at 14:06

Okay - never contributed before so I hope I don't screw up this answer. This will, I believe, do what you're looking for. It just finds all the "junctions" and then repeatedly contracts the nodes of degree 2 around each such junction until they're all gone. reduce[g,v] removes the degree 2 vertices around vertex v and reduce[g] applies that to all the junctions (i.e., non-degree 2 vertices) in the graph.

reduce[g_, v_] :=
FixedPoint[
VertexContract[#, {v,
AdjacencyList[#, v] /.vtx_ /; VertexDegree[g, vtx] != 2 -> Nothing}] &,
g]

reduce[g_] :=
Fold[reduce[#1, #2] &, g,
VertexList[g] /. v_ /; VertexDegree[g, v] == 2 -> Nothing] • Spiffed up the code using some ideas from @Yode and added the final result. May 30, 2016 at 1:50
• Look so good.:)
– yode
May 30, 2016 at 14:06
• I have changed the label into right ordering.:)
– yode
May 30, 2016 at 18:52

# Method 1

input = {13 -> 7, 7 -> 0, 0 -> 16, 16 -> 2, 2 -> 15, 10 -> 5, 5 -> 12,
12 -> 18, 18 -> 15, 17 -> 18, 15 -> 6, 6 -> 8, 8 -> 4, 9 -> 8,
4 -> 19, 19 -> 11, 11 -> 1, 1 -> 20, 20 -> 3, 3 -> 4, 14 -> 19};
g = Graph[input, VertexLabels -> "Name"] edge = IncidenceList[g, VertexList[g, _?(VertexDegree[g, #] == 2 &)]];
Fold[EdgeContract, g, edge] # Method 2

Since we have some trouble on label.I update it like following

Find all vertices whose degree is 2

v = VertexList[g, _?(VertexDegree[g, #] == 2 &)]


{7, 0, 16, 2, 5, 12, 6, 11, 1, 20, 3}

Cluster v as whether adjacent each other.Actually I don't like this step.I think must have some simple and efficient method can cluster they.If you know it,tell me please.

mat = AdjacencyMatrix[g]; group =
WeaklyConnectedComponents@
RelationGraph[mat[[VertexIndex[g, #1], VertexIndex[g, #2]]] == 1 &,
v, VertexLabels -> "Name"]


{{11, 1, 20, 3}, {7, 0, 16, 2}, {5, 12}, {6}}

Get the result with the right label.

edge = DirectedEdge @@
TopologicalSort[IncidenceList[g, #]][[{1, -1}]] & /@ group; • I love it! Does have the niggling problem that the vertex labels disappear on many nodes which doesn't happen with my much more clunky construct below. May 29, 2016 at 18:30
options={VertexLabels -> Placed["Name",Center],
VertexShapeFunction->"Square", VertexSize->.8, VertexStyle->Orange};
g1= Graph[Range[0,20], input, ##&@@options] junctions = VertexList[g1,_?((VertexOutDegree[g1, #] >= 2||VertexInDegree[g1, #] >= 2)&)];
sources = VertexList[g1, _?(VertexInDegree[g1,#] == 0 &)];
others = Complement[VertexList[g1], junctions];

contverts = Most/@ DeleteCases[DeleteDuplicates[ SortBy[ Select[Join @@
Outer[FindShortestPath[g1,##]&, Union[sources,junctions], junctions] /.
{}|{_}:>Sequence[],
Intersection[#, others] != {} && Length[Intersection[#, junctions]] <= 2&],
Length[#]&], Length[Intersection[##]] >= 2&], {_,_}];

Graph[VertexList @ #, EdgeList @ #, VertexSize->.5, ##&@@options]& @
Fold[VertexContract, g1, contverts] Note: Using @yode's edge and Fold[EdgeContract, g1, edge], we need further processing to get the vertex labels right. As is it gives:

Graph[VertexList @ #, EdgeList @ #, VertexSize->.6, ##&@@options]&@
Fold[EdgeContract, g1, edge] • Good guidance for me.Thanks a lots.:)
– yode
May 29, 2016 at 19:16
• But the wrong ordering.:)
– yode
May 29, 2016 at 19:21

Delete all vertices of degree = 2:

g = RandomGraph[{20,30}, VertexLabels-> "Name"];
myVertexDegrees = VertexDegree[g, #] & /@ VertexList[g];
vertexestoremove = Flatten@Position[myVertexDegrees, 2];
mygraph = VertexDelete[g, vertexestoremove];
Graph[mygraph, VertexLabels -> "Name"]

• This isn't how I interpret OP's question. How do you use this to recreate his second graph above? May 29, 2016 at 9:24