# Alignment of TreePlot

I want to construct a binomial tree using TreePlot but have troubles with the alignment. The code TreePlot[{1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6}, Left, 1, DirectedEdges -> True, VertexLabeling -> True] produces the following image: How can I make something like this?: EDIT: The image MMA produces: http://imgur.com/ygvqJ6D. The image I would like to have: http://imgur.com/NpJuHFm.

• @belisariushassettled, I added links to the images. – Skumin Nov 23 '15 at 21:24
• There is NestedSymmetricSubdivision function in ref / Traingle just before Properties & Relations section. One could use it for VertexCoordinates. – Kuba Nov 24 '15 at 7:12
• related q/a: Drawing the schematic diagram of algorithm – kglr Aug 18 '17 at 15:58

The idea is simple: we take the graph made by TreePlot and we change (the coordinates of) the points for the graph nodes into more regularly spaced points.

The solution below attempts to be somewhat robust.

1. The arguments and options taken by TreePlot can be used.

2. There is a check for is it possible the symmetric layout of the binary tree be done in such a way that the symmetricity is preserved for the tree sub-branches. See the last plot for which this is not the case.

I hope the code below is easy enough to follow.

Clear[MakeSymmetricTreePlot]
MakeSymmetricTreePlot[graphRules_, additionalArgs___, opts : OptionsPattern[]] :=
Block[{pos, gr, points, brect, pointGroups, newxs, newys, newPoints,
prules, xi = 1, yi = 2},
points = Cases[gr, GraphicsComplex[p_, ___] :> p, Infinity][];
(*Making the new points.*)
If[pos === Top || pos === Bottom, {xi, yi} = {yi, xi}];
brect = RegionBounds[Point[points]];
pointGroups = SortBy[GroupBy[points, Round[#[[xi]], 10^-8] &],Length];
newxs = Keys[pointGroups];
If[And @@
Map[#[] + 1 == #[] &,
Partition[Length /@ Values[pointGroups], 2, 1]],
(*We can do a locally symmetric layout.*)
newys = Reverse@
NestList[
If[Length[#] == 2, {Mean[#]}, Mean /@ Partition[#, 2, 1]] &,
Values[pointGroups][[-1]][[All, yi]],
Length[pointGroups] - 1],
(*ELSE*)
newys = Map[
Apply[Range,
Append[brect[[yi]],
Abs[Subtract @@ brect[[yi]]]/(# + 1)]][[2 ;; -2]] &,
Length /@ Values[pointGroups]];
];
If[pos === Top || pos === Bottom,
newPoints =
MapThread[Outer[List, #2, {#1}][[All, 1]] &, {newxs, newys}],
newPoints = MapThread[Outer[List, {#1}, #2][] &, {newxs, newys}]
];
(*Make rules from old to new points and replace them in the graph graphics.*)
prules =
Thread[#1 -> #2] &, {Values[pointGroups], newPoints}];
gr /. prules
];


Some examples follow.

graphRules = {1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6};
MakeSymmetricTreePlot[graphRules, Left, 1, DirectedEdges -> True, VertexLabeling -> True] graphRules = {1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7,
4 -> 8, 5 -> 8, 5 -> 9, 6 -> 9, 6 -> 10};
MakeSymmetricTreePlot[graphRules, Right, DirectedEdges -> True,
VertexLabeling -> True] graphRules = {1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7,
4 -> 8, 5 -> 9, 5 -> 10, 6 -> 11, 6 -> 12};
MakeSymmetricTreePlot[graphRules, DirectedEdges -> True,
VertexLabeling -> True] • The code indeed is easy to follow, thank you! – Skumin Nov 24 '15 at 9:52
• @Skumin Great then, I am glad it is working out. – Anton Antonov Nov 24 '15 at 14:26

You can use the built-in graph layout "MultipartiteEmbedding" as

GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> Range[n]}


where n is the number of layers in the tree.

edges1 = {1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6};
Graph[Sort @ VertexList[edges1], edges1, GraphStyle -> "VintageDiagram",
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> Range}] edges2 = {1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7,
4 -> 8, 5 -> 8, 5 -> 9, 6 -> 9, 6 -> 10, 7 -> 11, 7 -> 12, 8 -> 12,
8 -> 13, 9 -> 13, 9 -> 14, 10 -> 14, 10 -> 15, 11 -> 16, 11 -> 17,
12 -> 17, 12 -> 18, 13 -> 18, 13 -> 19, 14 -> 19, 14 -> 20,
15 -> 20, 15 -> 21};

g = Graph[Sort @ VertexList[edges2], edges2, GraphStyle -> "VintageDiagram",
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> Range}] To change the orientation, you can transform the vertex coordinates:

embedding = GraphEmbedding[g];
Row[SetProperty[g, {AspectRation -> 1,
VertexCoordinates -> (# /@ embedding)] & /@
{ReflectionTransform[{Max[embedding[[All, 2]]], 0}],
RotationTransform[-Pi/2],
RotationTransform[Pi/2]}}] • Nice, simple, and easy-to-read! – Skumin Nov 27 '17 at 9:24