22
$\begingroup$

The B-Spline function used the alogrithm as shown below:

enter image description here

I would like to draw it in Mathematica (Although this is my first time to use TreePlot)

 TreePlot[
   {1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7, 4 -> 8, 5 -> 8, 5 -> 9,
    6 -> 9, 6 -> 10}, Right, VertexLabeling -> True,
    EdgeRenderingFunction -> (Arrow[#1, 0.1] &)]

enter image description here

Question:

1.Is it possible to use some option to replace the tags like "1","2"... to the $N_{0,3},N_{0,2}...$? 2.How to make the treeplot looks symmetrically?

$\endgroup$
18
+250
$\begingroup$

Update: functions to generate the edge list, indices and labels:

ClearAll[layersF, edgesF, subscF, indicesF];

layersF = Module[{k = 1}, Table[k++, {i, #}, {j, i}]] &;
edgesF = Flatten[Thread /@ Thread[# -> Partition[#2, 2, 1]] & @@@
                                 Partition[layersF[#], 2, 1], 2] &;
indicesF = Reverse[Thread /@ Thread[{Reverse@Range[0, Range[0, # - 1]], Range[0, # - 1]}]] &;
subscF = Style[Subscript[N, ## & @@ ##], 16, "Panel", Background -> None] & /@ # &;
labelF = Flatten[subscF /@ indicesF[#]] &;

Examples:

edgesF@4

{1 -> 2, 1 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 3 -> 6, 4 -> 7, 4 -> 8, 5 -> 8, 5 -> 9, 6 -> 9, 6 -> 10}

vlabels = labelF@4

$ \left\{N_{0,3},N_{0,2},N_{1,2},N_{0,1},N_{1,1},N_{2,1},N_{0,0},N_{1,0},N_{2,0},N_{3, 0}\right\}$

el = edgesF@4;
vl = Flatten[layersF@4];
lbls = labelF@4;
vlabels = Thread[vl -> (Placed[#, Center] & /@ lbls)];
options = {VertexShapeFunction -> "Square", VertexSize -> {0.25`, 0.25`}, ImagePadding -> 20, 
   VertexStyle -> Hue[0.125`, 0.7`, 0.9`], ImageSize -> 400, BaseStyle -> Arrowheads[Large]};

By reversing the VertexList and the setting of "VertexPartition" suboption (credit: @MichaelE2) we can change orientation of the graph without the need for Rotation:

Graph[Reverse@vl, el, options, VertexLabels -> vlabels, 
 GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> Reverse[Range[4]]}]

enter image description here

Update 2: functions to generate vertex coordinates

Although we can easily get Left and Right orientations easily using "MultipartiteEmbedding", a function to generate similar vertex coordinates may be useful to get all four orientations. Such a function would also be useful for TreePlot and GraphPlot that do not provide similar layouts.

The following two functions both take an integer (representing the number of layers) as input:

 vcoordsF = {1, .5} # & /@ SparseArray[
      CellularAutomaton[{Unitize[#[[1]] + #[[3]]] &, {}, 1},{{1}, 0}, #-1]]["NonzeroPositions"] &;

or

vcoordsF2 = With[{n = #-1}, Reverse@Flatten[Thread /@ 
                ({#, Range[2 n + 1][[# ;; -# ;; 2]]} & /@ Range[n + 1]), 1]] &;

Examples:

gF1 = Graph[edgesF@#, ImageSize -> #2, options,
    VertexLabels -> Thread[Range@(# (# + 1)/2) -> (Placed[#, Center] & /@ (labelF@#))], 
    VertexCoordinates -> (-vcoordsF[#])] &;

Row[gF1 @@ # & /@ {{3, 250}, {5, 400}, {6, 500}}]

enter image description here

gF2 = Graph[edgesF@#, ImageSize -> #2, options,
    VertexLabels -> Thread[Range@(# (# + 1)/2) -> (Placed[#, Center] & /@ (labelF@#))], 
    VertexCoordinates -> (Reverse /@ vcoordsF[#])] &;

Row[gF2 @@ # & /@ {{3, 250}, {5, 400}, {6, 500}}]

enter image description here

Using with TreePlot (without subscripted labels)

TreePlot[edgesF@#, ImageSize -> #2, DirectedEdges -> True, VertexLabeling -> True, 
      VertexCoordinateRules -> (vcoordsF2[#])] & @@ # & /@ 
  {{3, 250}, {5, 400}, {12, 500}} // Row

enter image description here


Previous version

First, a helper function to get the subscript indices:

indicesF = Reverse[Thread /@ Inner[List, Reverse@Range[0, Range[0, #]], Range[0, #], List]] &;

And another to style and rotate indexed labels:

rssF = Rotate[Style[Subscript[N, #[[1]], #[[2]]], 16, "Panel", Background -> None], -Pi] &;

rlabels = Flatten[rss /@ # & /@ indicesF[3]]; 
vlabels = Table[i -> Placed[rlabels[[i]], Center], {i, Length@labels}];

Use the "MultipartiteEmbedding" suboption of the option GraphLayout to get the vertex coordinates as desired:

edgelist = {1->2, 1->3, 2->4, 2->5, 3->5, 3->6, 4->7, 4->8, 5->8, 5->9, 6->9, 6->10};
Rotate[Graph[edgelist, VertexShapeFunction -> "Square", VertexStyle -> Hue[0.125, 0.7, 0.9],
  VertexSize -> {.25, .25},  VertexLabels -> vlabels, ImagePadding -> 20, 
  GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> {1, 2, 3, 4}}], Pi]

enter image description here

$\endgroup$
  • $\begingroup$ This answer is very closely to what I need, I think I could finish the subscript according to your solution :-) $\endgroup$ – xyz Oct 18 '14 at 10:44
  • $\begingroup$ @ShutaoTang, updated with the subscript indices. $\endgroup$ – kglr Oct 18 '14 at 16:05
  • $\begingroup$ So surprised!+2,,:-) $\endgroup$ – xyz Oct 20 '14 at 6:18
  • $\begingroup$ @thank_you, thank you, thank you:) $\endgroup$ – kglr Feb 16 '17 at 18:11
10
$\begingroup$

Creating the edge list

The index and edges can be worked out like this:

step[list_, n_] := Block[
  {
   ln1 = list[[1]]
   , ln2 = list[[2]]
   },
  Join[
   If[ln2 < n ,
    {{ln1, ln2 + 1} -> {ln1, ln2}}, {}],
   If[ln2 < n,
    {{ln1, ln2 + 1} ->  {ln1 + 1, ln2  }}, {}],
   If[ln1 + ln2 + 1 < n,
    step[{ln1, ln2 + 1}, n], {}],
   If[ln1 + ln2 + 1 < n,
    step[{ln1 + 1, ln2}, n], {}]
   ]]

edgelist = DeleteDuplicates@step[{0, 0}, 3]
{{0, 1} -> {0, 0}, {0, 1} -> {1, 0}, {0, 2} -> {0, 1}, {0, 2} -> {1,    1}, {0, 3} -> {0, 2}, {0, 3} -> {1, 2}, {0, 4} -> {0, 3}, {0, 4} -> {1, 3}, {1, 3} -> {1, 2}, {1, 3} -> {2, 2}, {1, 2} -> {1, 1}, {1, 2} -> {2, 1}, {2, 2} -> {2, 1}, {2, 2} -> {3, 1}, {1, 1} -> {1, 0}, {1, 1} -> {2, 0}, {2, 1} -> {2, 0}, {2, 1} -> {3, 0}, {3, 1} -> {3, 0}, {3, 1} -> {4, 0}}

The main difference is that I'm using both indexes as vertex, and generating the graphs programatically by a recursion, allowing any arbitrary length, but unfortunately with duplicates.

Visualizing the graph

Building up from @kguler i.e copying shamelessly

edgelist = DeleteDuplicates@step[{0, 0}, 4];
vl = VertexList@Graph@edgelist;
{{0, 1}, {0, 0}, {1, 0}, {0, 2}, {1, 1}, {0, 3}, {1, 2}, {0, 4}, {1, 3}, {2, 2}, {2, 1}, {3, 1}, {2, 0}, {3, 0}, {4, 0}}
labels = Style[Subscript[N, #[[1]], #[[2]]], 16, "Title", Background -> None] & /@ vl ;
vlabels = #1 -> Placed[#2, Center] & @@@ Transpose[{vl, labels}];
Graph[
 edgelist
 , VertexLabels -> vlabels
 , VertexSize -> .5
 , VertexCoordinates -> ({#2, -#1 - #2/2} & @@@ vl )
 ]

Mathematica graphics

Another difference is that I'm defining the VertexCoordinates explicitly based on the index.

$\endgroup$
9
$\begingroup$

A function to recursively generate the edges:

n[_, 0] := {};
n[x : 0, y_Integer] /; y > 0 :=
  {{x, y} -> {x, y - 1}, {x, y} -> {x + 1, y - 1}, n[x + 1, y - 1], n[x, y - 1]};
n[x_Integer, y_Integer] /; y > 0 :=
  {{x, y} -> {x, y - 1}, {x, y} -> {x + 1, y - 1}, n[x + 1, y - 1]};

We have to sort the vertices so that the "MultipartiteEmbedding" method can partition the vertices into groups with the right order.

With[{edges = Flatten@n[0, 3]},
 Graph[
  SortBy[VertexList@Graph@edges, Last],
  edges,
  VertexSize -> {0.22, 0.22}, 
  VertexLabels -> (idx_ :> Placed[Subscript[N, Sequence @@ idx], Center]),
  EdgeShapeFunction -> GraphElementData["FilledArrow", "ArrowSize" -> 0.04], 
  EdgeStyle -> Directive[Opacity[1], RGBColor[0.4, 0.4, 0.8]],
  GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> {4, 3, 2, 1}}]
 ]

Mathematica graphics


Update for V8

The setting "MultipartiteEmbedding" was introduced in V9. It seems to be simply ignored in V8. Also rendering is different. In V8, one can get the above result by explicitly computing the coordinates and using the default edge rendering. The height and width can be adjusted in the ncoords code by multiplying Range[0, y] by a number or adding a number other than 1 in First[#] + 1, respectively.

ncoords[x_Integer, y_Integer] := 
  Flatten[Thread /@ 
    NestList[{First[#] + 1, MovingAverage[Last@#, 2]} &, {0, Range[0, y]}, y],
    1];

With[{edges = Flatten@n[0, 3], coords = ncoords[0, 3]}, 
 Graph[SortBy[VertexList@Graph@edges, Last], edges, 
  VertexSize -> {0.22, 0.22}, 
  VertexLabels -> (idx_ :> Placed[Subscript[N, Sequence @@ idx], Center]), 
  EdgeStyle -> Directive[Opacity[1], RGBColor[0.4, 0.4, 0.8]], 
  VertexCoordinates -> coords]]
$\endgroup$
  • $\begingroup$ Thanks a lot! BTW, why the graph that generated by your code in V8 is different from what you have given? $\endgroup$ – xyz Oct 19 '14 at 7:24
  • 1
    $\begingroup$ @ShutaoTang The setting "MultipartiteEmbedding" was introduced in V9. I've updated my answer with a V8 solution. $\endgroup$ – Michael E2 Oct 19 '14 at 13:16
  • $\begingroup$ @ShutaoTang You're welcome. :) $\endgroup$ – Michael E2 Oct 19 '14 at 14:05
8
$\begingroup$

Just use TreePlot with VertexCoordinateRules. I have tried like this.

treePlot[k_] := Module[{grp, pos},
   grp = DeleteCases[Flatten@Table[
       {n[j, i - j] -> n[j, i - 1 - j], 
        n[j, i - j] -> n[j + 1, i - 1 - j]},
       {i, k}, {j, 0, i}], n[__] -> n[_, _?(# < 0 &)]];
   pos = Flatten@Table[n[j, i - j] -> {(j + i)/3, i - j}, {i, 0, k}, {j, 0, i}];
   TreePlot[grp, Right, n[0, k], ImageSize -> 70 k, 
    VertexLabeling -> True, VertexCoordinateRules -> pos, 
    EdgeRenderingFunction -> ({Arrowheads -> Small, Arrow[#, 0.3]} &)]
   ] /. n[a_, b_] -> Subscript[N, a, b]

Test

Manipulate[treePlot[k], {{k, 3}, 1, 10, 1},
 ContentSize -> {300, 200}, SaveDefinitions -> True]

Blockquote

$\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.