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