Recreating a hierarchical graph from a compact representation

Question

Explanation: Let us consider the graph2:

z3 = {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}; graph2= Graph[z3,GraphLayout -> "SpringEmbedding",(*VertexLabels\[Rule]"Name",*)EdgeStyle -> Thick].

The color version looks like this:

Let us imagine that it is a network of streets. Red trail markes 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 the graph1. I wrote a script which calculates graph1 based on graph2 (for very large networks).

The question is: How can we get graph2 from the graph1? I think this is not a trivial issue:) Thanks for the help:)

z1 = {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}; graph1 = Graph[z1, GraphLayout -> "RadialDrawing"(*,VertexLabels\[Rule]"Name"*)]

Let us imagine that the driver starts from point 56 (graph2):

Assumption: the driver at a particular point always identifies the longest route! At point 56, the longest route is from point 56 to point 51 (or 52) (red road). And he goes .... He does not look at points 55 and 54 because there are no turns - therefore, in graph 1, the highest node will have 18 degree.

Next, he comes to point 1 and identifies the road towards point 53. There are no other roads from 1 to 53. And so on ... He comes to point 12 and turns and identifies the longest route. The longest route is from point 12 to 33 (or 36) (in graph 1 there will be a node of 4 times). And he goes this way. In point 30 he turns and identifies the longest road - this road is from 30 to 38 (or 37). And he goes ... In 34 is the turn, he identifies the longest path (34-37). Next he goes back to point 30 and goes on further identifying the roads on the route until point 33. Then he goes back to the main road to point 12 and continues to drive. That way we get graph1. The question is: How can we get graph2 from the graph1?

Re-interpretation by b3m2a1: (might not be correct)

Consider the set of edges and its corresponding graph, call it graph2:

z3 = {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}; 
graph2= Graph[z3,GraphLayout -> "SpringEmbedding",(*VertexLabels\[Rule]"Name",*)EdgeStyle -> Thick].

We'll colorize the longest chain, the longest branches off of this chain, the longest branches off of that chain, etc... This is the hierarchy we're representing

We can represent this hierarchy by a creating a graph where we have a central node representing the longest chain connected to a node for each subchain, each of which has connections for its subchains, etc.

In doing this we find that the each node has a degree equal to the total path length of the chain. Here's such a construction for the graph2 presented above:

z1 = {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};
graph1 = Graph[z1, GraphLayout -> "RadialDrawing"(*,VertexLabels\[Rule]"Name"*)]

Now, how can one reverse this process? That is, given graph1 can we build a hierarchical graph, graph2' that would also be reduced back to graph1?

Note that if we built the compact representation from an original chained graph then we're assured there is one unambiguous solution. If not, then we could hit collisions in interpretation, e.g. consider node with seven connections with two child nodes with 6. No matter where those child nodes are placed along the constructed chain (as only one of them can occupy a given spot) the resultant path will have a length longer than 7 and so will reduce down to a different form than the original.

Answer 1

Code

First off here's the code. I'll discuss some quick analysis of the problem after it. In particular I address some cases where the problem has no solution and these are important for knowing what behavior to expect.

sourceNode[node_, nodeList_] :=
  First@Keys@Select[nodeList, MemberQ[node]];
neighborNodes[node_, edgeList_] :=

  Cases[Flatten@edgeList, node ~UndirectedEdge~ f_ | f_ ~UndirectedEdge~ node :> f];
connectionCount[node_, edgeList_] :=

  Count[Flatten@edgeList, node ~UndirectedEdge~ _ | _ ~UndirectedEdge~ node];

