Construct a permutation tree plot

Question

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]

kglr · Accepted Answer

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 GraphComputation`ExpressionGraph. (See also this answer.)

Daniel Huber · Answer

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

Szabolcs · Answer

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.

kglr · 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"]

Construct a permutation tree plot

4 Answers

Add your own answers!

Ask a Question