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

Question

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?

Answer 1

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]

Answer 2

---

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;
EdgeAdd[VertexDelete[g, v], edge]

Answer 3

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]

Answer 4

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