connectTo[edgeList_, node_, nodeAssociation_, original_] :=
  With[{
    nodeChain =
     nodeAssociation[sourceNode[node, nodeAssociation]],
    neighbors =
     neighborNodes[sourceNode[node, nodeAssociation], original],
    firstNode =
     Reverse[SortBy[Values@nodeAssociation, Length]][[1, 1]],
    lastNodes =
     Values[nodeAssociation][[All, -1]]
    },
   With[{
     connectTo =
      Do[
       Replace[
        SelectFirst[
         If[Length@nodeAssociation[neighbor] > Length@nodeChain,
          If[neighbor === sourceNode[firstNode, nodeAssociation],
           RandomSample@
            Take[nodeAssociation[neighbor],
             {Length@nodeChain,
              1 + Length@nodeAssociation[neighbor] -
               Length@nodeChain
              }],
           RandomSample@
              If[Length@# > 1, Drop[#, -1], #] &@
            Take[nodeAssociation[neighbor],
             1 + Length@nodeAssociation[neighbor] -
              Length@nodeChain]
           ],
          {}
          ],
         With[{n = #},
           connectionCount[n, edgeList] <
            If[n === firstNode || MemberQ[lastNodes, n],
             2,
             3
             ]
           ] &
         ],
        i_Integer :> Return@i
        ],
       {neighbor, neighbors}
       ]
     },
    Append[edgeList, node ~UndirectedEdge~ connectTo]
    ]
   ];

connectTo[nodeAssociation_, original_][edgeList_, node_] :=
 connectTo[edgeList, node, nodeAssociation, original]

nodeColoring[n_, min_, max_] :=
 Replace[n, {
   1 -> Yellow,
   2 -> Cyan,
   3 -> Green,
   4 -> Blue,
   5 -> Purple,
   6 -> Orange,
   7 -> Gray,
   max -> Red,
   i_ :> ColorData["BrightBands"]@Rescale[i, {min, max}]
   }]

unSpoolConfiguration[newNodes_, configuration_] :=
  With[{
    newEdges =
     Fold[
        connectTo[newNodes, (*EdgeList@*)configuration],
        UndirectedEdge @@@ Partition[Riffle[#, Rest@#], 2] & /@ 
         Values@newNodes,
        First /@
         Values@
          Select[newNodes, Length@# < Max[Length /@ newNodes] &]
        ] // Flatten // Join[#,
        Thread[{"Cap1", "Cap2"} ~UndirectedEdge~ 
          First[MaximalBy[newNodes, Length]][[{1, -1}]]]
        ] &},
   Graph[newEdges,
    VertexStyle ->
     Join[
      Flatten@
       Map[
        Thread[# -> nodeColoring[Length@#,
            Min[Length /@ Values@newNodes],
            Max[Length /@ Values@newNodes]]] &,
        Values@newNodes
        ], {
       "Cap1" -> Red,
       "Cap2" -> Red
       }],
    GraphLayout -> "RadialDrawing"
    ]
   ];

unSpoolingChoices[configuration_, n_:All] :=
  With[{newNodes =
     Reverse@SortBy[Length]@Association@
        MapThread[
         Rule, {
          VertexList@configuration,
          Fold[
           Append[#,
             Range[
              Length@Flatten@# + 1,
              Length@Flatten@# + #2
              ]
             ] &,
           {},
           VertexDegree@configuration
           ]
          }]},
   RotateRight[newNodes, #] & /@ 
     Which[
       ListQ@n, n, 
       IntegerQ@n&&Positive@n, Range[0, n],
       IntegerQ@n&&Negative@n, Range[Length@newNodes+n, Length@newNodes-1],
       True, Range[0, Length@newNodes - 1]
       ]
   ];

unSpoolGraph[configuration_] :=
 unSpoolConfiguration[
  First@unSpoolingChoices@EdgeList@configuration,
  EdgeList@configuration]

traverseRecursive[currentPath_, traversed_, pathTree_] :=
  Table[
   With[{paths =
      Select[pathTree,
       #[[1]] == n &&
         Intersection[#,
           Join[traversed, DeleteCases[currentPath, n]]
           ] == {} &
       ]},
    If[Length@paths > 0,
     {
      n -> {
        currentPath,
        First@Rest@First@TakeLargestBy[paths, Length, 1]
        },
      traverseRecursive[
       Rest@First@TakeLargestBy[paths, Length, 1],
       Join[traversed, currentPath],
       pathTree]
      },
     Nothing
     ]
    ],
   {n, currentPath}
   ];

spooledRep[graph_] :=
 Graph[graph,
  GraphLayout -> "RadialDrawing",
  VertexStyle ->
   Map[
    # ->
      nodeColoring[
       VertexDegree[graph, #],
       Min[VertexDegree@graph],
       Max[VertexDegree@graph]
       ] &,
    VertexList@graph]
  ]

spoolGraph[graph_] :=
  Block[{
    spoolEdgeList = Sort@EdgeList@graph,
    spoolAPSP, spoolEdges, spoolNodes},
   spoolAPSP = FindShortestPath[spoolEdgeList, All, All];
   spoolAPSP =
    Reverse@SortBy[Length]@
      Select[
       Flatten[
        Table[
         DeleteCases[spoolAPSP[i, j], i],
         {i, VertexList@spoolEdgeList},
         {j, VertexList@spoolEdgeList}],
        1],
       Length@# > 1 &
       ];
   spoolEdges =
    Flatten@traverseRecursive[First@spoolAPSP, {}, spoolAPSP];
   spoolNodes =
    #[[2, 1]] & /@ spoolEdges // 
     Reverse@*SortBy[Length]@*DeleteDuplicates;
   spoolEdges =
    #[[1]] ~UndirectedEdge~ #[[2, 2]] & /@ spoolEdges;
   spoolEdges =
    spoolEdges /.
     MapIndexed[
      Apply[Alternatives, #] -> First@#2 &,
      Join[
       spoolNodes,
       Thread@{VertexList@spoolEdges}
       ]
      ];
   spooledRep[
    spoolEdges /. MapIndexed[# -> First@#2 &, VertexList@spoolEdges]]
   ];

isoAdjMat[g_] := 
  AdjacencyMatrix@SortBy[EdgeList@g, VertexDegree[g, First@#] &];

findUnspooling[spooledGraph_] :=
 With[{ia = isoAdjMat@spooledGraph},
  Replace[
   SelectFirst[
    unSpoolingChoices[spooledGraph],
    Equal[isoAdjMat@spoolGraph@unSpoolConfiguration[#, spooledGraph], 
      ia] &
    ],
   a_Association :> unSpoolConfiguration[a, spooledGraph]
   ]
  ]

Basic idea:

From a source graph that is a radial tree, construct graph where there is a primary chain representing the root node with degree D in the source graph, call this {c_1, c_2, ..., c_D }. Then for each child node n with degree d, with parent node of degree m with a chain in the graph { m_1, m_2, ..., m_n } construct a path { n_1, n_2, ..., n_d } and attach it to the first m_i that has no paths of lower degree connected to it.

In my mind this looks lot like unspooling some thread, since we effectively linearize our radial representation. This isn't always reversible though (I think).

Demonstrating reversibility in an unspooling process:

First we'll check that the code can find a solution to the reversible-unspooling problem. We'll use z1 as defined by the OP:

z1 = {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};

Then:

findUnspooling@z1

And we'll just demonstrate what this reversibility looks like:

Row@unSpoolReSpool@z1

Note that the nodal orientation changes, but the graph is otherwise the same.

Sometimes this process (as I've understood it at least) isn't reversible. I'll use a z2 that the OP found wasn't reversing properly:

z2 = {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, 27 <-> 28, 28 <-> 29};

Then the spooled-unspooled-respooled picture:

Row@unSpoolReSpool@z2

Obviously these are different. And I was unable to find a set of initial conditions that would reverse (at least across applying RotateRight to the new set of generated node sets as many times as was possible. Too many Permutations to test).

In[765]:= findUnspooling@z2

Out[765]= Missing["NotFound"]

On reversible mappings:

And now we can think about whether this is right or not. Consider that chain of cyan nodes. Each of these has degree 2 and so at each step of this chain we get the node itself and a single node branching off of it. When we go to respool this, however, the finds a longer chain, because we have multiple nodes with only a single branch off of it. Hence this is an irreversible mapping.

And in fact we can most likely generalize this to the claim that, for an unspooling to be reversible, for a node N the degree of each its child nodes (because really this is a tree structure as it radiates out from that central node) must be strictly less than its own. Otherwise in re-spooling we will get an effective chain of degree than that of N.

Obviously this isn't a formal proof and I may have missed some subtleties, but I think it's certainly a believable claim.

Update:

In fact we can generalize this one step further, which allows us to make the process more efficient:

Along the primary chain {c_1, c_2, ..., c_M}, for a child node N of degree D, which generates a path {N_1, ..., N_D}, N_1 can only connect to one of the {c_D, ..., c_M-D}. And for a non-primary node N with degree D which creates a path {N_1, N_2, ..., N_D} and a child node n of degree d with first node n_1, n_1 can only connect to one of the {N_1, ..., N_D-d}. Knowing this we can refine our placements. This obviously also means that for a node N with degree D the sum of the degrees of its child nodes must be less than or equal to (D-1 + D-2 + ... +1).