13
$\begingroup$

I am trying to plot a generalized version of this graph in Mathematicaenter image description here

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:enter image description here

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

links[{j_, i_}] :=

  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},
   lin = Flatten[links[ket], 1];
   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];

rep = Thread[kets2 -> list];

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

AdjacencyGraph[Map[f, Normal@H, {2}]]

`

$\endgroup$
  • $\begingroup$ Have you tried playing with GraphLayout? $\endgroup$ – Kuba Jan 17 '17 at 16:19
  • $\begingroup$ @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... $\endgroup$ – Pedro Portugal Jan 17 '17 at 16:33
  • 1
    $\begingroup$ Now I noticed that I didn't try all of them and some of them come really close actually, thanks for the comment $\endgroup$ – Pedro Portugal Jan 17 '17 at 16:44
9
$\begingroup$

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 °] &

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Pedro Portugal Jan 17 '17 at 22:01
  • 1
    $\begingroup$ @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. $\endgroup$ – Mr.Wizard Jan 17 '17 at 22:26
  • 1
    $\begingroup$ @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. $\endgroup$ – Mr.Wizard Jan 18 '17 at 23:13
  • $\begingroup$ "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. $\endgroup$ – Pedro Portugal Jan 19 '17 at 15:57
15
$\begingroup$

Not exactly the same but similar layout:

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

enter image description here

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]

enter image description here

$\endgroup$
5
$\begingroup$

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[Developer`PartitionMap[N@Mean@# &, #, base] &, divs, n];
  Join @@ MapIndexed[Thread[{#2[[1]], #}] &, Internal`PartitionRagged[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]

Mathematica graphics

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[Developer`PartitionMap[N@Mean@# &, #, base] &, divs, n];
 vertcoords = Join @@ MapIndexed[Thread[{#2[[1]], #}] &, 
    Internal`PartitionRagged[ycoords, layers]];
 vlist = Range@Total@layers;
 parts = Partition[Internal`PartitionRagged[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

Mathematica graphics

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

Mathematica graphics

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

Mathematica graphics

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

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

Mathematica graphics

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

Mathematica graphics

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.