Elegant implementation of factorial tree graph
up vote
27
down vote
favorite
Consider the tree graph used in part of my solution to this question:
Each level $i$ has $i!$ nodes, and the branching ratio is $i+1$:
I kludged together code to generate this graph (with code better left un-reproduced).
Is there an elegant method for generating such a tree graph for arbitrary number of levels?
A three-dimensional layout might look like this:
but I'd prefer a better embedding at the higher-$n$ levels, closer to this:
graphs-and-networks trees
add a comment |
up vote
27
down vote
favorite
Consider the tree graph used in part of my solution to this question:
Each level $i$ has $i!$ nodes, and the branching ratio is $i+1$:
I kludged together code to generate this graph (with code better left un-reproduced).
Is there an elegant method for generating such a tree graph for arbitrary number of levels?
A three-dimensional layout might look like this:
but I'd prefer a better embedding at the higher-$n$ levels, closer to this:
graphs-and-networks trees
@J42161217 Fixed. Thanks.
– David G. Stork
Nov 30 at 21:29
add a comment |
up vote
27
down vote
favorite
up vote
27
down vote
favorite
Consider the tree graph used in part of my solution to this question:
Each level $i$ has $i!$ nodes, and the branching ratio is $i+1$:
I kludged together code to generate this graph (with code better left un-reproduced).
Is there an elegant method for generating such a tree graph for arbitrary number of levels?
A three-dimensional layout might look like this:
but I'd prefer a better embedding at the higher-$n$ levels, closer to this:
graphs-and-networks trees
Consider the tree graph used in part of my solution to this question:
Each level $i$ has $i!$ nodes, and the branching ratio is $i+1$:
I kludged together code to generate this graph (with code better left un-reproduced).
Is there an elegant method for generating such a tree graph for arbitrary number of levels?
A three-dimensional layout might look like this:
but I'd prefer a better embedding at the higher-$n$ levels, closer to this:
graphs-and-networks trees
graphs-and-networks trees
edited Dec 1 at 1:17
asked Nov 30 at 21:17
David G. Stork
22.8k22051
22.8k22051
@J42161217 Fixed. Thanks.
– David G. Stork
Nov 30 at 21:29
add a comment |
@J42161217 Fixed. Thanks.
– David G. Stork
Nov 30 at 21:29
@J42161217 Fixed. Thanks.
– David G. Stork
Nov 30 at 21:29
@J42161217 Fixed. Thanks.
– David G. Stork
Nov 30 at 21:29
add a comment |
5 Answers
5
active
oldest
votes
up vote
22
down vote
accepted
here is my elegant implementation
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]];
T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]];
T@3
which returns
but if your Mathematica version doesn't support TakeList
here is another way
s[x_] := Sum[k!,{k,x}];
z[y_] := Partition[Range[s@y+1,s[y+1]],1+y];
v[n_] := Table[{Flatten[z[n-1]][[i]]->z[n][[i,j]]},{i,n!},{j,n+1}];
tree[t_] := Graph[Flatten[Array[v@#&,t],3]];
tree@3
tree@6
Very nice (+1). I would add onlyEmbedding -> "RadialEmbedding"
to your code.
– David G. Stork
Nov 30 at 22:38
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
1
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
add a comment |
up vote
28
down vote
Update 2: a more streamlined version for 2D graphs:
ClearAll[g]
g = GraphComputation`ExpressionGraph[ConstantArray[x, #], VertexLabels -> None] &;
Examples:
g[Range[2, 4]]
SetProperty[g[{3, 1, 3, 1, 2, 1, 4}],
{GraphLayout -> "RadialEmbedding", EdgeShapeFunction -> "Line"}]
Original answer:
ClearAll[f]
f[g_: Graph][n_List, o : OptionsPattern] := g[UndirectedEdge @@@ EdgeList@
GraphComputation`ExpressionGraph[ConstantArray[x, n]],
o, GraphLayout -> {"BalloonEmbedding"}, ImageSize -> Large]
f[g_: Graph][n_Integer, o : OptionsPattern] := f[g][Range[n], o]
Examples:
f[6]
f[6, GraphLayout -> {"RadialEmbedding"}]
g1 = f[Graph3D][6]
g2 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding"}]
Use a list for number of vertices on each layer as the argument:
f[{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}]
Update: ... to take the Graph3D and somehow improve the layout on the high-n layers: There seems to be lots of wasted space.
One way to change the box ratios without distorting the vertex shapes is to modify the VertexCoordinates
using ScalingTransform
:
SetProperty[g1, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g1]]
SetProperty[g2, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g2]]
Or add the suboption "LayerSizeFunction"
in "RadialEmbedding"
:
g3 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}];
SetProperty[g3, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g3]]
SetProperty[#, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@#]] &@
f[Graph3D][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction"->(#&)}]
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
1
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
@David, please see the update.
– kglr
Dec 1 at 16:03
2
@HenrikSchumacher:l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.
– David G. Stork
Dec 1 at 17:15
1
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
|
show 2 more comments
up vote
24
down vote
IGraph/M already has this built-in as IGSymmetricTree
. You can specify the number of branches at each level.
IGSymmetricTree[
Range[2, 4],
DirectedEdges -> True,
GraphLayout -> "LayeredEmbedding"
]
The implementation is mostly in C (not Mathematica) and not from igraph this time. This is simply easier to implement procedurally, for which C is a good fit. This is why I did not do it in pure WL.
Here's another structure, with a different number of branches at each level.
IGSymmetricTree[{5, 4, 3, 2}]
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
5
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
1
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
|
show 1 more comment
up vote
15
down vote
I don't know if you find this elegant. But I give it a try.
maxdepth = 5;
Graph[
Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, (i + 1)]],
Join[{{1}}, Partition[Accumulate[Range[maxdepth - 1]!], 2, 1] + ConstantArray[{1, 0}, maxdepth - 2]]
],
Range[2, Total[Range[maxdepth]!]]
}],
DirectedEdges -> True,
GraphLayout -> "BalloonEmbedding"
]
Edit
Out of curiosity, I adapted the algorithm above to produce also other symmetric trees.
SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] :=
Module[{levelnodecounts},
levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
Graph[Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[1]]]]]],
Join[
{{1}},
Partition[Accumulate[Most[levelnodecounts]], 2, 1] + ConstantArray[{1, 0}, Length[branchlist] - 1]
]
],
Range[2, 1 + Total[Rest[levelnodecounts]]]}],
DirectedEdges -> True
]
]
Regarding speed, it seems to be on par with IGSymmetricTree
. Of course, I cannot provide such a detailed user interface as Szabolcs so I would suggest to use IGraphM whenever possible.
Edit 2
Adapting my (slow) code for fractal trees, here is another way to embedd the tree:
BoccoliEmbedding[branchlist_] :=
Module[{data0, data, θ, stem, thickness, s1, s2, f, F},
θ = Pi/4.;
s1 = 1/GoldenRatio // N;
s2 = 1/GoldenRatio // N;
stem = {0., 0., 1.};
thickness = 0.15;
data0 = {Join[
{{0., 0., 0.}},
{stem},
{{thickness, 1., 0.}},
Table[
RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]},
{k, 0, branchlist[[1]] - 1}]
]
};
f = {U, n} [Function] Table[
Join[
{U[[1]] + U[[2]]},
{U[[i]]},
{s2 U[[3]]},
Dot[
s1 Table[RotationMatrix[2. Pi j/n, U[[2]]].U[[i]], {j, 0, n - 1}],
RotationMatrix[{U[[i]], U[[2]]}]
]
],
{i, 4, Length[U]}];
F = {data, n} [Function] Join @@ (f[#, n] & /@ data);
data = Join @@ FoldList[F, data0, Join[Rest[branchlist], {1}]];
data[[All, 1]] + data[[All, 2]]
];
And this is how we apply it:
b = Range[2, 7];
plot = Graph[
EdgeList[SymmetricTree[b]],
VertexCoordinates -> BoccoliEmbedding[b]
]
1
Elegant enough! (+1)GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.
– David G. Stork
Nov 30 at 21:59
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, usingVertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!
– David G. Stork
Dec 1 at 0:39
add a comment |
up vote
5
down vote
Based on @kglr's answer, but avoiding the use of undocumented functions (ExpressionGraph):
These trees correspond to the expression structure of a full array of dimensions {2, 3, 4, ...}
(think TreeForm
).
To recover this tree, we walk the array expression using Position
and record the positions of subexpressions. We will use these positions as graph vertices.
The position specification is such that we can always compute the parent node of a position by dropping its last element (implemented as [[;;-2]]
). For example, the parent subexpression of a subexpression at position {2,1}
is found at position {2}
.
Position
walks the expression in post-order, meaning that it returns the root vertex (position of full expression, {}
) last. We reverse the vertex list to get the root as the first vertex instead. Then we drop this root from the edge computation (MapThread
) as it has no parents.
Finally, we replace vertex names with integer vertex indices using IndexGraph
.
symmetricTree[levels_List] :=
Module[{vertices, edges},
vertices = Reverse@Position[ConstantArray[0, levels], _, {0, Infinity}, Heads -> False];
edges = MapThread[DirectedEdge, {vertices[[2;; , ;;-2]], vertices[[2;;]]}];
IndexGraph@Graph[v, e]
]
I find this method clear and readable.
symmetricTree[{2, 3, 4}]
add a comment |
5 Answers
5
active
oldest
votes
5 Answers
5
active
oldest
votes
active
oldest
votes
active
oldest
votes
up vote
22
down vote
accepted
here is my elegant implementation
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]];
T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]];
T@3
which returns
but if your Mathematica version doesn't support TakeList
here is another way
s[x_] := Sum[k!,{k,x}];
z[y_] := Partition[Range[s@y+1,s[y+1]],1+y];
v[n_] := Table[{Flatten[z[n-1]][[i]]->z[n][[i,j]]},{i,n!},{j,n+1}];
tree[t_] := Graph[Flatten[Array[v@#&,t],3]];
tree@3
tree@6
Very nice (+1). I would add onlyEmbedding -> "RadialEmbedding"
to your code.
– David G. Stork
Nov 30 at 22:38
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
1
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
add a comment |
up vote
22
down vote
accepted
here is my elegant implementation
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]];
T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]];
T@3
which returns
but if your Mathematica version doesn't support TakeList
here is another way
s[x_] := Sum[k!,{k,x}];
z[y_] := Partition[Range[s@y+1,s[y+1]],1+y];
v[n_] := Table[{Flatten[z[n-1]][[i]]->z[n][[i,j]]},{i,n!},{j,n+1}];
tree[t_] := Graph[Flatten[Array[v@#&,t],3]];
tree@3
tree@6
Very nice (+1). I would add onlyEmbedding -> "RadialEmbedding"
to your code.
– David G. Stork
Nov 30 at 22:38
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
1
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
add a comment |
up vote
22
down vote
accepted
up vote
22
down vote
accepted
here is my elegant implementation
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]];
T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]];
T@3
which returns
but if your Mathematica version doesn't support TakeList
here is another way
s[x_] := Sum[k!,{k,x}];
z[y_] := Partition[Range[s@y+1,s[y+1]],1+y];
v[n_] := Table[{Flatten[z[n-1]][[i]]->z[n][[i,j]]},{i,n!},{j,n+1}];
tree[t_] := Graph[Flatten[Array[v@#&,t],3]];
tree@3
tree@6
here is my elegant implementation
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]];
T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]];
T@3
which returns
but if your Mathematica version doesn't support TakeList
here is another way
s[x_] := Sum[k!,{k,x}];
z[y_] := Partition[Range[s@y+1,s[y+1]],1+y];
v[n_] := Table[{Flatten[z[n-1]][[i]]->z[n][[i,j]]},{i,n!},{j,n+1}];
tree[t_] := Graph[Flatten[Array[v@#&,t],3]];
tree@3
tree@6
edited Dec 1 at 1:30
answered Nov 30 at 22:29
J42161217
3,687220
3,687220
Very nice (+1). I would add onlyEmbedding -> "RadialEmbedding"
to your code.
– David G. Stork
Nov 30 at 22:38
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
1
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
add a comment |
Very nice (+1). I would add onlyEmbedding -> "RadialEmbedding"
to your code.
– David G. Stork
Nov 30 at 22:38
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
1
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
Very nice (+1). I would add only
Embedding -> "RadialEmbedding"
to your code.– David G. Stork
Nov 30 at 22:38
Very nice (+1). I would add only
Embedding -> "RadialEmbedding"
to your code.– David G. Stork
Nov 30 at 22:38
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
@DavidG.Stork updated with a new approach
– J42161217
Dec 1 at 1:16
1
1
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
Now THAT is elegant! (accept) Thanks so much! I'm now working on getting a clear three-dimensional embedding (see revised question).
– David G. Stork
Dec 1 at 1:19
add a comment |
up vote
28
down vote
Update 2: a more streamlined version for 2D graphs:
ClearAll[g]
g = GraphComputation`ExpressionGraph[ConstantArray[x, #], VertexLabels -> None] &;
Examples:
g[Range[2, 4]]
SetProperty[g[{3, 1, 3, 1, 2, 1, 4}],
{GraphLayout -> "RadialEmbedding", EdgeShapeFunction -> "Line"}]
Original answer:
ClearAll[f]
f[g_: Graph][n_List, o : OptionsPattern] := g[UndirectedEdge @@@ EdgeList@
GraphComputation`ExpressionGraph[ConstantArray[x, n]],
o, GraphLayout -> {"BalloonEmbedding"}, ImageSize -> Large]
f[g_: Graph][n_Integer, o : OptionsPattern] := f[g][Range[n], o]
Examples:
f[6]
f[6, GraphLayout -> {"RadialEmbedding"}]
g1 = f[Graph3D][6]
g2 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding"}]
Use a list for number of vertices on each layer as the argument:
f[{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}]
Update: ... to take the Graph3D and somehow improve the layout on the high-n layers: There seems to be lots of wasted space.
One way to change the box ratios without distorting the vertex shapes is to modify the VertexCoordinates
using ScalingTransform
:
SetProperty[g1, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g1]]
SetProperty[g2, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g2]]
Or add the suboption "LayerSizeFunction"
in "RadialEmbedding"
:
g3 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}];
SetProperty[g3, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g3]]
SetProperty[#, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@#]] &@
f[Graph3D][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction"->(#&)}]
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
1
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
@David, please see the update.
– kglr
Dec 1 at 16:03
2
@HenrikSchumacher:l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.
– David G. Stork
Dec 1 at 17:15
1
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
|
show 2 more comments
up vote
28
down vote
Update 2: a more streamlined version for 2D graphs:
ClearAll[g]
g = GraphComputation`ExpressionGraph[ConstantArray[x, #], VertexLabels -> None] &;
Examples:
g[Range[2, 4]]
SetProperty[g[{3, 1, 3, 1, 2, 1, 4}],
{GraphLayout -> "RadialEmbedding", EdgeShapeFunction -> "Line"}]
Original answer:
ClearAll[f]
f[g_: Graph][n_List, o : OptionsPattern] := g[UndirectedEdge @@@ EdgeList@
GraphComputation`ExpressionGraph[ConstantArray[x, n]],
o, GraphLayout -> {"BalloonEmbedding"}, ImageSize -> Large]
f[g_: Graph][n_Integer, o : OptionsPattern] := f[g][Range[n], o]
Examples:
f[6]
f[6, GraphLayout -> {"RadialEmbedding"}]
g1 = f[Graph3D][6]
g2 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding"}]
Use a list for number of vertices on each layer as the argument:
f[{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}]
Update: ... to take the Graph3D and somehow improve the layout on the high-n layers: There seems to be lots of wasted space.
One way to change the box ratios without distorting the vertex shapes is to modify the VertexCoordinates
using ScalingTransform
:
SetProperty[g1, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g1]]
SetProperty[g2, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g2]]
Or add the suboption "LayerSizeFunction"
in "RadialEmbedding"
:
g3 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}];
SetProperty[g3, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g3]]
SetProperty[#, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@#]] &@
f[Graph3D][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction"->(#&)}]
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
1
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
@David, please see the update.
– kglr
Dec 1 at 16:03
2
@HenrikSchumacher:l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.
– David G. Stork
Dec 1 at 17:15
1
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
|
show 2 more comments
up vote
28
down vote
up vote
28
down vote
Update 2: a more streamlined version for 2D graphs:
ClearAll[g]
g = GraphComputation`ExpressionGraph[ConstantArray[x, #], VertexLabels -> None] &;
Examples:
g[Range[2, 4]]
SetProperty[g[{3, 1, 3, 1, 2, 1, 4}],
{GraphLayout -> "RadialEmbedding", EdgeShapeFunction -> "Line"}]
Original answer:
ClearAll[f]
f[g_: Graph][n_List, o : OptionsPattern] := g[UndirectedEdge @@@ EdgeList@
GraphComputation`ExpressionGraph[ConstantArray[x, n]],
o, GraphLayout -> {"BalloonEmbedding"}, ImageSize -> Large]
f[g_: Graph][n_Integer, o : OptionsPattern] := f[g][Range[n], o]
Examples:
f[6]
f[6, GraphLayout -> {"RadialEmbedding"}]
g1 = f[Graph3D][6]
g2 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding"}]
Use a list for number of vertices on each layer as the argument:
f[{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}]
Update: ... to take the Graph3D and somehow improve the layout on the high-n layers: There seems to be lots of wasted space.
One way to change the box ratios without distorting the vertex shapes is to modify the VertexCoordinates
using ScalingTransform
:
SetProperty[g1, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g1]]
SetProperty[g2, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g2]]
Or add the suboption "LayerSizeFunction"
in "RadialEmbedding"
:
g3 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}];
SetProperty[g3, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g3]]
SetProperty[#, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@#]] &@
f[Graph3D][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction"->(#&)}]
Update 2: a more streamlined version for 2D graphs:
ClearAll[g]
g = GraphComputation`ExpressionGraph[ConstantArray[x, #], VertexLabels -> None] &;
Examples:
g[Range[2, 4]]
SetProperty[g[{3, 1, 3, 1, 2, 1, 4}],
{GraphLayout -> "RadialEmbedding", EdgeShapeFunction -> "Line"}]
Original answer:
ClearAll[f]
f[g_: Graph][n_List, o : OptionsPattern] := g[UndirectedEdge @@@ EdgeList@
GraphComputation`ExpressionGraph[ConstantArray[x, n]],
o, GraphLayout -> {"BalloonEmbedding"}, ImageSize -> Large]
f[g_: Graph][n_Integer, o : OptionsPattern] := f[g][Range[n], o]
Examples:
f[6]
f[6, GraphLayout -> {"RadialEmbedding"}]
g1 = f[Graph3D][6]
g2 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding"}]
Use a list for number of vertices on each layer as the argument:
f[{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}]
Update: ... to take the Graph3D and somehow improve the layout on the high-n layers: There seems to be lots of wasted space.
One way to change the box ratios without distorting the vertex shapes is to modify the VertexCoordinates
using ScalingTransform
:
SetProperty[g1, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g1]]
SetProperty[g2, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g2]]
Or add the suboption "LayerSizeFunction"
in "RadialEmbedding"
:
g3 = f[Graph3D][6, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction" -> (# &)}];
SetProperty[g3, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@g3]]
SetProperty[#, VertexCoordinates -> ScalingTransform[{1, 1, 3}][GraphEmbedding@#]] &@
f[Graph3D][{3, 5, 2, 4}, GraphLayout -> {"RadialEmbedding", "LayerSizeFunction"->(#&)}]
edited Dec 4 at 16:17
answered Dec 1 at 3:20
kglr
175k9197402
175k9197402
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
1
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
@David, please see the update.
– kglr
Dec 1 at 16:03
2
@HenrikSchumacher:l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.
– David G. Stork
Dec 1 at 17:15
1
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
|
show 2 more comments
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
1
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
@David, please see the update.
– kglr
Dec 1 at 16:03
2
@HenrikSchumacher:l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.
– David G. Stork
Dec 1 at 17:15
1
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
I knew you'd come up with something powerful and elegant. My only suggestion for improvement would be to take the Graph3D and somehow improve the layout on the high-$n$ layers: There seems to be lots of wasted space. Other than that... great! (+1)
– David G. Stork
Dec 1 at 6:33
1
1
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
Just wow. That's hardly to top in terms of elegance.
– Henrik Schumacher
Dec 1 at 8:52
@David, please see the update.
– kglr
Dec 1 at 16:03
@David, please see the update.
– kglr
Dec 1 at 16:03
2
2
@HenrikSchumacher:
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.– David G. Stork
Dec 1 at 17:15
@HenrikSchumacher:
l[c_]:=TakeList[Range@Sum[k!,{k,c}],Range@c!][[c-1]]; T[x_]:=Graph[(F=Flatten)@Table[MapThread[#->#2&,{Sort@F@Table[l@i,i],l[i+1]}],{i,2,x+1}]]
; seems incredibly efficient, clever and... yes.. "elegant." All other implementations include more code or are less elegant (in my humble opinion). About 1/6 the code in my (non-optimized) implementation.– David G. Stork
Dec 1 at 17:15
1
1
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
I've joined the community just to upvote this answer and those wonderful graphs.
– Eric Duminil
Dec 3 at 9:34
|
show 2 more comments
up vote
24
down vote
IGraph/M already has this built-in as IGSymmetricTree
. You can specify the number of branches at each level.
IGSymmetricTree[
Range[2, 4],
DirectedEdges -> True,
GraphLayout -> "LayeredEmbedding"
]
The implementation is mostly in C (not Mathematica) and not from igraph this time. This is simply easier to implement procedurally, for which C is a good fit. This is why I did not do it in pure WL.
Here's another structure, with a different number of branches at each level.
IGSymmetricTree[{5, 4, 3, 2}]
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
5
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
1
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
|
show 1 more comment
up vote
24
down vote
IGraph/M already has this built-in as IGSymmetricTree
. You can specify the number of branches at each level.
IGSymmetricTree[
Range[2, 4],
DirectedEdges -> True,
GraphLayout -> "LayeredEmbedding"
]
The implementation is mostly in C (not Mathematica) and not from igraph this time. This is simply easier to implement procedurally, for which C is a good fit. This is why I did not do it in pure WL.
Here's another structure, with a different number of branches at each level.
IGSymmetricTree[{5, 4, 3, 2}]
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
5
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
1
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
|
show 1 more comment
up vote
24
down vote
up vote
24
down vote
IGraph/M already has this built-in as IGSymmetricTree
. You can specify the number of branches at each level.
IGSymmetricTree[
Range[2, 4],
DirectedEdges -> True,
GraphLayout -> "LayeredEmbedding"
]
The implementation is mostly in C (not Mathematica) and not from igraph this time. This is simply easier to implement procedurally, for which C is a good fit. This is why I did not do it in pure WL.
Here's another structure, with a different number of branches at each level.
IGSymmetricTree[{5, 4, 3, 2}]
IGraph/M already has this built-in as IGSymmetricTree
. You can specify the number of branches at each level.
IGSymmetricTree[
Range[2, 4],
DirectedEdges -> True,
GraphLayout -> "LayeredEmbedding"
]
The implementation is mostly in C (not Mathematica) and not from igraph this time. This is simply easier to implement procedurally, for which C is a good fit. This is why I did not do it in pure WL.
Here's another structure, with a different number of branches at each level.
IGSymmetricTree[{5, 4, 3, 2}]
edited Nov 30 at 22:01
answered Nov 30 at 21:56
Szabolcs
158k13432926
158k13432926
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
5
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
1
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
|
show 1 more comment
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
5
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
1
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
This is precisely the functionality I need (thanks... +1), but I was hoping for the full code to be available, and (hopefully) clever and elegant.
– David G. Stork
Nov 30 at 22:01
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
@DavidG.Stork The full code is available (I linked to part of it), it is just not fully in Mathematica.
– Szabolcs
Nov 30 at 22:02
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
Thanks, but I need fully Mathematica code. Perhaps WRI will add this valuable functionality to its next release.
– David G. Stork
Nov 30 at 22:04
5
5
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
@David I accept that you want WL code, but could you explain why, just to satisfy my interest? People often refuse to use my package "because it's not built in". I do not understand why that is an issue. The package is polished, more robust than most, easy to install, and easy to uninstall without leaving traces. Other than for using the function in the cloud or in a FreeCDF (which is on the way out...) I do not see why having this functionality in a package (instead of built in) would be a problem.
– Szabolcs
Nov 30 at 22:07
1
1
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
Sure. I appreciate your wonderful coding efforts. However, in many cases I make CDF figures for class presentation and it is simpler to generate such figures without linking to libraries (especially $C$ or $C++$ libraries). Also, I understand and can thus modify Mathematica code better. Why not write all the code in Mathematica?
– David G. Stork
Nov 30 at 22:18
|
show 1 more comment
up vote
15
down vote
I don't know if you find this elegant. But I give it a try.
maxdepth = 5;
Graph[
Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, (i + 1)]],
Join[{{1}}, Partition[Accumulate[Range[maxdepth - 1]!], 2, 1] + ConstantArray[{1, 0}, maxdepth - 2]]
],
Range[2, Total[Range[maxdepth]!]]
}],
DirectedEdges -> True,
GraphLayout -> "BalloonEmbedding"
]
Edit
Out of curiosity, I adapted the algorithm above to produce also other symmetric trees.
SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] :=
Module[{levelnodecounts},
levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
Graph[Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[1]]]]]],
Join[
{{1}},
Partition[Accumulate[Most[levelnodecounts]], 2, 1] + ConstantArray[{1, 0}, Length[branchlist] - 1]
]
],
Range[2, 1 + Total[Rest[levelnodecounts]]]}],
DirectedEdges -> True
]
]
Regarding speed, it seems to be on par with IGSymmetricTree
. Of course, I cannot provide such a detailed user interface as Szabolcs so I would suggest to use IGraphM whenever possible.
Edit 2
Adapting my (slow) code for fractal trees, here is another way to embedd the tree:
BoccoliEmbedding[branchlist_] :=
Module[{data0, data, θ, stem, thickness, s1, s2, f, F},
θ = Pi/4.;
s1 = 1/GoldenRatio // N;
s2 = 1/GoldenRatio // N;
stem = {0., 0., 1.};
thickness = 0.15;
data0 = {Join[
{{0., 0., 0.}},
{stem},
{{thickness, 1., 0.}},
Table[
RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]},
{k, 0, branchlist[[1]] - 1}]
]
};
f = {U, n} [Function] Table[
Join[
{U[[1]] + U[[2]]},
{U[[i]]},
{s2 U[[3]]},
Dot[
s1 Table[RotationMatrix[2. Pi j/n, U[[2]]].U[[i]], {j, 0, n - 1}],
RotationMatrix[{U[[i]], U[[2]]}]
]
],
{i, 4, Length[U]}];
F = {data, n} [Function] Join @@ (f[#, n] & /@ data);
data = Join @@ FoldList[F, data0, Join[Rest[branchlist], {1}]];
data[[All, 1]] + data[[All, 2]]
];
And this is how we apply it:
b = Range[2, 7];
plot = Graph[
EdgeList[SymmetricTree[b]],
VertexCoordinates -> BoccoliEmbedding[b]
]
1
Elegant enough! (+1)GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.
– David G. Stork
Nov 30 at 21:59
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, usingVertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!
– David G. Stork
Dec 1 at 0:39
add a comment |
up vote
15
down vote
I don't know if you find this elegant. But I give it a try.
maxdepth = 5;
Graph[
Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, (i + 1)]],
Join[{{1}}, Partition[Accumulate[Range[maxdepth - 1]!], 2, 1] + ConstantArray[{1, 0}, maxdepth - 2]]
],
Range[2, Total[Range[maxdepth]!]]
}],
DirectedEdges -> True,
GraphLayout -> "BalloonEmbedding"
]
Edit
Out of curiosity, I adapted the algorithm above to produce also other symmetric trees.
SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] :=
Module[{levelnodecounts},
levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
Graph[Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[1]]]]]],
Join[
{{1}},
Partition[Accumulate[Most[levelnodecounts]], 2, 1] + ConstantArray[{1, 0}, Length[branchlist] - 1]
]
],
Range[2, 1 + Total[Rest[levelnodecounts]]]}],
DirectedEdges -> True
]
]
Regarding speed, it seems to be on par with IGSymmetricTree
. Of course, I cannot provide such a detailed user interface as Szabolcs so I would suggest to use IGraphM whenever possible.
Edit 2
Adapting my (slow) code for fractal trees, here is another way to embedd the tree:
BoccoliEmbedding[branchlist_] :=
Module[{data0, data, θ, stem, thickness, s1, s2, f, F},
θ = Pi/4.;
s1 = 1/GoldenRatio // N;
s2 = 1/GoldenRatio // N;
stem = {0., 0., 1.};
thickness = 0.15;
data0 = {Join[
{{0., 0., 0.}},
{stem},
{{thickness, 1., 0.}},
Table[
RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]},
{k, 0, branchlist[[1]] - 1}]
]
};
f = {U, n} [Function] Table[
Join[
{U[[1]] + U[[2]]},
{U[[i]]},
{s2 U[[3]]},
Dot[
s1 Table[RotationMatrix[2. Pi j/n, U[[2]]].U[[i]], {j, 0, n - 1}],
RotationMatrix[{U[[i]], U[[2]]}]
]
],
{i, 4, Length[U]}];
F = {data, n} [Function] Join @@ (f[#, n] & /@ data);
data = Join @@ FoldList[F, data0, Join[Rest[branchlist], {1}]];
data[[All, 1]] + data[[All, 2]]
];
And this is how we apply it:
b = Range[2, 7];
plot = Graph[
EdgeList[SymmetricTree[b]],
VertexCoordinates -> BoccoliEmbedding[b]
]
1
Elegant enough! (+1)GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.
– David G. Stork
Nov 30 at 21:59
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, usingVertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!
– David G. Stork
Dec 1 at 0:39
add a comment |
up vote
15
down vote
up vote
15
down vote
I don't know if you find this elegant. But I give it a try.
maxdepth = 5;
Graph[
Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, (i + 1)]],
Join[{{1}}, Partition[Accumulate[Range[maxdepth - 1]!], 2, 1] + ConstantArray[{1, 0}, maxdepth - 2]]
],
Range[2, Total[Range[maxdepth]!]]
}],
DirectedEdges -> True,
GraphLayout -> "BalloonEmbedding"
]
Edit
Out of curiosity, I adapted the algorithm above to produce also other symmetric trees.
SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] :=
Module[{levelnodecounts},
levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
Graph[Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[1]]]]]],
Join[
{{1}},
Partition[Accumulate[Most[levelnodecounts]], 2, 1] + ConstantArray[{1, 0}, Length[branchlist] - 1]
]
],
Range[2, 1 + Total[Rest[levelnodecounts]]]}],
DirectedEdges -> True
]
]
Regarding speed, it seems to be on par with IGSymmetricTree
. Of course, I cannot provide such a detailed user interface as Szabolcs so I would suggest to use IGraphM whenever possible.
Edit 2
Adapting my (slow) code for fractal trees, here is another way to embedd the tree:
BoccoliEmbedding[branchlist_] :=
Module[{data0, data, θ, stem, thickness, s1, s2, f, F},
θ = Pi/4.;
s1 = 1/GoldenRatio // N;
s2 = 1/GoldenRatio // N;
stem = {0., 0., 1.};
thickness = 0.15;
data0 = {Join[
{{0., 0., 0.}},
{stem},
{{thickness, 1., 0.}},
Table[
RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]},
{k, 0, branchlist[[1]] - 1}]
]
};
f = {U, n} [Function] Table[
Join[
{U[[1]] + U[[2]]},
{U[[i]]},
{s2 U[[3]]},
Dot[
s1 Table[RotationMatrix[2. Pi j/n, U[[2]]].U[[i]], {j, 0, n - 1}],
RotationMatrix[{U[[i]], U[[2]]}]
]
],
{i, 4, Length[U]}];
F = {data, n} [Function] Join @@ (f[#, n] & /@ data);
data = Join @@ FoldList[F, data0, Join[Rest[branchlist], {1}]];
data[[All, 1]] + data[[All, 2]]
];
And this is how we apply it:
b = Range[2, 7];
plot = Graph[
EdgeList[SymmetricTree[b]],
VertexCoordinates -> BoccoliEmbedding[b]
]
I don't know if you find this elegant. But I give it a try.
maxdepth = 5;
Graph[
Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, (i + 1)]],
Join[{{1}}, Partition[Accumulate[Range[maxdepth - 1]!], 2, 1] + ConstantArray[{1, 0}, maxdepth - 2]]
],
Range[2, Total[Range[maxdepth]!]]
}],
DirectedEdges -> True,
GraphLayout -> "BalloonEmbedding"
]
Edit
Out of curiosity, I adapted the algorithm above to produce also other symmetric trees.
SymmetricTree[branchlist_?(VectorQ[#, IntegerQ] &)] :=
Module[{levelnodecounts},
levelnodecounts = FoldList[#1 #2 &, 1, branchlist];
Graph[Transpose[{
Join @@ MapIndexed[
{x, i} [Function] Join @@ Transpose[ConstantArray[Range @@ x, branchlist[[i[[1]]]]]],
Join[
{{1}},
Partition[Accumulate[Most[levelnodecounts]], 2, 1] + ConstantArray[{1, 0}, Length[branchlist] - 1]
]
],
Range[2, 1 + Total[Rest[levelnodecounts]]]}],
DirectedEdges -> True
]
]
Regarding speed, it seems to be on par with IGSymmetricTree
. Of course, I cannot provide such a detailed user interface as Szabolcs so I would suggest to use IGraphM whenever possible.
Edit 2
Adapting my (slow) code for fractal trees, here is another way to embedd the tree:
BoccoliEmbedding[branchlist_] :=
Module[{data0, data, θ, stem, thickness, s1, s2, f, F},
θ = Pi/4.;
s1 = 1/GoldenRatio // N;
s2 = 1/GoldenRatio // N;
stem = {0., 0., 1.};
thickness = 0.15;
data0 = {Join[
{{0., 0., 0.}},
{stem},
{{thickness, 1., 0.}},
Table[
RotationMatrix[2. k Pi/branchlist[[1]], {0, 0, 1}].{Cos[θ], 0.,Sin[θ]},
{k, 0, branchlist[[1]] - 1}]
]
};
f = {U, n} [Function] Table[
Join[
{U[[1]] + U[[2]]},
{U[[i]]},
{s2 U[[3]]},
Dot[
s1 Table[RotationMatrix[2. Pi j/n, U[[2]]].U[[i]], {j, 0, n - 1}],
RotationMatrix[{U[[i]], U[[2]]}]
]
],
{i, 4, Length[U]}];
F = {data, n} [Function] Join @@ (f[#, n] & /@ data);
data = Join @@ FoldList[F, data0, Join[Rest[branchlist], {1}]];
data[[All, 1]] + data[[All, 2]]
];
And this is how we apply it:
b = Range[2, 7];
plot = Graph[
EdgeList[SymmetricTree[b]],
VertexCoordinates -> BoccoliEmbedding[b]
]
edited Dec 2 at 16:32
answered Nov 30 at 21:53
Henrik Schumacher
47k466134
47k466134
1
Elegant enough! (+1)GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.
– David G. Stork
Nov 30 at 21:59
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, usingVertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!
– David G. Stork
Dec 1 at 0:39
add a comment |
1
Elegant enough! (+1)GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.
– David G. Stork
Nov 30 at 21:59
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, usingVertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!
– David G. Stork
Dec 1 at 0:39
1
1
Elegant enough! (+1)
GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.– David G. Stork
Nov 30 at 21:59
Elegant enough! (+1)
GraphLayout -> "LayeredEmbedding"
works fine for $4$ levels, but not $5$, so your layout choice is probably one of the best. Before I accept, let me wait to see if someone is clever with specifying vertex order or other approach.– David G. Stork
Nov 30 at 21:59
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, using
VertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!– David G. Stork
Dec 1 at 0:39
Thanks for the wonderful coding... extremely helpful. I know it wasn't part of my original question, but I've been working on a three-dimensional graph embedding, using
VertexCoordinates
, in which each level $i$ is at a different (stacked) height and the vertices at each height are packed efficiently. This would be a very cool graphic, and interpretable for $n=7$ or possibly higher!– David G. Stork
Dec 1 at 0:39
add a comment |
up vote
5
down vote
Based on @kglr's answer, but avoiding the use of undocumented functions (ExpressionGraph):
These trees correspond to the expression structure of a full array of dimensions {2, 3, 4, ...}
(think TreeForm
).
To recover this tree, we walk the array expression using Position
and record the positions of subexpressions. We will use these positions as graph vertices.
The position specification is such that we can always compute the parent node of a position by dropping its last element (implemented as [[;;-2]]
). For example, the parent subexpression of a subexpression at position {2,1}
is found at position {2}
.
Position
walks the expression in post-order, meaning that it returns the root vertex (position of full expression, {}
) last. We reverse the vertex list to get the root as the first vertex instead. Then we drop this root from the edge computation (MapThread
) as it has no parents.
Finally, we replace vertex names with integer vertex indices using IndexGraph
.
symmetricTree[levels_List] :=
Module[{vertices, edges},
vertices = Reverse@Position[ConstantArray[0, levels], _, {0, Infinity}, Heads -> False];
edges = MapThread[DirectedEdge, {vertices[[2;; , ;;-2]], vertices[[2;;]]}];
IndexGraph@Graph[v, e]
]
I find this method clear and readable.
symmetricTree[{2, 3, 4}]
add a comment |
up vote
5
down vote
Based on @kglr's answer, but avoiding the use of undocumented functions (ExpressionGraph):
These trees correspond to the expression structure of a full array of dimensions {2, 3, 4, ...}
(think TreeForm
).
To recover this tree, we walk the array expression using Position
and record the positions of subexpressions. We will use these positions as graph vertices.
The position specification is such that we can always compute the parent node of a position by dropping its last element (implemented as [[;;-2]]
). For example, the parent subexpression of a subexpression at position {2,1}
is found at position {2}
.
Position
walks the expression in post-order, meaning that it returns the root vertex (position of full expression, {}
) last. We reverse the vertex list to get the root as the first vertex instead. Then we drop this root from the edge computation (MapThread
) as it has no parents.
Finally, we replace vertex names with integer vertex indices using IndexGraph
.
symmetricTree[levels_List] :=
Module[{vertices, edges},
vertices = Reverse@Position[ConstantArray[0, levels], _, {0, Infinity}, Heads -> False];
edges = MapThread[DirectedEdge, {vertices[[2;; , ;;-2]], vertices[[2;;]]}];
IndexGraph@Graph[v, e]
]
I find this method clear and readable.
symmetricTree[{2, 3, 4}]
add a comment |
up vote
5
down vote
up vote
5
down vote
Based on @kglr's answer, but avoiding the use of undocumented functions (ExpressionGraph):
These trees correspond to the expression structure of a full array of dimensions {2, 3, 4, ...}
(think TreeForm
).
To recover this tree, we walk the array expression using Position
and record the positions of subexpressions. We will use these positions as graph vertices.
The position specification is such that we can always compute the parent node of a position by dropping its last element (implemented as [[;;-2]]
). For example, the parent subexpression of a subexpression at position {2,1}
is found at position {2}
.
Position
walks the expression in post-order, meaning that it returns the root vertex (position of full expression, {}
) last. We reverse the vertex list to get the root as the first vertex instead. Then we drop this root from the edge computation (MapThread
) as it has no parents.
Finally, we replace vertex names with integer vertex indices using IndexGraph
.
symmetricTree[levels_List] :=
Module[{vertices, edges},
vertices = Reverse@Position[ConstantArray[0, levels], _, {0, Infinity}, Heads -> False];
edges = MapThread[DirectedEdge, {vertices[[2;; , ;;-2]], vertices[[2;;]]}];
IndexGraph@Graph[v, e]
]
I find this method clear and readable.
symmetricTree[{2, 3, 4}]
Based on @kglr's answer, but avoiding the use of undocumented functions (ExpressionGraph):
These trees correspond to the expression structure of a full array of dimensions {2, 3, 4, ...}
(think TreeForm
).
To recover this tree, we walk the array expression using Position
and record the positions of subexpressions. We will use these positions as graph vertices.
The position specification is such that we can always compute the parent node of a position by dropping its last element (implemented as [[;;-2]]
). For example, the parent subexpression of a subexpression at position {2,1}
is found at position {2}
.
Position
walks the expression in post-order, meaning that it returns the root vertex (position of full expression, {}
) last. We reverse the vertex list to get the root as the first vertex instead. Then we drop this root from the edge computation (MapThread
) as it has no parents.
Finally, we replace vertex names with integer vertex indices using IndexGraph
.
symmetricTree[levels_List] :=
Module[{vertices, edges},
vertices = Reverse@Position[ConstantArray[0, levels], _, {0, Infinity}, Heads -> False];
edges = MapThread[DirectedEdge, {vertices[[2;; , ;;-2]], vertices[[2;;]]}];
IndexGraph@Graph[v, e]
]
I find this method clear and readable.
symmetricTree[{2, 3, 4}]
edited Dec 5 at 14:22
answered Dec 5 at 14:11
Szabolcs
158k13432926
158k13432926
add a comment |
add a comment |
Thanks for contributing an answer to Mathematica Stack Exchange!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
Use MathJax to format equations. MathJax reference.
To learn more, see our tips on writing great answers.
Some of your past answers have not been well-received, and you're in danger of being blocked from answering.
Please pay close attention to the following guidance:
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
To learn more, see our tips on writing great answers.
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f187060%2felegant-implementation-of-factorial-tree-graph%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
@J42161217 Fixed. Thanks.
– David G. Stork
Nov 30 at 21:29