# Construct a permutation tree plot

How to construct a tree like this? I was looking CompleteKaryTree initially, there are some similarities overall, but it's still different.

CompleteKaryTree[5, 2, GraphLayout -> "LayeredEmbedding", AspectRatio -> 1/4]


Another way, I've generated the coordinates of all the points, but I don't know how to connect them

n=4;
pts=Join @@ Table[{1/2 (1+(n-j)!)+(i-1) (n-j)!,n-j-1},{j,0,n},{i,FactorialPower[n,j]}];
Graphics[{Point@pts}, ImageSize->Large]


• Have you seen this? Changing GraphPlot to TreePlot in the source code gives the requested output Commented Jan 26, 2021 at 11:34

You can use ExpressionGraph to draw the tree

expr = ConstantArray[x, Reverse @ Range[4]];

ExpressionGraph[expr, GraphLayout -> "LayeredEmbedding", ImageSize -> Large]


 epxr2  = ConstantArray[x, Reverse @ Range[5]];

ExpressionGraph[expr2, GraphLayout -> "LayeredEmbedding", ImageSize -> 700,
VertexSize -> Medium, AspectRatio -> 1/2]


Define a function that constructs a permutation tree with edge labels:

ClearAll[rule, permutationTree]
rule = # /.  x : {___Integer} /; Length[x] > 1 :>
(Reverse /@ Subsets[Reverse@x, {Length[x] - 1}]) &;

permutationTree[n_, opts : OptionsPattern[Graph]] :=
Module[{eg = ExpressionGraph[ConstantArray[x, Reverse@Range[n]],
opts, GraphLayout -> "LayeredEmbedding",
ImageSize -> 700, VertexSize -> Medium, AspectRatio -> 1/2],
edgelabels},
edgelabels =  Thread[First @ Last @ Reap@
BreadthFirstScan[eg, 1, {"FrontierEdge" -> Sow}] ->
Flatten@NestList[rule, Range[n], n - 1]] ;
SetProperty[eg, EdgeLabels -> edgelabels]]


Examples:

permutationTree[3]


permutationTree[4]


permutationTree[4, GraphLayout -> "RadialEmbedding",
AspectRatio -> 1, EdgeLabelStyle -> Large]


permutationTree[5, ImageSize -> 900]


Alternatively, you can use TreeForm:

TreeForm[expr,  ImageSize -> Large, VertexLabeling -> False]


Note: For versions older than v12.0, replace ExpressionGraph with GraphComputationExpressionGraph. (See also this answer.)

Using a slight modification of the code in Wolfram Demonstrations >> Permutation Tree (linked by George Varnavides in comments) and adding edge labels:

ClearAll[permTree]
permTree[n_, opts : OptionsPattern[Graph]] := Module[{el = Union @@
Map[Rule @@@ Partition[FoldList[Append, {}, #], 2, 1] &, Permutations @ Range @ n]},
Graph[el, opts, DirectedEdges -> False,
GraphLayout -> "LayeredEmbedding", EdgeLabels -> {e_ :> e[[2, -1]]}]]


Examples:

permTree[3, ImageSize -> Large,
VertexLabels -> {v_ /; Length[v] == 3 :> Placed[Column @ v, Below]}]


permTree[4, ImageSize -> 800,
VertexLabels -> {v_ /; Length[v] == 4 :> Placed[Column @ v, Below]}]


permTree[4, ImageSize -> Large, GraphLayout -> "RadialEmbedding"]


In 12.3 or later, you can use NestTree:

choice[{_, list_List}]:=
MapIndexed[{e, pos} |-> {e, Delete[list, pos]}, list]

permutationTree[list_List] :=
NestTree[choice, {Null, list}, Infinity, First]
permutationTree[n_Integer] :=
permutationTree[Range[n]]


Using my package IGraph/M,

Needs["IGraphM"]
IGSymmetricTree[{4, 3, 2, 1}, GraphLayout -> "LayeredEmbedding"]


See its documentation, which shows precisely the tree you are asking for.

We create the points recursively. Given the numbers of siblings in every generation by e.g. ngen=ngen = {4, 3, 2, 1}, in a first step we create 4 descendants. Then for every sibling we create another 3 descendants, then 2, then 1. Finally we use TreePlot. You may play with labels, I simply number the edges here:

ngen = {4, 3, 2, 1};
p = 0;
Clear[step];
step[n0_,
gen_] := (next =
Table[n0 \[UndirectedEdge] ++p, ngen[[gen]]]; {next,
If[gen == Length@ngen, Nothing[], step[#[[2]], gen + 1] & /@ next]})
tr = step[0, 1];
TreePlot[tr // Flatten(*,0,VertexLabels\[Rule]"Name"*),
EdgeLabels -> "Index"]