# Plotting a bipartite tree graph

I am trying to plot a generalized version of this graph in Mathematica

I already have a code where you give a number(for the above graph the number would be 4) and it returns a matrix that gives this type of graph in any size using the AdjacencyGraph function, but it doesn't plot it the way I want. It comes out like this:

I will include my code that gives the matrix and the graph. I hope its not too confusing, it was written this way because I need to work with individual points in the graph.

The numbering system I used is "j" for the column and "i" for the lines. For example, the "j=3" column has 4 "i's", from 1 to 4, and for n=4 there are 9 possible values for j.



n = 4;

js = Table[i, {i, 1, 2 n + 1}];

nis = Table[

If[i <= n + 1, 2^(js[[i]] - 1),
2^(2 n - (js[[i]] - 1))
]

, {i, 1, 2 n + 1}];

kets = {};

Do[AppendTo[kets, Table[{js[[j]], i}, {i, 1, nis[[j]]}]], {j, 1,
2 n + 1}]

If[j != 1 && j != 2 n + 1 && j != n + 1 && j < n + 1,
{
If[Divisible[i - 1, 2],
{kets[[j - 1, (i - 1)/2 + 1]]}
, {kets[[j - 1, i/2]]}]
, {kets[[j + 1, 2 (i - 1) + 1]]},
{kets[[j + 1, 2 (i - 1) + 2]]}
},

If[j == 1,
{{kets[[j + 1, i]]}, {kets[[j + 1, i + 1]]}},

If[j == 2 n + 1,
{{kets[[j - 1, i]]}, {kets[[j - 1, i + 1]]}},

If[j == n + 1,

{If[Divisible[i - 1, 2],
{kets[[j - 1, (i - 1)/2 + 1]]}
, {kets[[j - 1, i/2]]}]
, If[Divisible[i - 1, 2],
{kets[[j + 1, (i - 1)/2 + 1]]}
, {kets[[j + 1, i/2]]}]},
If[j != 1 && j != 2 n + 1 && j != n + 1 && j > n + 1,
{
If[Divisible[i - 1, 2],
{kets[[j + 1, (i - 1)/2 + 1]]}
, {kets[[j + 1, i/2]]}]
, {kets[[j - 1, 2 (i - 1) + 1]]},
{kets[[j - 1, 2 (i - 1) + 2]]}
}
]
]
]
]
];

int[{j1_, i1_}, {j2_, i2_}] := 1.0;

matElem[ket_] := Module[{lin},
Table[{ket /. rep, lin[[i]] /. rep} -> int[ket, lin[[i]]], {i,
Length@lin}]
];

f[x_] := If[x != 0, 1, 0];

kets2 = Flatten[kets, 1];

d = Length@kets2;

list = Range[1, d];

H = SparseArray[Flatten[Table[matElem[ket], {ket, kets2}], 1], {d, d}]



• Have you tried playing with GraphLayout? – Kuba Jan 17 '17 at 16:19
• @Kuba I have and none of them worked. What "almost" worked was plotting half the graph, but only to a certain size, then it would mess up again... – Pedro Portugal Jan 17 '17 at 16:33
• Now I noticed that I didn't try all of them and some of them come really close actually, thanks for the comment – Pedro Portugal Jan 17 '17 at 16:44

A different approach starting from scratch. Now corrected for n > 4.

Even if you don't use my rather hackish visualization construction f2 may be useful to you.

