Elegant implementation of factorial tree graph

Update 3: ExpressionGraph is now available in version 12.1.

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


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


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