Converting expressions to "edges" for use in TreePlot, Graph

Question

This question is similar to this: Nested list to graph. How to "flatten" an arbitrary expression, eg

expr = a[b[c, d[e][f], g], h]

to a list of key-value pairs representing Graph edges of the expression tree:

These can be extracted by applying WReach's exception-based method --> Can TreeForm be displayed “sideways”?:

Block[{TreePlot},
  t_TreePlot := Throw@Hold@t;
  Catch@MakeBoxes@TreeForm[expr]
  ][[1, 1]]

Giving:

{{"a", "0", "a[b[c, d[e][f], g], h]"} -> {"b", "1", 
   "b[c, d[e][f], g]"}, {"b", "1", "b[c, d[e][f], g]"} -> {"c", "2", 
   "c"}, {"b", "1", "b[c, d[e][f], g]"} -> {"d[e]", "3", 
   "d[e][f]"}, {"d[e]", "3", "d[e][f]"} -> {"f", "4", "f"}, {"b", "1",
    "b[c, d[e][f], g]"} -> {"g", "5", "g"}, {"a", "0", 
   "a[b[c, d[e][f], g], h]"} -> {"h", "6", "h"}}

(Why are they cast to String?) Note non-atomic sub-expressions replaced with their Head. Based on the above, and the rule: ({h_, _, _} -> {a_, _, _}) :> ToExpression@h -> ToExpression@ a gives:

{a -> b, b -> c, b -> d[e], d[e] -> f, b -> g, a -> h}

TreeForm is a wrapper around TreePlot. TreePlot[%, VertexLabeling -> True] gives:

Since the layout is different, TreePlot must be making use of the other components of the output of the Block above.

EDIT:

How do TreeForm and SparseAray`ExpressionToTree (see below) extract these pairs of vertices? "Proof of work" is to extract the position (in the expression) of each vertex along with the edges.

Previously, I asked how to extract these "edges" based on a more restricted example Alternatives ordering affects pattern matching in Cases?. Also tried ReplaceList but don't know how to map it consistently across all levels.

Answer 1

Although kguler posted an answer using a nice internal function that does this (almost) directly I find this kind of expression manipulation interesting in itself so I wanted to see what could be done without it.

expr = a[b[c, d[e][f], g], h];

edges =
  Reap[
    Cases[expr, h_[___, c_[___] | c_?AtomQ, ___] /; Sow[h -> c], {0, -1}] 
  ][[2, 1]];

TreePlot[edges, VertexLabeling -> True]

Or for the different layout:

TreePlot[edges, Automatic, Head @ expr, VertexLabeling -> True]

---

A user asked about non-unique node names. Here is a first attempt at addressing that case.

tree[expr_] :=
  Module[{e2, edges, head},
    e2 = MapIndexed[head, expr, {0, -1}, Heads -> True];
    edges = Reap[
       Cases[e2, (head[h_, x_])[___, 
          head[head[c_, {z__}][___] | c_?AtomQ, {a__}], ___] /; 
         Sow[Annotation[h, x] -> 
           Annotation[c, If[{z} === {}, {a}, {z}]]], {0, -1}]][[2, 1]];
    edges = edges /. head -> Annotation;
    TreePlot[edges, Automatic, edges[[-1, 1]], VertexLabeling -> True]
  ]

a[b[c, d[e][f], g, b, d[e][b]], h] // tree

This very likely has bugs that will need to be addressed as I did it in a hurry and tired, but I think it at least gives us a place to start.

Answer 2

An alternative method to WReach's method is to use SparseArray`ExpressionToTree which produces the same output without string wrappers:

expr = a[b[c, d[e][f], g], h];
ett = SparseArray`ExpressionToTree[expr]
(* {{a,0,a[b[c,d[e][f],g],h]}->{b,1,b[c,d[e][f],g]},
    {b,1,b[c,d[e][f],g]}->{c,2,c},
    {b,1,b[c,d[e][f],g]}->{d[e],3,d[e][f]},
    {d[e],3,d[e][f]}->{f,4,f},
    {b,1,b[c,d[e][f],g]}->{g,5,g},
    {a,0,a[b[c,d[e][f],g],h]}->{h,6,h}} *)

edges = ett[[All,All,1]] (* thanks: @Mr.Wizard *)
(* or edges = ett /. Rule[a_, b_] :> Rule[First[a], First[b]];*)
(* {a->b,b->c,b->d[e],d[e]->f,b->g,a->h} *)

Graph[edges, VertexLabels -> Placed["Name", {Center, Center}],
             VertexSize -> .3, VertexLabelStyle -> Directive[Red, Italic, 20],
             ImagePadding -> 20, ImageSize -> 400, 
             GraphLayout -> {"LayeredEmbedding", "RootVertex" -> edges[[1,1]]}]

Update: You can also use GraphComputation`ExpressionGraph:

eg = GraphComputation`ExpressionGraph[expr, VertexSize -> Large, 
   VertexLabelStyle -> Directive[Red, Italic, 20]];
SetProperty[eg,  VertexLabels -> {v_ :> 
    Placed[PropertyValue[{eg, v}, VertexLabels], Center]}]

Answer 3

IGraph/M now includes IGExpressionTree:

<<IGraphM`
IGExpressionTree[expr]

GraphQ[%]
(* True *)

Answer 4

Is this what you are seeking?

expr = a[b[c, d[e][f], g], h]
boxes = ToBoxes@TreeForm[expr]
positions = Cases[boxes, LineBox[{x__}] -> x, Infinity]
nodes =
  Cases[
    boxes,
    StyleBox[x_, __] :> ToExpression@x, Infinity] /. 
      {t_Times :> First@t, Verbatim[HoldForm][x_] -> x}
Rule @@@ Extract[nodes, List /@ positions]

{a -> b, a -> h, b -> c, b -> d, b -> g, d -> f}