How to examine the structure of Graphics objects

Question

One difficulty I'm encountering in studying the structure of Graphics objects is that I have not yet found a way to print or display such structures that are sufficiently general.

The FullForm of Graphics objects can be huge and extremely difficult to take in visually. I have tried to deal with this using Shallow, but with only limited success, because I find that "the interesting bits" in a Graphics not always occur at the same depth.

It's a chicken-and-egg problem: to write a function that displays such structure in a useful way, I need to understand what such structure could be. But gaining this understanding is precisely what I'm trying to do here!

In case it matters, I'm primarily interested in examining the structure of Graphics objects generated, directly or indirectly, by plotting commands such as Plot, ListPlot, etc.

Answer 1

Finally, the following code gives you an interactive tree. You might want to enlarge the area of the tree if the nodes are too small.

structureOfGraph[gr_] := Module[{xx = gr /. Rule[a_, _] :> a /. 
  x_ /; And @@ NumericQ /@ x :> x[[0]] /. {List ..} :> 
  ListOfLists}, Manipulate[TreeForm[xx, n], {n, 1, Depth[xx] - 1, 1}]];

structureOfGraph[Show[Plot[{Cos[x], Sin[x]}, {x, 0, 4 Pi}], Graphics[{Circle[]}]]]

---

Second iteration

This second attempt makes an even shorter tree by getting rid of the terminal List:

TreeForm[Graphics[{Blue, {EdgeForm[{Red, Thick}], Disk[]}, 
 Disk[{1, 0}]}] /. x_ /; And @@ NumericQ /@ x :> x[[0]] /. x_[List] :> x]

---

First iteration

I will send this as an answer because I cannot add comments with graphics to this previous answer.

TreeForm[Graphics[{Blue, {EdgeForm[{Red, Thick}], Disk[]}, 
Disk[{1, 0}]}] /. x_ /; And @@ NumericQ /@ x :> x[[0]]]

produces

Answer 2

In light of the structure of Graphics, the best bet is to write a parser. Here is one I wrote. It is not complete, as I keep discovering directives I've missed, but it is close.

(* Utility for turning printing on/off. *)
(* --- Mr.Wizard's version of BlockPrint --- *)
ClearAll[BlockPrint];
SetAttributes[BlockPrint, HoldRest];
BlockPrint[True , body_] := Block[{Print}, body]
BlockPrint[False, body_] := body

(* Parser proper. Invoked by: parser@Graphics[...] *)
ClearAll[parser, parser`iparser, parser`directive, parser`primitive]; 

Options[parser] = {Verbose -> False};
parser[a_, opts:OptionsPattern[]] := 
Block[{parser`state = {}, parser`primList, parser`unknownfcn},
    parser`unknownfcn[_]:= Sequence[];
    BlockPrint[!OptionValue[Verbose], 
      Flatten[parser`iparser[a]] /. parser`primList -> List
    ] 
]

(* Better isolation*)
Begin["parser`"];

(* Note the changes for v10 *)
directive := _AbsolutePointSize | _Arrowheads | _CapForm | _Dashing | 
  _EdgeForm | _FaceForm | _Glow  | _JoinForm | 
  _Opacity | _PointSize |  _Specularity | _Thickness |
  If[ $VersionNumber < 10,
    _CMYKColor | _RGBColor | _GrayLevel | _Hue,
    _?ColorQ
  ];

primitive := _Arrow | _BezierCurve | _BSplineCurve | _BSplineSurface | _Circle | 
  _Cone | _Cuboid | _Cylinder | _Disk | _FilledCurve | _Inset | 
  _JoinedCurve | _Line | _Point | _Polygon | _Raster | _Raster3D | 
  _Rectangle | _Sphere | _Text | _Tube | 
  If[ $VersionNumber >= 10,
    _Ball | _Circumsphere | 
    _ConicHullRegion | _HalfLine | 
    _HalfPlane | _Hexahedron | _InfiniteLine  | 
    _Parallelepiped | _Parallelogram | _Prism | _Pyramid | 
    _Simplex | _Tetrahedron | _Triangle,
   ##&[]
  ] | 
  If[ $VersionNumber >= 10.2,
    _AffineHalfSpace | _AffineSpace | _Annulus | _CapsuleShape | 
    _Cuboid | _DiskSegment | _HalfSpace | _Hyperplane | _InfinitePlane | 
    _Insphere | _RegularPolygon | _SphericalShell | _StadiumShape,
    ##&[]
  ];

(* 
 AASTriangle, ASATriangle, SASTriangle, and SSSTriangle evaluate
 to Triangle via DownValues, so they'll never show up in Graphics(3D)
 by themselves.
*)

iparser[l_Legended] := iparser@First@l
iparser[g:(_Graphics|_Graphics3D)]:= iparser @ First @ g

iparser[{}]:= Sequence[]

