The road in the graph

Question

Consider the graph:

kk={4612<->4613,4613<->4614,4642<->4612,4614<->4522,4798<->4642,4522<->4376,4536<->4798,4798<->4996,4376<->4201,4338<->4536,4813<->4996,4201<->4043,4074<->4338,4813<->4735,4043<->3813,3796<->4074,4646<->4735,3711<->3813,3665<->3796,4646<->4585,3711<->3450,3509<->3665,4584<->4585,3119<->3450,3177<->3509,4662<->4584,3119<->2911,2890<->3177,4729<->4662,2911<->2714,2642<->2890,4729<->4753,2551<->2714,2641<->2642,4875<->4753,2518<->2551,4972<->4875,2481<->2518,5081<->4972,2365<->2481,4967<->5081,2320<->2365,4938<->4967,2310<->2320,4937<->4938,2215<->2310,2310<->2317,4942<->4937,2053<->2215,2315<->2317,4923<->4942,1943<->2053,2315<->2316,4922<->4923,1942<->1943,2329<->2316,4880<->4922,2329<->2248,4721<->4880,2248<->2249,4673<->4721,4683<->4721,2249<->2246,4672<->4673,4508<->4683,2246<->2191,4831<->4672,4507<->4508,2191<->2093,4779<->4831,2093<->2052,4551<->4779,4717<->4779,2052<->2000,4551<->4409,4489<->4717,2000<->1961,4274<->4409,4323<->4489,1961<->1950,4224<->4274,4084<->4323,1950<->1951,4223<->4224,3876<->4084,1951<->1957,4336<->4223,3769<->3876,1957<->1948,4336<->4069,4232<->4336,3704<->3769,1948<->1949,3767<->4069,4103<->4232,3545<->3704,2054<->1949,3561<->3767,4055<->4103,3409<->3545,2054<->1996,3415<->3561,3899<->4055,3408<->3409,1996<->1997,3415<->3377,3898<->3899,3425<->3408,2043<->1997,3345<->3377,3905<->3898,3461<->3425,2043<->2128,3277<->3345,3689<->3905,3410<->3461,2091<->2128,3277<->3105,3459<->3689,3360<->3410,2091<->1946,2923<->3105,3458<->3459,3254<->3360,1946<->1838,2822<->2923,2923<->2894,3458<->3460,3239<->3254,1725<->1838,2772<->2822,2894<->2788,3407<->3460,3238<->3239,1725<->1531,2771<->2772,2788<->2598,3406<->3407,1531<->1342,2480<->2598,3514<->3406,1342<->1276,2480<->2402,3321<->3514,3514<->3504,1219<->1276,2402<->2400,3153<->3321,3504<->3272,1219<->1090,2400<->2401,3042<->3153,3023<->3272,1090<->1035,2793<->3042,3084<->3042,2850<->3023,997<->1035,2424<->2793,3008<->3084,2739<->2850,997<->960,2134<->2424,3007<->3008,2578<->2739,2739<->2645,960<->961,1914<->2134,2488<->2578,2645<->2356,1656<->1914,2278<->2488,2195<->2356,1655<->1656,2277<->2278,2195<->2023,1896<->2023,1895<->1896,2772<->1,1<->2,2<->3,2<->4,3277<->100,4<->5,5<->6,5<->7,5<->8,5<->9};

g1=Graph[kk]; 

gl1 = VertexList[g1]; 

gl2 = Table[VertexDegree[g1, gl1[[i]]], {i, 1, Length[gl1]}]; 

gl3 = Flatten[Position[gl2, _?(# != 2 &)]]; gl4 = Table[gl1[[gl3[[i]]]], {i, 1, Length[gl3]}]; 

g2=HighlightGraph[g1, Flatten[gl4], VertexSize -> 2, ImageSize -> 1200]

The graph g2 is a graph g1 with the designation of nodes with degree !=2. How to reduce the graph g2 to the weighted graph i.e. without nodes degree 2 where the weights are the number of removed nodes of degree 2. It looks like this:

I started like that:

gp = GraphPeriphery[g1, Method -> "PseudoDiameter"];

pu1 = Select[Subsets[gp, 2], Length[#] >= 2 &];

pu2 = Sort[Table[{Length[FindShortestPath[g1, pu1[[i, 1]], pu1[[i, 2]]]], pu1[[i]]}, {i, 1, Length[pu1]}], #1[[1]] > #2[[1]] &];

pu3 = pu2[[1, 2]];

gl1 = FindShortestPath[g1, pu3[[1]], pu3[[2]]];

gl2 = Table[VertexDegree[g1, gl1[[i]]], {i, 1, Length[gl1]}];

gl3 = Flatten[Position[gl2, _?(# != 2 &)]];

gl4 = Table[gl1[[gl3[[i]]]], {i, 1, Length[gl3]}];

gl5 = Partition[gl4, 2, 1];

gl6 = Flatten[Table[{Length[FindShortestPath[g1, gl5[[i, 1]], gl5[[i, 2]]]] - 1}, {i, 1, Length[gl5]}]];

gl7 = Table[{gl5[[i, 1]] <-> gl5[[i, 2]], gl6[[i]]}, {i, 1,Length[gl5]}]

I will make calculations for large graphs, e.g. as here: https://drive.google.com/drive/folders/1EUaH6x8mZ-QYq3PKQNNzKdLN_7eQ-Sa2?usp=sharing

Does anyone have any idea?

Answer 1

IGSmoothen from IGraph/M does basically this: it smoothens degree-2 vertices.

It removes degree-2 vertices, i.e. in 1 - 2 - 3 it merges the edges 1 - 2 and 2 - 3 into a single edge 1 - 3. The weights of the original edges are added up. IGSmoothen considers all edges in an unweighted graph to have weight 1, thus it will effectively count how many edges were merged.

Demo on your graph:

IGSmoothen[g1, EdgeLabels -> "EdgeWeight", 
 VertexShapeFunction -> "Name", PerformanceGoal -> "Quality"]

IGSmoothen is partially implemented in C++ and will be much faster than any alternative written in pure WL.

Should you want to round edge weights to integers (IGSmoothen creates reals by default), just apply the function IGEdgeMap[Round, EdgeWeight] to the resulting graph. It is an operator that applies Round to every value of the EdgeWeight edge property.