3
$\begingroup$

Let us consider a graph1.

g1 = {1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 6 <-> 7, 7 <-> 19,19 <-> 20, 19 <-> 22, 20 <-> 21, 20 <-> 23, 7 <-> 8, 8 <-> 24, 24 <-> 25, 24 <-> 26, 8 <-> 9, 9 <-> 10, 9 <-> 27, 27 <-> 28, 27 <-> 29, 10 <-> 11, 11 <-> 12, 12 <-> 13, 13 <-> 14, 14 <-> 15,15 <-> 16, 16 <-> 17, 17 <-> 18, 12 <-> 30, 30 <-> 31, 31 <-> 32, 32 <-> 33, 30 <-> 34, 31 <-> 35, 32 <-> 36, 34 <-> 37, 34 <-> 38, 2 <-> 39, 3 <-> 40, 4 <-> 41, 5 <-> 42, 6 <-> 43, 10 <-> 44, 11 <-> 45, 13 <-> 46, 14 <-> 47, 15 <-> 48, 16 <-> 49, 17 <-> 50,18 <-> 51, 18 <-> 52, 1 <-> 53, 1 <-> 54}; 

graph1 = Graph[g1, GraphLayout -> "SpringEmbedding", EdgeStyle -> Thick]

The color version of graph1 looks like this:

graph1

Let us imagine that it is a network of streets. The red trail is the longest street. The longest street connects directly to 18 smaller streets — this is the degree of the middle vertex in graph1. The second longest street is dark blue – this street connects to three other streets, and so on. In this way we obtain graph2:

graph2

g2 = {1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 1 <-> 6, 1 <-> 7, 1 <-> 8,1 <-> 9, 1 <-> 10, 1 <-> 11, 1 <-> 12, 9 <-> 13, 1 <-> 14, 1 <-> 15,1 <-> 16, 12 <-> 17, 1 <-> 18, 12 <-> 19, 12 <-> 20, 1 <-> 21,1 <-> 22, 1 <-> 23, 8 <-> 24, 4 <-> 25, 4 <-> 26, 20 <-> 27}; 

graph2 = Graph[g2, GraphLayout -> "RadialDrawing"]

I wrote a script which calculates graph2 based on graph1, but it is very slow. I need a simple script for calculating large networks.

Does anyone have an idea?

$\endgroup$
11
  • 3
    $\begingroup$ Can you share what you've done? $\endgroup$
    – jjc385
    Nov 14, 2017 at 20:26
  • $\begingroup$ I will wait for some response. My code is relatively long. $\endgroup$
    – ralph
    Nov 14, 2017 at 20:57
  • 1
    $\begingroup$ How did you get the coloring of your graph1? $\endgroup$ Nov 14, 2017 at 22:13
  • $\begingroup$ It is not clear what you mean by "longest street" and "second longest street". Can you define these precisely? For example, it is not at all clear to me what the expected result is for {1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 6 <-> 7, 7 <-> 8, 8 <-> 1, 4 <-> 9, 9 <-> 8, 2 <-> 10, 10 <-> 6} $\endgroup$
    – Szabolcs
    Nov 15, 2017 at 9:38
  • 1
    $\begingroup$ Just to be clear, I am not confused by the term "street" (I don't think it should have been edited out). My point was that these concepts are unclear if there are loops in the graph. If you only work with trees, it is important to say so. $\endgroup$
    – Szabolcs
    Nov 15, 2017 at 19:03

1 Answer 1

4
$\begingroup$

I think you can transform the graph by finding the longest path, vertex contracting the path, and then repeat starting with the new contracted vertex neighbors. Here is some code to do this:

longestPath[g_, s_:Automatic] := Module[{p = GraphPeriphery[g], ends},
    ends = If[s===Automatic, Subsets[p, {2}], Thread[{s, p}]];
    ends = First @ MaximalBy[ends, GraphDistance[g, Sequence@@#]&, 1];
    First @ FindPath[g,Sequence@@ends]
]

refactor[g_, s_:Automatic] := Module[{long, new, adj},
    If[VertexCount[g]<2, Return[]];
    long = Sow @ longestPath[g,s];
    new = VertexContract[g, long];
    adj = AdjacencyList[new, First@long];
    new = VertexDelete[new, First@long];
    Map[
        refactor[Subgraph[new, First @ ConnectedComponents[new, #]], #]&,
        adj
    ]
]

contractions[g_] := First @ Last @ Reap @ refactor[g]

transform[g_] := Graph[
    Fold[VertexContract, g, contractions[g]],
    GraphLayout -> "RadialEmbedding"
]

For your example:

transform[Graph @ g1]

enter image description here

$\endgroup$
3
  • $\begingroup$ Thank you. But there is a problem - errors appear - example: graph data is here: drive.google.com/drive/folders/… $\endgroup$
    – ralph
    Nov 15, 2017 at 6:47
  • $\begingroup$ I think the problem is with 'p = GraphPeriphery[g]'. It should be 'p = GraphPeriphery[g, Method -> "PseudoDiameter"]'. But the code is still slow. Can you enter some counter (at which stage of calculation is the code)? $\endgroup$
    – ralph
    Nov 15, 2017 at 8:21
  • $\begingroup$ Does anyone know how to speed it up? $\endgroup$
    – ralph
    Nov 18, 2017 at 15:06

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.