3
$\begingroup$

Suppose we have the given network 'graph', which we get based on the set 'edges':

edges = {1 <-> 2, 3 <-> 4, 5 <-> 6, 7 <-> 5, 7 <-> 8, 9 <-> 7,  10 <-> 11, 12 <-> 1, 13 <-> 3, 14 <-> 9, 15 <-> 10, 16 <-> 12, 17 <-> 13, 18 <-> 14, 19 <-> 20, 21 <-> 15, 22 <-> 23, 24 <-> 25, 24 <-> 16, 26 <-> 27, 28 <-> 26, 29 <-> 28, 29 <-> 17, 30 <-> 29, 31 <-> 30, 32 <-> 33, 34 <-> 32, 34 <-> 18, 35 <-> 19, 36 <-> 35, 36 <-> 21, 23 <-> 36, 23 <-> 37, 38 <-> 39, 25 <-> 40, 41 <-> 42, 41 <-> 29, 43 <-> 31, 33 <-> 44, 45 <-> 34, 37 <-> 46, 39 <-> 47, 48 <-> 38, 49 <-> 48, 50 <-> 51, 40 <-> 50, 52 <-> 40, 53 <-> 52, 54 <-> 55, 56 <-> 54, 57 <-> 56, 58 <-> 57, 42 <-> 59, 60 <-> 43, 60 <-> 61, 44 <-> 62, 63 <-> 45, 46 <-> 64, 46 <-> 65, 47 <-> 66, 51 <-> 49, 67 <-> 40, 68 <-> 53, 55 <-> 68, 69 <-> 58, 59 <-> 69, 61 <-> 70, 62 <-> 70, 71 <-> 63, 64 <-> 72, 66 <-> 73, 74 <-> 67, 70 <-> 75, 72 <-> 76, 72 <-> 71, 77 <-> 65, 73 <-> 78, 79 <-> 74, 75 <-> 80, 76 <-> 81, 82 <-> 79, 83 <-> 84, 85 <-> 86, 80 <-> 87,  80 <-> 85, 81 <-> 88, 84 <-> 82, 87 <-> 89, 90 <-> 91, 89 <-> 92, 89 <-> 90, 93 <-> 88, 92 <-> 94, 95 <-> 93, 96 <-> 97, 94 <-> 96,  98 <-> 95, 99 <-> 98, 100 <-> 99, 96 <-> 101, 101 <-> 102,  102 <-> 103, 102 <-> 104, 102 <-> 105, 59 <-> 106, 105 <-> 107, 105 <-> 108, 108 <-> 109, 108 <-> 110, 97 <-> 111, 97 <-> 112, 111 <-> 113, 111 <-> 114};
graph = Graph[edges, VertexLabels -> "Name", GraphLayout -> "RadialEmbedding"]

enter image description here

This graph should be divided according to the scheme:

enter image description here

My suggestion is as follows.


Searching for '1'


Looking for the longest path in the graph:

graph = Graph[edges, GraphLayout -> "RadialEmbedding"];
pu1 = GraphPeriphery[graph, Method -> "PseudoDiameter"];
pu2 = FindShortestPath[graph, pu1[[1]], pu1[[2]]];
HighlightGraph[graph, Style[pu2, Blue], ImageSize -> 500, GraphHighlight -> EdgeList[graph], VertexSize -> 1]

enter image description here

All '1' in this graph:

length1 = Length[pu2] - 1 (*Out: 47*)

'length1' is our first result!


Searching for '2'


Looking for nodes with degrees greater than 2:

degree = Merge[{CountsBy[edges, First], CountsBy[edges, Last]}, Total];
degree1 = Keys@Select[degree, LessEqualThan[2]];
degree2 = Complement[pu2, degree1]
HighlightGraph[graph, Style[degree2, Blue], ImageSize -> 500, GraphHighlight -> EdgeList[graph], VertexSize -> 1]

enter image description here

Then we tear the graph along path '1':

graph = Graph[edges, VertexLabels -> "Name", GraphLayout -> "RadialEmbedding"];
v1 = VertexDelete[graph, pu2]

enter image description here

And here comes the problem. The same operation should be done for each element of the 'v1' graph as for the path '1'. Then we get 11 results, which will be a set of paths '2' (length2). This will be our second result. E.t.c.... Each longest path in the 'v1' subgraphs should start with the node located on path '1'. For example, for the widest subgraph 'v1', look for the longest path starting from node number '70'.

Maybe further considerations will help:):

ver = VertexList[v1];
HighlightGraph[graph, Style[ver, Blue], ImageSize -> 500, GraphHighlight -> EdgeList[graph], VertexSize -> 1]
n1 = Table[{degree2[[i]], Complement[AdjacencyList[graph, degree2[[i]]], pu2]}, {i, 1, Length[degree2]}]
n2 = Table[{n1[[i, 1]] <-> n1[[i, 2, j]]}, {i, 1, Length[n1]}, {j, 1, Length[n1[[i, 2]]]}]
$\endgroup$
1
  • 2
    $\begingroup$ The problem you pose reminds me of the procedure one follows to assign a systematic name to organic chemical compounds, where one also has to identify “longest chains” and branches, and repeat within the branches iteratively. Algorithms exist to solve that problem unequivocally; these have widespread implementation. Perhaps you could look some of those up and see if you can adapt them. $\endgroup$
    – MarcoB
    Jun 15, 2020 at 14:53

3 Answers 3

3
$\begingroup$

Here's some example you can start:

