# Drawing the schematic diagram of algorithm

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

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


### 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?

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

ClearAll[layersF, edgesF, subscF, indicesF];

layersF = Module[{k = 1}, Table[k++, {i, #}, {j, i}]] &;
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]]}]


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


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


Using with TreePlot (without subscripted labels)

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


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]


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

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


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

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


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

• Thanks a lot! BTW, why the graph that generated by your code in V8 is different from what you have given?
– xyz
Commented Oct 19, 2014 at 7:24
• @ShutaoTang The setting "MultipartiteEmbedding" was introduced in V9. I've updated my answer with a V8 solution. Commented Oct 19, 2014 at 13:16
• @ShutaoTang You're welcome. :) Commented Oct 19, 2014 at 14:05

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