29
$\begingroup$

Consider the tree graph used in part of my solution to this question:

Factorial tree graph

Each level $i$ has $i!$ nodes, and the branching ratio is $i+1$:

I kludged together code to generate this graph (with code better left un-reproduced).

Is there an elegant method for generating such a tree graph for arbitrary number of levels?

A three-dimensional layout might look like this:

enter image description here

but I'd prefer a better embedding at the higher-$n$ levels, closer to this:

enter image description here

$\endgroup$
  • $\begingroup$ @J42161217 Fixed. Thanks. $\endgroup$ – David G. Stork Nov 30 '18 at 21:29
22
$\begingroup$

here is my elegant implementation

l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]];
T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]];

T@3   

which returns

enter image description here

but if your Mathematica version doesn't support TakeList here is another way

s[x_] := Sum[k!,{k,x}];
z[y_] := Partition[Range[s@y+1,s[y+1]],1+y];
v[n_] := Table[{Flatten[z[n-1]][[i]]->z[n][[i,j]]},{i,n!},{j,n+1}];
tree[t_] := Graph[Flatten[Array[v@#&,t],3]];

tree@3    

enter image description here

tree@6    

enter image description here

$\endgroup$
  • $\begingroup$ Very nice (+1). I would add only Embedding -> "RadialEmbedding" to your code. $\endgroup$ – David G. Stork Nov 30 '18 at 22:38
  • $\begingroup$ @DavidG.Stork updated with a new approach $\endgroup$ – J42161217 Dec 1 '18 at 1:16
  • 1
    $\begingroup$ Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question). $\endgroup$ – David G. Stork Dec 1 '18 at 1:19
28
$\begingroup$

Update 2: a more streamlined version for 2D graphs:

ClearAll[g]
g = GraphComputation`ExpressionGraph[ConstantArray[x, #], VertexLabels -> None] &;

Examples:

g[Range[2, 4]]

enter image description here

SetProperty[g[{3, 1, 3, 1, 2, 1, 4}],
  {GraphLayout -> "RadialEmbedding", EdgeShapeFunction -> "Line"}]

enter image description here

Original answer:

ClearAll[f]
f[g_: Graph][n_List, o : OptionsPattern[]] := g[UndirectedEdge @@@ EdgeList@
    GraphComputation`ExpressionGraph[ConstantArray[x, n]], 
     o, GraphLayout -> {"BalloonEmbedding"}, ImageSize -> Large]
f[g_: Graph][n_Integer, o : OptionsPattern[]] := f[g][Range[2, n], o]

Examples:

f[][6]

enter image description here

f[][6, GraphLayout -> {"RadialEmbedding"}]

enter image description here

g1 = f[Graph3D][6]

enter image description here

g2 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding"}]

enter image description here

Use a list for number of vertices on each layer as the argument:

f[][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}]

enter image description here

Update: ... to take the Graph3D and somehow improve the layout on the high-n layers: There seems to be lots of wasted space.

One way to change the box ratios without distorting the vertex shapes is to modify the VertexCoordinates using ScalingTransform:

SetProperty[g1, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g1]]

enter image description here

SetProperty[g2, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g2]]

enter image description here

Or add the suboption "LayerSizeFunction" in "RadialEmbedding":

g3 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}];
SetProperty[g3, VertexCoordinates -> ScalingTransform[{1, 1, -3}][GraphEmbedding@g3]]

enter image description here