findLongestPath[g_] := 
    PathGraph[FindShortestPath[g, ##] & @@ GraphPeriphery[g, Method -> "PseudoDiameter"]]

splitGraph[g_, path_] :=
 Block[{sg, sjunction, nedges},
    sg = Graph[EdgeList[EdgeDelete[g, EdgeList[path]]]];
    sjunction = Select[VertexList[path], VertexDegree[sg, #] > 1 &];
    If[Length[sjunction] > 0,
      VertexReplace[#, "j"[x_, _] :> x] & /@ 
        ConnectedGraphComponents[EdgeAdd[VertexDelete[sg,sjunction], 
          Flatten[(Function[y, "j"[#, y] \[UndirectedEdge] y] /@ 
               AdjacencyList[sg, #]) & /@ sjunction]]],
     ConnectedGraphComponents[sg]
    ]
  ]

and you could use Reap and FixedPoint:

levels = Reap[
    Module[{i = 0}, 
     FixedPoint[(i++; 
        Flatten[splitGraph[#, 
            Sow[findLongestPath[#], i]] & /@ #]) &, {graph}]]][[2]];

It gives the list of path graphs by level.

HighlightGraph[graph, levels]

enter image description here

$\endgroup$
0
2
$\begingroup$

Improvement on first step:

findDiameterPath[g_?UndirectedGraphQ] := 
 Module[{d = GraphDistanceMatrix[g], u, v, pos}, 
  pos = First@Position[d, Max[d]];
  {u, v} = Part[VertexList[g], pos];
  PathGraph@FindShortestPath[g, u, v]]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you. I think that this is not an improvement but rather an alternative solution. This code uses, among others 'GraphDistance Matrix [...]' and hence the level of NxN complexity type and thus for large networks (several million nodes) this function is inappropriate (it will fill any computer memory). $\endgroup$
    – ralph
    Jun 16, 2020 at 5:22
2
$\begingroup$

We pick one of the nodes on the GraphPeriphery as the root and find the shortest paths to the root from all the leaves. Then recursively prune the paths removing parts that belong to longer paths, and group non-disjoint pruned paths.

root = GraphPeriphery[edges][[1]];
leaves = DeleteCases[root] @ VertexList[edges, _?(VertexDegree[edges, #] == 1 &)];
pathsToRoot = ReverseSort[FindShortestPath[edges, root, #] & /@ leaves];

Two simple functions for pruning and grouping:

ClearAll[prunePaths, groupPaths, step]

prunePaths = ReverseSort @
  Map[DeleteCases[Alternatives @@ First[#]]] @ Rest[#] &;

groupPaths =  Gather[#, IntersectingQ] &;

A function to combine prunePaths and groupPaths and add annotations as we step through:

annotated[i_] := Map[{{i, Flatten @ Map[First] @ #}, 
   Map[prunePaths] @* Select[ Length[#] > 1 &] @ #} &] @* Map[groupPaths];

step = # /. {{i_Integer, a_List}, b : {{{__Integer} ..} ...}} :>
     {i -> a, annotated[i + 1][b]} &;

Start with the longest path annotated with 1 and the remaining paths pruned:

start = {{1, First @ #}, {prunePaths @ #}} & @ pathsToRoot;

layers = Merge[Flatten][Flatten @ FixedPoint[step, start]]
 <|1 -> {11, 10, 15, 21, 36, 23, 37, 46, 64, 72, 71, 63, 45, 34, 32, 33, 44, 62, 70, 
   61, 60, 43, 31, 30, 29, 41, 42, 59, 69, 58, 57, 56, 54, 55, 68, 53,
   52, 40, 50, 51, 49, 48, 38, 39, 47, 66, 73, 78}, 
 2 -> {75, 80, 87, 89, 92, 94, 96, 101, 102, 105, 108, 110, 76, 81, 88, 93, 95, 
   98, 99, 100, 67, 74, 79, 82, 84, 83, 25, 24, 16, 12, 1, 2, 18, 14, 9, 7, 5, 
   6, 17, 13, 3, 4, 35, 19, 20, 28, 26, 27, 65, 77, 106, 22}, 
 3 -> {97, 111, 114, 90, 91, 85, 86, 109, 107, 104, 103, 8}, 
 4 -> {113, 112}|>
vertexLayers = Association[Flatten @ KeyValueMap[Thread[#2 -> #] &]@layers]

edgeLayers = AssociationThread[#, # /. UndirectedEdge[a_, b_] :> 
    Max[vertexLayers /@ {a, b}]] & @ edges;

colors = {Red, Green, Blue, Orange};
 
SetProperty[graph, {BaseStyle -> Thick, 
  EdgeStyle -> {e_ :> colors[[edgeLayers@e]]}, 
  VertexStyle -> {v_ :> colors[[vertexLayers[v]]]}}]

enter image description here

v2 = Pick[VertexList@edges, VertexDegree@edges, 2];

vCoords = AssociationThread[VertexList[graph], GraphEmbedding[graph]];

edgeLabel = Max[vertexLayers /@ (List @@ #)] &;

pruned = GraphUnion @@ 
   (PathGraph /@ (DeleteCases[Alternatives @@ v2] /@ pathsToRoot));

SetProperty[pruned, 
 {ImageSize -> 600, BaseStyle -> CapForm["Round"], 
  EdgeStyle -> {e_ :> (Directive[ColorData[97]@#, 
         AbsoluteThickness[10/#]] &@edgeLabel[e])},
  VertexSize -> 0, EdgeLabels -> {e_ :> edgeLabel[e]}, 
  VertexCoordinates -> {v_ :> vCoords[v]}}]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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