2
$\begingroup$

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:

enter image description here

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): enter image description here

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?

enter image description here

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

graph2

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"*)]

graph1

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.

$\endgroup$
  • 3
    $\begingroup$ I don't understand the relationship between the two graphs. The top one has a single node with a dozen connections, the bottom has no node with more than about three... $\endgroup$ – bill s Mar 12 '17 at 18:57
  • 3
    $\begingroup$ Please show what you've already tried to do. Moreover if you could provide more background on the problem that would be helpful. Is the special thing about graph two that no node has more than two leaves, there are no cycles, and it's connected? $\endgroup$ – b3m2a1 Mar 12 '17 at 18:57
  • $\begingroup$ Moreover the node count on the bottom is significantly higher than on the top. 53 if I counted right to the 27 on the top. Is there suppose to be a connection in the node doubling? Is one the negative branch and the other the positive? All of these bits of info are necessary to answer your question. $\endgroup$ – b3m2a1 Mar 12 '17 at 19:03
  • $\begingroup$ ralph, do not post answers which aren't answers. You can edit the question or comment existing answers. $\endgroup$ – Kuba Mar 17 '17 at 12:51
  • $\begingroup$ @Kuba thanks for cleaning that up. ralph, I updated with the z2 that was causing you trouble. I believe there shouldn't be a solution to the problem as it's stated for that graph. Revamped much of the code to show it. $\endgroup$ – b3m2a1 Mar 17 '17 at 16:10
7
$\begingroup$

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

found

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

Row@unSpoolReSpool@z1

reversible

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

irrev

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).

$\endgroup$
  • $\begingroup$ I think it works !!! I will do tests on large graphs. Thank you. $\endgroup$ – ralph Mar 16 '17 at 10:24
  • $\begingroup$ Please consider the case of the graph1: z1 = {1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 1 <-> 6, 1 <-> 7, 1 <-> 8,1 <-> 9, 1 <-> 10, 1 <-> 11, 1 <-> 12, 12 <-> 30, 9 <-> 13,1 <-> 14, 1 <-> 15, 1 <-> 16, 1 <-> 18, 12 <-> 19, 12 <-> 20,1 <-> 21, 1 <-> 22, 1 <-> 23, 8 <-> 24, 4 <-> 25, 4 <-> 26,12 <-> 27, 27 <-> 28, 27 <-> 29, 12 <-> 35}; $\endgroup$ – ralph Mar 17 '17 at 18:11
  • $\begingroup$ graph1 = Graph[z1, GraphLayout -> "RadialDrawing"(,VertexLabels[Rule]"Name")] Correct graph2 should look like this: $\endgroup$ – ralph Mar 17 '17 at 18:12
  • $\begingroup$ drive.google.com/drive/folders/… $\endgroup$ – ralph Mar 17 '17 at 18:20
  • $\begingroup$ Unfortunately your code gives a different result :( Thank you for your interest in the topic. I hope you come up with something :) $\endgroup$ – ralph Mar 17 '17 at 18:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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