# Does anyone know how to speed it up? More efficient way to derive a new graph from a given one

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:

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:

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?

• Can you share what you've done? Nov 14, 2017 at 20:26
• I will wait for some response. My code is relatively long. Nov 14, 2017 at 20:57
• How did you get the coloring of your graph1? Nov 14, 2017 at 22:13
• 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} Nov 15, 2017 at 9:38
• 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. Nov 15, 2017 at 19:03

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];
new = VertexDelete[new, First@long];
Map[
refactor[Subgraph[new, First @ ConnectedComponents[new, #]], #]&,
]
]

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

transform[g_] := Graph[
Fold[VertexContract, g, contractions[g]],

transform[Graph @ g1]