f1[p_, 0] := p
f1[p_, lev_] := (Scan[Sow @ {p, f1[2 p + #, lev - 1]} &, {0, 1}]; p)

f2[n_] := Reap[ f1[1, n] ][[2, 1]];

el = f2[5];
vc = GraphEmbedding @ Graph[el, GraphLayout -> "LayeredEmbedding"];
Graph[el, VertexCoordinates -> vc.{{1, 0}, {0, #}}] & /@ {3.5, -3.5};
Show[%] // Rotate[#, 90 °] &


• The values {3.5, -3.5} control the aspect ratio, e.g. for different n values.

My answer feels incomplete without a way to generate an actual and complete Graph.
Here is a solution somewhat less clean than I would like but functional.

n = 4;
el = f2[n];
vc = GraphEmbedding @ Graph[el, GraphLayout -> "LayeredEmbedding"];

el2 = Join[el, Mod[el, 2^(n + 1) - 1, 2^n]];
vc2 = Join[vc, Drop[vc, -(2^n)].{{1, 0}, {0, -1}}].{{0, -1}, {-2, 0}};

Graph[el2
, VertexCoordinates -> vc2
, VertexLabels -> Placed["Name", Center]
, VertexLabelStyle -> 16
, VertexSize -> 0
]


• That's a very nice solution and the graph looks perfect up to n=4. I can't use it for the main purpose of my project but i will definitely use it on the report. Thanks. – Pedro Portugal Jan 17 '17 at 22:01
• @Pedro I must admit I forgot to test this beyond n=4 and didn't see that it failed. I'll try to return to this later and see if I can extend it. Anyway I hope the f2 function proves to be a useful base for further experimentation. – Mr.Wizard Jan 17 '17 at 22:26
• @Pedro Please see my updated answer. I just needed GraphLayout -> "LayeredEmbedding" for that part of it. Regarding I can't use it for the main purpose of my project why is that? Perhaps I can improve this further. – Mr.Wizard Jan 18 '17 at 23:13
• "Perhaps I can improve this further". I can't imagine how you could improve this code, it works perfectly now. The reason why I believed I wouldn't be able to use this code is that I couldn't get an AdjacencyMatrix from it combined with the fact that I already invested a lot of time in these few days using my original construction of the graph. I'll mark your answer as the accepted one because it does what I asked exactly. Thanks for willing to help further but I believe that in the stage I am in my project it's too late to change my code. But rest assured that f2 will be used. – Pedro Portugal Jan 19 '17 at 15:57

Not exactly the same but similar layout:

g = AdjacencyGraph[Map[f, Normal@H, {2}],
GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Left}]


Modify coords to get better shape:

emb = GraphEmbedding[g];
emb[[All, 1]] =
1.2 Divide @@
Reverse[Differences[CoordinateBoundingBox[emb]][[1]]] emb[[All, 1]];

Graph[g, VertexCoordinates -> emb, PlotTheme -> "BasicBlack", VertexSize -> .6]


Update: Slightly factored version of the original function to generate the VertexCoordinates and the AdjacencyMatrix to be used in AdjacencyGraph:

ClearAll[vcF, amF, karyAdjG]
vcF[n_, base_] := Module[{layers = base^Join @@ Range[{0, n - 1}, {n, 0}, {1, -1}],
hsize, divs, ycoords},
hsize = Length[layers] - 1;
divs = Range[-hsize/2, hsize/2, hsize/(base^n - 1)];
ycoords = Flatten@{Reverse@#, Rest@#} &@
NestList[DeveloperPartitionMap[N@Mean@# &, #, base] &, divs, n];
Join @@ MapIndexed[Thread[{#2[[1]], #}] &, InternalPartitionRagged[ycoords, layers]]]

amF[n_, base_] := Module[{layers = base^(Join@@Range[{0, n - 1}, {n, 0}, {1, -1}]), r, c},
r = Total[layers[[;; n]]]; c = Total[layers[[;; n + 1]]];
# + Transpose[#] &@ SparseArray[{Band[{1, 2}, {r, c}] -> {{Table[1, {base}]}},
Band[{1, 1} + {r, c}, {-1, -1}] -> {Table[{1}, {base}]}}, (r + c) {1, 1}]]

karyAdjG[n_, base_, aspect_: 1][opts___ : OptionsPattern[Graph]] :=
AdjacencyGraph[amF[n, base], VertexCoordinates -> ({1, aspect} # & /@ vcF[n, base]), opts]


Example:

karyAdjG[3, 4][VertexStyle -> Directive[PointSize[0.015], Black],
EdgeStyle -> Thickness[Large], EdgeShapeFunction -> "Line",
VertexShapeFunction -> "Point", ImageSize -> 400]


Original post: Also from scratch, generalizing to arbitrary k-ary layered network:

ClearAll[karyG]
karyG[n_, base_, aspect_: 1][opts___ : OptionsPattern[Graph]] :=
Module[{layers = base^Join @@ Range[{0, n - 1}, {n, 0}, {1, -1}],
ycoords, vertcoords, vlist, parts, elist, divs, hsize},
hsize = Length[layers] - 1;
divs = Range[-hsize/2, hsize/2, hsize/(base^n - 1)];
ycoords = Flatten@{Reverse@#, Rest@#} &@
NestList[DeveloperPartitionMap[N@Mean@# &, #, base] &, divs, n];
vertcoords = Join @@ MapIndexed[Thread[{#2[[1]], #}] &,
InternalPartitionRagged[ycoords, layers]];
vlist = Range@Total@layers;
parts = Partition[InternalPartitionRagged[vlist, layers], 2, 1];
elist = Sort /@ (Flatten@(Thread /@ Thread[# <-> Partition[#2, base]] & @@@
MapAt[Reverse, parts, {1 + n ;;}]));
Graph[elist, VertexCoordinates -> ({1, aspect} # & /@ vertcoords), opts]]


Examples:

ops = Sequence[VertexStyle -> Directive[PointSize[.02], Black], EdgeStyle -> Thick,
EdgeShapeFunction -> "Line", VertexShapeFunction -> "Point", ImageSize -> 400];

karyG[#, #2][ops, PlotLabel->Style[Row[{"n = ", #, ", base = ", #2}], "Panel", 16]]& @@@
{{2, 2}, {3, 2}, {4, 2}} // Row


karyG[#, #2][ops, PlotLabel->Style[Row[{"n = ", #, ", base = ", #2}], "Panel", 16]]& @@@
{{2, 3}, {3, 3}, {4, 3}} // Row


Row[{karyG[7, 2][ops], karyG[3, 5][ops]}]


The optional third argument (with default value 1) controls the aspect ratio:

Row[{karyG[4, 2, 1][ops], karyG[4, 2, 1/2][ops]}]


Vertices are ordered left-to-right and bottom-to-up:

karyG[4, 2][EdgeStyle -> Thick, EdgeShapeFunction -> "Line",
ImageSize -> 400, VertexStyle -> White,
VertexLabelStyle -> Directive[12, Bold], VertexSize -> .75,
VertexLabels -> Placed["Name", Center]]
`