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

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]

enter image description here


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

enter image description here

edge = IncidenceList[g, VertexList[g, _?(VertexDegree[g, #] == 2 &)]];
Fold[EdgeContract, g, edge]

enter image description here

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]

enter image description here


options={VertexLabels -> Placed["Name",Center], 
         VertexShapeFunction->"Square", VertexSize->.8, VertexStyle->Orange};
   g1= Graph[Range[0,20], input, ##&@@options]

Mathematica graphics

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]

Mathematica graphics

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]

Mathematica graphics

Tags:

Graphs And Networks

Recent Posts