how to make tree plot to 100 rows

Question

[

I know how to make finite tree plot(small row numbers), but how can I make this thing continue to 100 rows? Thank you very much!!

Answer 1

You can construct a graph like the following:

levelTreeGraph[level_, opts:OptionsPattern[]]:=
Block[{n, part, elist, g, vcoord},
    n = Sum[i,{i,1,level}];
    part = TakeList[Range[n],Table[i,{i,level}]];
    elist = Flatten[BlockMap[MapThread[Thread[#1->#2]&,{#[[1]],Partition[#[[2]],2,1]}]&,part, 2 ,1]];
    g = Graph[Range[n], elist, 
            GraphLayout->{"MultipartiteEmbedding","VertexPartition" -> Range[level]}];
    vcoord = Transpose[GraphEmbedding[g]]; 
    vcoord[[2]] = Rescale[vcoord[[2]],MinMax[vcoord[[2]]],Max[vcoord[[1]]]{-1/2,1/2}];
    vcoord = Transpose[vcoord];
    Graph[g, opts, VertexCoordinates -> vcoord]
]

For example:

levelTreeGraph[5, PlotTheme -> "ClassicLabeled"]

levelTreeGraph[12, PlotTheme -> "IndexLabeled", VertexSize -> 1/2]

Answer 2

Using edgesF from this answer to construct a pure function that takes an integer as an argument and Graph options:

ClearAll[edgesF, layersF, treeGraph]
layersF = TakeList[Range[# (# + 1)/2], Range@#] &;

edgesF = Flatten[Thread /@ Thread[# -> Partition[#2, 2, 1]] & @@@ 
     Partition[layersF[#], 2, 1]] &;

treeGraph = Graph[edgesF @ #, ##2, PlotTheme -> "ClassicLabeled", 
    GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> Range[#]}] &;

Examples:

Row[treeGraph[#, ImageSize -> 300] & /@ {3, 5, 9}, Spacer[5]]

Row[treeGraph[#, PlotTheme -> "IndexLabeled", ImageSize -> 300] & /@ {3, 5, 9}, Spacer[5]]

Row[treeGraph[#, PlotTheme -> None, VertexShapeFunction -> "Name", 
    ImageSize -> 300] & /@ {3, 5, 9}, Spacer[5]]

Update: If you have more than 8 layers, then you can use legacy LayeredGraphPlot (available in versions 12+ as GraphComputation`LayeredGraphPlotLegacy). (For fewer layers, graph layout needs to be adjusted.) The second argument of this function allows control of layout orientation without additional work to modify the vertex coordinates.

GraphComputation`LayeredGraphPlotLegacy[edgesF @ 9, #, 
   VertexLabeling -> True, ImageSize -> 300] & /@ {Left, Right, Top, Bottom} // Row

Answer 3

MakeSymmetricTreePlot does not appear to be a function in Mathematica V12. Is it from a package or earlier version of MMA?

Either way, I think the following should work for you:

graphRules = Flatten[
  Table[
    j -> k, 
    {i, 0, 99}, 
    {j, Sum[n, {n, i}] + 1, Sum[n, {n, i + 1}]}, 
    {k, j + i + 1, j + i + 2}
  ]
]

Limiting i to a maximum of 9, I get the following:

If you put this into your MakeSymmetricTreePlot function, you should get what you're looking for.

Answer 4

An alternative approach:

ClearAll[sa, layeredGraph]

sa = Module[{k = 1, n = #}, SparseArray[Join @@ 
  (Thread[{#, Range[n - # + 1, n + # - 1, 2]}] & /@ Range[n]) :> (k++)]] &;

layeredGraph = Module[{m = sa[#], edges},
    edges = DirectedEdge @@@ DeleteDuplicates[Sort /@ Flatten[Thread /@ 
       ComponentMeasurements[Normal[m], "Neighbors"]]];
    Graph[edges, ##2, VertexCoordinates -> m["NonzeroPositions"]]] &;

Examples:

Row[layeredGraph[#, PlotTheme -> "IndexLabeled", VertexSize -> .05 #, 
    ImageSize -> # -> 200] & /@ {3, 4, 12}, Spacer[5]]

Use PlotTheme -> "ClassicLabeled" to get:

ClearAll[reOrient]
reOrient[origin_: Left] := Module[{f = 
    Switch[origin,
      Right, ReflectionTransform[{-1, 0}], 
      Bottom, Reverse /@ # &, 
      Top, RotationTransform[-Pi/2],
      _, Identity]},
 SetProperty[#, VertexCoordinates -> f[Rescale@GraphEmbedding[#]]]] &;


Row[reOrient[#][layeredGraph[4, PlotTheme -> "IndexLabeled", 
     ImageSize -> (# /. {Left | Right -> 200, _ -> 350})]] & /@ 
  {Left, Right, Top, Bottom}, Spacer[10]]

Update: Yet another approach using NearestNeighborGraph and IndexGraph:

ClearAll[vc, layeredGraph2]
vc = Module[{n = #}, Join @@ (Thread[{#, Range[n - # + 1, n + # - 1, 2]}]& /@ Range[n])]&;

layeredGraph2 = IndexGraph[NearestNeighborGraph[vc @ #], ##2, 
    PlotTheme -> "IndexLabeled"] &;

Row[{layeredGraph2[8, ImageSize -> 300], 
  layeredGraph2[8, ImageSize -> 300, EdgeShapeFunction -> "Arrow"]}, Spacer[5]]

layeredGraph2[100, PlotTheme -> None, GraphStyle -> "LargeNetwork", 
 ImageSize -> Large]

Overlay with MatrixPlot:

Row[Show[MatrixPlot[k = 1; Transpose@SparseArray[vc[#] :> k++, Automatic, White], 
  Mesh -> All, ColorFunction -> "Pastel", Frame -> False, 
  DataRange -> {{1, #}, {1, 2 # - 1}}], 
layeredGraph2[#, EdgeShapeFunction -> "Arrow"], ImageSize -> 300] & /@ {3, 5, 7}]