4
$\begingroup$

I would like to embed (layout) a tree graph where the angle of each edge is determined by a simple function of the values of the vertices that that edge joins as well as the previous edge angle. An excellent application is the (binary) Collatz conjecture tree graph.

Here is Collatz code that will form the Collatz tree graph. The task is now to lay it out (embed it in the plane) based on the values of the vertices and the previous angle of an edge.

Here is a teeny portion of the Collatz graph:

Graph[{5 -> 16, 32 -> 16, 16 -> 8}, VertexLabels -> "Name"]

enter image description here

Suppose the angle of the 16 -> 8 edge happens to be vertical. (More generally, an edge will be at some angle $\theta$.) I would like the angle of any subsequent edge to vertex 16 will be at angle $\theta + \phi$ if it comes from an even-valued vertex, and $\theta - \phi$ if it comes from an odd-valued vertex.

Here is a video of the final graph layout I'm seeking.

Example:

For the teeny portion of the Collatz graph, 5 -> 16 edge to be rotated by some angle $+\phi$ (e.g., $\theta+5^\circ$) and the 32 -> 16 edge to be rotated by $-\phi$ (e.g., $\theta-5^\circ$).

I'd like to create VertexCoordinateRules that involves the value of a linked vertex (even or odd) and the orientation of the adjacent edge.

How can this be done?

$\endgroup$
2
$\begingroup$

Update 2: Another attempt:

pos[{t1, t2, ...}, {u, v}] gives the starting position {x, y} that connects to the final position {u, v} if we follow the angle path {t1, t2, ...}. For a non-sink vertex v the path of angles is found by replacing the vertices on the shortest path from v to 1 with ϕ + θ or ϕ - θ depending on parity.

ClearAll[pos, angleList, vcoord]
pos[t:{__}, {u_, v_}] := {u, v} - Total[Through @ {Cos, Sin} @ Accumulate[t], {2}]
angleList[g_, v_, ϕ_, t_] := ϕ +  Most[FindShortestPath[g, v, 1]] /. 
   {u_?EvenQ -> t, u_?OddQ -> - t}
vcoord[g_, v_, ϕ_, t_, pos1_: {0, 0}] := pos[angleList[g, v, ϕ, t], pos1]

Examples:

vk = 20;
edges = (DirectedEdge @@@ Partition[Collatz[#], 2, 1]) & /@ Range[vk] // Flatten // Union;
g = Graph[edges];
ϕ = 0;
θ = Pi/32;
Graph[edges, 
    VertexCoordinates -> {1 -> {0, 0}, v_ :> vcoord[g, v, ϕ, θ]}, 
     ImagePadding -> 20, EdgeStyle -> Arrowheads[Small], 
     VertexShapeFunction -> "Name", AspectRatio -> 2, 
     ImageSize -> 500]

enter image description here

With vk = 500 and

Graph[edges, 
   VertexCoordinates -> {1 -> {0, 0}, v_ :> vcoord[g, v, ϕ, θ]}, 
    ImagePadding -> 20, EdgeStyle -> Arrowheads[Tiny], 
    VertexShapeFunction ->None, AspectRatio -> 2,   ImageSize -> 500]

enter image description here

Using

VertexCoordinates -> {1 -> {0, 0}, v_ :> vcoord[g, v, ϕ, 2 θ]}

enter image description here

With vk = 600 and adding the options

EdgeShapeFunction -> "CurvedArc",
EdgeStyle -> {e_ :> Directive[RandomColor[], AbsoluteThickness[5], CapForm["Round"]]

enter image description here

Update: -- this is not quite correct --- (1) Reverse the edges in Collatz tree, (2) use DepthFirstScan get an ordered list of vertices, (3) split the list at branch points, (4) assign θ or to each element of the list based on its parity, (5) Fold AnglePath on the resulting list of lists:

ClearAll[anglePath]
Options[anglePath] := {VertexLabels -> False, InitialCoords -> {{0, 0}, 0}};

anglePath[g_, θ_, opts : OptionsPattern[{anglePath, Graphics}]] := 
 Module[{pieces = Split[Flatten @ Reap[DepthFirstScan[g, 1, 
  {"PrevisitVertex" -> (If[Length @ VertexOutComponent[g, #, 1] == 3, 
     Sow[{#, #}], Sow[#]] &)} ]][[2, 1]], Unequal], angles, path},
  angles = θ ( Mod[pieces, 2] + 1 /. 2 -> -1);
  path = Join @@ Rest[FoldList[AnglePath[Last[#], Rest@#2] &, 
     {OptionValue[InitialCoords]}, angles]];
  Graphics[{Red,  Point @ path, Black, 
    OptionValue[VertexLabels] /. 
      {True -> MapThread[Text[Style[#, 14], #2] &, {Join @@ pieces, path} ], _ -> {}}, 
     Blue, Line@ path}, FilterRules[{opts}, Options[Graphics]]]]

Examples:

vk = 20;
edges = (DirectedEdge @@@ Partition[Collatz[#], 2, 1]) & /@  Range[vk] // 
   Flatten // Union;
g = Graph[Reverse /@ edges];

anglePath[g, Pi/5, VertexLabels -> True, ImageSize -> 400, ImagePadding -> 10]

enter image description here

vk = 500;
edges = (DirectedEdge @@@ Partition[Collatz[#], 2, 1]) & /@  
     Range[vk] // Flatten // Union;
g = Graph[Reverse /@ edges];

anglePath[g, Pi/2, BaseStyle -> PointSize[Tiny], ImageSize -> 500, 
 ImagePadding -> 10]

enter image description here

With vk = 3000 and

 anglePath[g, 2 Pi/5, BaseStyle -> PointSize[Tiny], ImageSize -> 700, 
   ImagePadding -> 10]

enter image description here

Original answer:

Perhaps:

Using this answer by Sjoerd C. de Vries to construct a Collatz sequence:

ClearAll[Collatz]
Collatz[1] := {1}
Collatz[n_Integer]  := Prepend[Collatz[3 n + 1], n] /; OddQ[n] && n > 0
Collatz[n_Integer] := Prepend[Collatz[n/2], n] /; EvenQ[n] && n > 0

vk =  15;
edges = (DirectedEdge @@@ Partition[Collatz[#], 2, 1]) & /@ Range[vk] // Flatten // Union;

g = Graph[edges, 
   GraphLayout -> {"LayeredDigraphDrawing", "Orientation" -> Top}, 
   ImagePadding -> 10, EdgeStyle -> Arrowheads[Small], 
   VertexShapeFunction -> "Name", AspectRatio -> 2, ImageSize -> 300];

We take the vertical component of a vertex as its distance to the sink vertex and the vertical distance between layers as 1. So instead of working with angles we can work with horizontal displacements from 0 as input to the vertex layout process.

ClearAll[vc]
vc[g_, Δ_] := First[#] -> {Δ If[EvenQ @ First @ #, 1, -1] + Δ (Count[Rest @ #, _?EvenQ] - 
  Count[Rest @ #, _OddQ]), Length @ #} & /@ (VertexOutComponent[g, #] & /@ VertexList[g])

g2 = Graph[edges, VertexCoordinates -> vc[g, 1/4], 
   ImagePadding -> 10, EdgeStyle -> Arrowheads[Small], 
   VertexShapeFunction -> "Name", ImageSize -> 300, AspectRatio -> 2];

Row[{g, g2}, Spacer[10]]

enter image description here

Note: For larger vk (e.g., vk = 20) some vertices will overlap.

$\endgroup$
  • 1
    $\begingroup$ This is a nice start, but alas cannot work for the large ($\approx 4 \cdot 10^5$) node Collatz network I want to create. Such a network cannot be layered, as is required in your solution. In fact, the links curve and can occasionally reverse direction, and (yes) overlap, as shown in my linked video. I will try to modify your solution to deal with angles, not just horizontal offsets, but I think that will prove rather difficult. $\endgroup$ – David G. Stork Sep 11 at 21:10
  • $\begingroup$ Alas, I tried simply running your code but got lots of errors and no graph, so clearly I'm not initializing something, or something correctly. You should be able to make a "large" graph from beginning to end with your code (e.g., $10^4$) without any memory or computation problems... right? I'll work on this tomorrow. Thanks for the effort... I feel we're close. $\endgroup$ – David G. Stork Sep 12 at 5:53
  • $\begingroup$ @DavidG.Stork, I am not able run it on graphs with more than a few thousand nodes due to cloud credit limitation on wolfram cloud. $\endgroup$ – kglr Sep 12 at 5:58
  • $\begingroup$ Even 200 will suffice. Does that work for you? When I inspect graph g I get: Graph[{Partition[1, 2, 1], Partition[1, 2, 2],.... Something is wrong there. $\endgroup$ – David G. Stork Sep 12 at 5:59
  • $\begingroup$ @David, looks like a different Collatz function than Sjoerd's? $\endgroup$ – kglr Sep 12 at 6:10

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.