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

  • $\begingroup$ @J42161217 Fixed. Thanks. $\endgroup$ Nov 30, 2018 at 21:29

5 Answers 5


here is my elegant implementation



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]];


enter image description here


enter image description here

  • $\begingroup$ Very nice (+1). I would add only Embedding -> "RadialEmbedding" to your code. $\endgroup$ Nov 30, 2018 at 22:38
  • $\begingroup$ @DavidG.Stork updated with a new approach $\endgroup$
    – ZaMoC
    Dec 1, 2018 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$ Dec 1, 2018 at 1:19

Update 3: ExpressionGraph is now available in version 12.1.

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

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


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:

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]



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

  • $\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$ Dec 1, 2018 at 6:33
  • 1
    $\begingroup$ Just wow. That's hardly to top in terms of elegance. $\endgroup$ Dec 1, 2018 at 8:52
  • $\begingroup$ @David, please see the update. $\endgroup$
    – kglr
    Dec 1, 2018 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$ Dec 1, 2018 at 17:15
  • 1
    $\begingroup$ I've joined the community just to upvote this answer and those wonderful graphs. $\endgroup$ Dec 3, 2018 at 9:34

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

enter image description here

 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

  • $\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$ Nov 30, 2018 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, 2018 at 22:02
  • $\begingroup$ Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release. $\endgroup$ Nov 30, 2018 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, 2018 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$ Nov 30, 2018 at 22:18

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

maxdepth = 5;
   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


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

SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] := 
  levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
     Join @@ MapIndexed[
       {x, i} \[Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[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.}},
     {{thickness, 1., 0.}},
      RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]}, 
      {k, 0, branchlist[[1]] - 1}]
  f = {U, n} \[Function] Table[
      {U[[1]] + U[[2]]},
      {s2 U[[3]]},
       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[
  VertexCoordinates -> BoccoliEmbedding[b]

enter image description here

  • 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$ Nov 30, 2018 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$ Dec 1, 2018 at 0:39

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


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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