SetProperty[#, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@#]] &@
 f[Graph3D][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction"->(#&)}]

enter image description here

$\endgroup$
  • $\begingroup$ I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1) $\endgroup$ – David G. Stork Dec 1 '18 at 6:33
  • 1
    $\begingroup$ Just wow. That's hardly to top in terms of elegance. $\endgroup$ – Henrik Schumacher Dec 1 '18 at 8:52
  • $\begingroup$ @David, please see the update. $\endgroup$ – kglr Dec 1 '18 at 16:03
  • 2
    $\begingroup$ @HenrikSchumacher: l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation. $\endgroup$ – David G. Stork Dec 1 '18 at 17:15
  • 1
    $\begingroup$ I've joined the community just to upvote this answer and those wonderful graphs. $\endgroup$ – Eric Duminil Dec 3 '18 at 9:34
24
$\begingroup$

IGraph/M already has this built-in as IGSymmetricTree. You can specify the number of branches at each level.

enter image description here

IGSymmetricTree[
 Range[2, 4],
 DirectedEdges -> True,
 GraphLayout -> "LayeredEmbedding"
]

enter image description here

The implementation is mostly in C (not Mathematica) and not from igraph this time. This is simply easier to implement procedurally, for which C is a good fit. This is why I did not do it in pure WL.

Here's another structure, with a different number of branches at each level.

IGSymmetricTree[{5, 4, 3, 2}]

enter image description here

$\endgroup$
  • $\begingroup$ This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant. $\endgroup$ – David G. Stork Nov 30 '18 at 22:01
  • $\begingroup$ @DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica. $\endgroup$ – Szabolcs Nov 30 '18 at 22:02
  • $\begingroup$ Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release. $\endgroup$ – David G. Stork Nov 30 '18 at 22:04
  • 6
    $\begingroup$ @David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem. $\endgroup$ – Szabolcs Nov 30 '18 at 22:07
  • 1
    $\begingroup$ Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica? $\endgroup$ – David G. Stork Nov 30 '18 at 22:18
15
$\begingroup$

I don't know if you find this elegant. But I give it a try.

maxdepth = 5;
Graph[
 Transpose[{
   Join @@ MapIndexed[
     {x, i} \[Function] Join @@ Transpose[ConstantArray[Range @@ x, (i + 1)]], 
     Join[{{1}}, Partition[Accumulate[Range[maxdepth - 1]!], 2, 1] + ConstantArray[{1, 0}, maxdepth - 2]]
     ],
   Range[2, Total[Range[maxdepth]!]]
   }],
 DirectedEdges -> True,
 GraphLayout -> "BalloonEmbedding"
 ]

enter image description here

Edit

Out of curiosity, I adapted the algorithm above to produce also other symmetric trees.

SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] := 
 Module[{levelnodecounts}, 
  levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
  Graph[Transpose[{
     Join @@ MapIndexed[
       {x, i} \[Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[1]]]]]],
       Join[
        {{1}},
        Partition[Accumulate[Most[levelnodecounts]], 2, 1] + ConstantArray[{1, 0}, Length[branchlist] - 1]
        ]
       ],
     Range[2, 1 + Total[Rest[levelnodecounts]]]}], 
   DirectedEdges -> True
   ]
  ]

Regarding speed, it seems to be on par with IGSymmetricTree. Of course, I cannot provide such a detailed user interface as Szabolcs so I would suggest to use IGraphM whenever possible.

Edit 2

Adapting my (slow) code for fractal trees, here is another way to embedd the tree:

BoccoliEmbedding[branchlist_] := 
 Module[{data0, data, θ, stem, thickness, s1, s2, f, F},
  θ = Pi/4.;
  s1 = 1/GoldenRatio // N;
  s2 = 1/GoldenRatio // N;
  stem = {0., 0., 1.};
  thickness = 0.15;
  data0 = {Join[
     {{0., 0., 0.}},
     {stem},
     {{thickness, 1., 0.}},
     Table[
      RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]}, 
      {k, 0, branchlist[[1]] - 1}]
     ]
    };
  f = {U, n} \[Function] Table[
     Join[
      {U[[1]] + U[[2]]},
      {U[[i]]},
      {s2 U[[3]]},
      Dot[
       s1 Table[RotationMatrix[2. Pi j/n, U[[2]]].U[[i]], {j, 0, n - 1}], 
       RotationMatrix[{U[[i]], U[[2]]}]
       ]
      ],
     {i, 4, Length[U]}];
  F = {data, n} \[Function] Join @@ (f[#, n] & /@ data);
  data = Join @@ FoldList[F, data0, Join[Rest[branchlist], {1}]];
  data[[All, 1]] + data[[All, 2]]
  ];

And this is how we apply it:

b = Range[2, 7];
plot = Graph[
  EdgeList[SymmetricTree[b]],
  VertexCoordinates -> BoccoliEmbedding[b]
  ]

enter image description here

$\endgroup$
  • 1
    $\begingroup$ Elegant enough! (+1) GraphLayout -> "LayeredEmbedding" works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach. $\endgroup$ – David G. Stork Nov 30 '18 at 21:59
  • $\begingroup$ Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, using VertexCoordinates, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher! $\endgroup$ – David G. Stork Dec 1 '18 at 0:39
6
$\begingroup$

Based on @kglr's answer, but avoiding the use of undocumented functions (ExpressionGraph):

These trees correspond to the expression structure of a full array of dimensions {2, 3, 4, ...} (think TreeForm).

To recover this tree, we walk the array expression using Position and record the positions of subexpressions. We will use these positions as graph vertices.

The position specification is such that we can always compute the parent node of a position by dropping its last element (implemented as [[;;-2]]). For example, the parent subexpression of a subexpression at position {2,1} is found at position {2}.

Position walks the expression in post-order, meaning that it returns the root vertex (position of full expression, {}) last. We reverse the vertex list to get the root as the first vertex instead. Then we drop this root from the edge computation (MapThread) as it has no parents.

Finally, we replace vertex names with integer vertex indices using IndexGraph.

symmetricTree[levels_List] :=
 Module[{vertices, edges},
  vertices = Reverse@Position[ConstantArray[0, levels], _, {0, Infinity}, Heads -> False];
  edges = MapThread[DirectedEdge, {vertices[[2;; , ;;-2]], vertices[[2;;]]}];
  IndexGraph@Graph[v, e]
 ]

I find this method clear and readable.

symmetricTree[{2, 3, 4}]

enter image description here

$\endgroup$

Your Answer

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

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