TreePlot with centered vertexes

Question

I want to draw a tree plot for Euler totient function for this question like the following:

I generate the EulerPhi for first 20 numbers into a list:

list = Map[# -> EulerPhi[#] &, Range[2, 20]]

Then I plot it using this:

TreePlot[list, Bottom, 1, VertexLabeling -> True,  DirectedEdges -> True ]

And the output:

But I want the layout of tree become like the above one so that numbers of form $2^n$ are centered and branches to the left or right. How can I do this?

By manually editing the graph the output looks like the following

Updated

I've managed to centralize the powers of $2$ but now the branches aren't placed well.

y = 0; coordinates = 
 Map[First[#] -> {0, y++} &, 
 Select[Prepend[list, 1 -> {0, 0}], IntegerQ[Log[2, First[#]]] &]]

{1 -> {0, 0}, 2 -> {0, 1}, 4 -> {0, 2}, 8 -> {0, 3}, 16 -> {0, 4}}

and using GraphPlot:

GraphPlot[list, VertexLabeling -> True, DirectedEdges -> True,
    VertexCoordinateRules -> coordinates]

Now, If the branches are placed upper than the root, then the result would be OK.

Answer 1

Update: It turns out to be easier to construct your own vertex coordinates than trying to adjust the coordinates produced by built-in options.

 vrtxLst = {1, 2, 3, 4, 6, 5, 8, 12, 18, "{7,9,14}",
       15, 16, 10, 13, 19, 20, 17, 11};
 edgeLst = {2 -> 1, 3 -> 2, 4 -> 2, 5 -> 4, 6 -> 2, "{7,9,14}" -> 6,  8 -> 4, 
   10 -> 4,  11 -> 10, 12 -> 4, 13 -> 12, 15 -> 8, 16 -> 8, 17 -> 16,
   18 -> 6,  19 -> 18, 20 -> 8};
 alignedKPartiteCoords[layersizes_List, offsett_List] :=
    Flatten[Table[N[{i - 1, j - 1}], {j, Length[layersizes]},
       {i, 1 - offsett[[j]], layersizes[[j]] - offsett[[j]]}], 1];
 layersizes = {1, 1, 3, 5, 5, 3};
 offsets = {0, 0, 1, 1, 1, 1};
 options = Sequence[ImageSize -> 350, 
    VertexStyle -> Directive[EdgeForm[None], White], VertexSize -> 0.5`, 
    VertexLabels -> Placed["Name", {1/2, 1/2}],
    VertexLabelStyle -> Directive[12, RGBColor[1, 0, 0], Bold, Italic],
    VertexCoordinates -> alignedKPartiteCoords[layersizes, offsets]];
 Graph[vrtxLst, edgeLst, options]

---

Original post:

In version 9, you can use Graph with GraphLayout option set to {"MultipartiteEmbedding", "VertexPartition" -> {1, 1, 3, 7, 5, 3}}.

First manually re-ordered the vertex list to match the ordering in your first image:

  vl = {1, 2, 3, 4, 6, 5, 8, 12, 18, 7, 9, 14, 15, 16, 10, 13, 19, 20, 17, 11};
  grph1=Graph[vl, list, VertexLabels -> "Name", ImagePadding -> 10,
   GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> {1, 1, 3, 7, 5, 3}}]

Answer 2

Method 1: Semi-Automatic

My suggestion would be to use semi-automatic placement rules like

Needs["GraphUtilities`"]
n = 30;
list = Map[# -> EulerPhi[#] &, Range[2, n]];
RulesPow2 = Table[2^k -> {0, k}, {k, 0, 10}];
RulesOther = Table[k -> {Automatic, GraphDistance[list, k, 1]}, {k, Complement[Range[1, n], Table[2^k, {k, n}]]}]
vcr = Union[RulesPow2, RulesOther];
TreePlot[list, Top, 1, VertexLabeling -> True, DirectedEdges -> True, VertexCoordinateRules -> vcr, AspectRatio -> 0.6]

which produces

Sadly the semi-automatic placement does not work so well for some values with many long path branches, e.g. n=20.

Method 2: Roll your own Algorithm

Alternatively you can write some code to automatically calculate the coordinates for you, e.g.

Needs["GraphUtilities`"]; n = 136;
list = Map[# -> EulerPhi[#] &, Range[2, n]];
rlist = Map[#[[2]] -> #[[1]] &, list];
Pow2 = Table[2^k, {k, 0, Log[2, n]}];
vcr = {}; d = Table[0, {k, n}];
DepthFirstScan[Graph[rlist], 1, "PrevisitVertex" -> Function[
vcr = Append[vcr,
  If[MemberQ[Pow2, #], # -> {0, Log[2, #]}, 
     # -> {dd = GraphDistance[list, #, 1]; 
     d[[dd]] = Max[d[[dd]], ((# /. list) /. vcr)[[1]]] + 1; 
     d[[dd]], dd}]]]];
TreePlot[list, Top, 1, VertexLabeling -> True, DirectedEdges -> True, VertexCoordinateRules -> vcr, AspectRatio -> 0.6]

You can play with this any way you like, e.g. adjust

DepthFirstScan[Graph[rlist], 1, "PrevisitVertex" -> Function[
vcr = Append[vcr,
  If[MemberQ[Pow2, #], # -> {0, Log[2, #]}, 
       # -> {dd = GraphDistance[list, #, 1]; 
           d[[dd]] = Max[d, ((# /. list) /. vcr)[[1]]] + 1;
           d[[dd]], dd - 0.2}]]]];

The latter one should give

Answer 3

If you are willing to sketch out how you want the graph to look, the following may be of interest. But I warn that it requires some manual input.

Imagine you sketch out something like this:

So you know you are dealing with a grid with 6 levels, 7 cols). Assuming there are no internal gaps in the grid, you could tell MMA where you want vertices placed, going column by column.

The following,

layout = {{6, {20, 15, 5, 3}}, {6, {17, 16, 8, 4, 2, 1}}, {6, {11, 10,
  12, 6}}, {5, {13, 18}}, {5, {19, 7}}, {4, {9}}, {4, {14}}};

would be understood as meaning that the leftmost column begins as the highest level (6), and, reading downwards, should place the numbers 20, 15, 5, 3. And so forth. The following will assign coordinates to each vertex.

g[lis_]:=Module[{pos=0,f}, 
   f[{c_,r_,ns_}]:=Module[{pos=r},#-> {c,pos--}&/@ns];
   Flatten[f[Prepend[#, pos++]]&/@lis,1]]

Here are the original edges:

edges = {2 -> 1, 3 -> 2, 4 -> 2, 5 -> 4, 6 -> 2, 7 -> 6, 8 -> 4, 
  9 -> 6, 10 -> 4, 11 -> 10, 12 -> 4, 13 -> 12, 14 -> 6, 15 -> 8, 
  16 -> 8, 17 -> 16, 18 -> 6, 19 -> 18, 20 -> 8};

This gives the plot shown above.

Graph[edges,DirectedEdges -> True, VertexCoordinates -> g[layout],
ImagePadding -> 20,GraphStyle -> "VintageDiagram"]

So does this.

GraphPlot[edges, VertexLabeling -> True,DirectedEdges -> True, 
VertexCoordinateRules -> g[layout]]