What is the simplest way to plot a decomposition tree in Mathematica?

7
votes

I would like to plot a "decomposition tree" in Mathematica.

I have a function f that takes an object and returns all the components of that object as a list. For the purpose of this question, let's just decompose Mathematica expressions as follows (my actual f relies on an external database to decompose different kinds of objects, so I can't easily post it):

f[e_?AtomQ] := {}
f[e_] := List @@ e

I would like to create a tree plot that shows how an object is decomposed as we recursively keep applying f. For the particular example f above, we should get something very similar to the output of TreeForm, except that a full expression should be displayed (rather than just a head) at each node. The children of a node are going to be its components as returned by f.

Note that elements can repeat in a decomposition tree like this, but not elements are repeated in the output of TreePlot as it works with graphs. One idea would be to generate a unique "internal name" for each node, construct a graph, and use TreePlot, setting it to display the actual form of the nodes rather than their "internal name"

2
wolfram-mathematica

2 Answers

9
votes

How about this?

tf[x_] := f[x] /. {{} :> x, r_ :> x @@ tf /@ r}

example usage

If any of the terms are not inert, this "simple" (?) approach will not work.

4
votes

I am not sure it answers your question, but here is how I would implement rudimentary TreeForm:

decompose[expr_?AtomQ] := expr
decompose[expr_] := Block[{lev = Level[expr, {1}]},
  Sow[Thread[expr -> lev]]; decompose /@ lev;]

treeForm[expr_] := Reap[decompose[expr]][[-1, 1]] // Flatten

Then:

enter image description here

EDIT Yes you are right, this is not a tree. To make it a tree, each expression should carry with it its position. Kind of like so:

ClearAll[treePlot, node, decompose2];
SetAttributes[{treePlot, node, decompose2}, HoldAll];
decompose2[expr_] /; AtomQ[Unevaluated[expr]] := node[expr];
decompose2[expr_] := Module[{pos, list},
  pos = SortBy[
    Position[Unevaluated[expr], _, {0, Infinity}, Heads -> False], 
    Length];
  list = Extract[Unevaluated[expr], pos, node];
  list = MapThread[Append, {list, pos}];
  ReplaceList[
   list, {___, node[e1_, p1_], ___, node[e2_, p2_], ___} /; 
     Length[p2] == Length[p1] + 1 && 
      Most[p2] == p1 :> (node[e1, p1] -> node[e2, p2])]
  ]

Then

treePlot2[expr_] := 
 Module[{data = decompose2[a^2 + Subscript[b, 2] + 3 c], gr, vlbls},
  gr = Graph[data];
  vlbls = Table[vl -> (HoldForm @@ {vl[[1]]}), {vl, VertexList[gr]}];
  Graph[data, VertexLabels -> vlbls, ImagePadding -> 50]
  ]

enter image description here