6
$\begingroup$

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]

enter image description here

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

enter image description here

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?

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

4 Answers 4

8
$\begingroup$

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

$\endgroup$
3
  • $\begingroup$ Spiffed up the code using some ideas from @Yode and added the final result. $\endgroup$ May 30, 2016 at 1:50
  • 1
    $\begingroup$ Look so good.:) $\endgroup$
    – yode
    May 30, 2016 at 14:06
  • $\begingroup$ I have changed the label into right ordering.:) $\endgroup$
    – yode
    May 30, 2016 at 18:52
7
$\begingroup$

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

$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$ May 29, 2016 at 18:30
3
$\begingroup$
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

$\endgroup$
2
  • $\begingroup$ Good guidance for me.Thanks a lots.:) $\endgroup$
    – yode
    May 29, 2016 at 19:16
  • $\begingroup$ But the wrong ordering.:) $\endgroup$
    – yode
    May 29, 2016 at 19:21
2
$\begingroup$

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"]
$\endgroup$
1
  • 3
    $\begingroup$ This isn't how I interpret OP's question. How do you use this to recreate his second graph above? $\endgroup$
    – C. E.
    May 29, 2016 at 9:24

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.