# 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"] – DavidC May 29 '16 at 13:15
• Or you may use DirectedEdges -> True with GraphPlot. – DavidC May 29 '16 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. – Darrell Plank May 30 '16 at 1:50
• Look so good.:) – yode May 30 '16 at 14:06
• I have changed the label into right ordering.:) – yode May 30 '16 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. – Darrell Plank May 29 '16 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 '16 at 19:16
• But the wrong ordering.:) – yode May 29 '16 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? – C. E. May 29 '16 at 9:24