iparser[l_List] := 
Internal`InheritedBlock[{state},
  Print["List"];
  iparser /@ l 
]

iparser[Style[a_, b__]]:=
Internal`InheritedBlock[{state,unknownfcn},
  (* augment unknown function to work with strings *)
  unknownfcn[str_String]:= (state = {state, str}; ##&[]);
  Print["Style"];
  iparser /@ {b};
  iparser @ a
]

iparser[GraphicsGroup[a_List]] := 
  (Print["GraphicsGroup - List"]; iparser @ a)
iparser[GraphicsGroup[a_]]:= 
  (Print["GraphicsGroup - NoList"]; iparser @ {a})

iparser[g_GraphicsComplex]:= 
  (Print["GraphicsComplex - Normalizing."]; iparser @ Normal @ g);

iparser[Directive[a___]] := 
  (Print["Directive: ", Directive[a]]; iparser /@ Flatten[{a}])

iparser[m:directive] := 
  (Print["directive: ", m]; state = {state, m}; ##&[])

iparser[p:primitive] := 
  (
   Print["primitive: ", p, "; state: ", state]; 
   (* Prevents flattening later *)
   primList[Flatten[state], p]
  )

iparser[a_] := (Print["unknown: ", a]; unknownfcn[a])
End[]; (* parser` *)

This returns a list of the form

{{{directives__}, primitive_} .. }

So, it can not be immediately used again in a Graphics object, but that can be sidestepped if need be. Applying parser to the example from the previous question

parser@Graphics[{Blue, {EdgeForm[{Red, Thick}], Disk[]}, Disk[{1,0}]}]

returns

{
 {{RGBColor[0, 0, 1], EdgeForm[{RGBColor[1, 0, 0], Thickness[Large]}]}, Disk[{0, 0}]}, 
 {{RGBColor[0, 0, 1]}, Disk[{1, 0}]}
}

as I described.

Answer 3

Here is a Graphics explorer that enables you to see the hierarchy of the Graphics statement while allowing you to open and close parts for clarity. Large graphics primitives (with 'large' I mean with lots of coordinates) are replaced with their graphical equivalents to make it a bit more compact and recognizable.

Test graphics:

plot = 
  Show[
    Plot[{Cos[x], Sin[x]}, {x, 0, 4 Pi}], 
    Graphics[{Circle[]}], 
    Graphics@GraphicsComplex[{{10, 0}, {10, 1}, {9, 0}, {10, -1}}, Polygon[{1, 2, 3, 4}]]
  ]

There we go:

graphicsExplorer[plot]

A part of the Graphics structure can now be easily indexed using the printed level indications. For instance, the Hue statement in the picture above is:

plot[[1, 1, 1, 3, 1]]

Hue[0.67, 0.6, 0.6]

The code:

ClearAll[graphicsExplorer];
graphicsExplorer[expr_] := graphicsExplorer[expr, 0, False];
graphicsExplorer[expr_, d_, gc_] :=
 Module[{h = Head[expr]},
  If[AtomQ[expr],
   Row[{d, "\[Rule]", expr}, " "],
   If[MatchQ[h, 
      Line | Polygon | Point | Arrow | Tube | BezierCurve | BSplineCurve | BSplineSurface] && 
     StringLength[ToString@expr] > 50,
    Row[{d, "\[Rule]", h, 
      Graphics[If[gc === False, expr, GraphicsComplex[gc, expr]], AspectRatio -> 1/5]}, " "],
    Framed@
     OpenerView[{Row[{d, "\[Rule]", Tooltip[h, expr]}, " "], 
       Column[MapIndexed[
         graphicsExplorer[#1, #2[[1]], 
           If[h === GraphicsComplex, expr[[1]], gc]] &, (expr /. h -> List)]]}]
    ]
   ]
  ]

A Tooltip provides a bit of context at every level.

For 3D graphics define a graphics3DExplorer in which every Graphics in the code is replaced by Graphics3D.

Answer 4

A streamlined version of Hector's "Second iteration" method:

simple = TreeForm[# //. h_[List .. | __?NumericQ] :> h] &;

Use:

Graphics[{Blue, {EdgeForm[{Red, Thick}], Disk[]}, Disk[{1, 0}]}] // simple

---

rcollyer's BlockPrint can be simplified:

SetAttributes[BlockPrint, HoldRest];
BlockPrint[False , body_] := Block[{Print}, body]
BlockPrint[True, body_] := body

I'll try to streamline the rest of his parser, once I understand it. :^)

Answer 5

When just looking for the structure all data is mostly noise, here is a way to strip out all lists that just contains numbers:

plot = Show[Plot[{Cos[x], Sin[x]}, {x, 0, 4 Pi}], Graphics[{Circle[]}]]
DeleteCases[
 plot[[1]],
 _List?(VectorQ[Flatten[#], NumericQ] &),
 Infinity]
(* {{{
     {Hue[0.67, 0.6, 0.6], Line[]},
     {Hue[0.906068, 0.6, 0.6], Line[]}
    }}, {Circle[{0, 0}]}} *)

VectorQ[Flatten[#], NumericQ] matches all lists of all shapes that contains only numbers unlike ArrayQ[#, _, NumericQ] it is True also for {{1},2} etc.

Circle[{0,0}] is in the output because after {0,0} is taken away Circle[] automatically evaluates back to Circle[{0,0}]