How to get the real PlotRange of Graphics with GeometricTransformations in it?

Question

For demonstrating the problem, have a look at the following example, and try adjusting the rotation angle a and/or the Locator position, comparing the real PlotRange of pic indicated by the frame-ticks with the one under the graph obtained by AbsoluteOptions[pic, PlotRange]:

Manipulate[
 DynamicModule[{pic},
  Column[{
    pic = Graphics[{FaceForm[], EdgeForm[Black],
       GeometricTransformation[Rectangle[], RotationTransform[a]],
       Red, Point[p]},
      Frame -> True],
    p,
    AbsoluteOptions[pic, PlotRange]
    }]
  ],
 {{a, 0}, 0, 2 Pi},
 {{p, {.1, .2}}, {-2, -2}, {2, 2}, Locator}]

As shown in the screen capture above, in my Mathematica 9.0 on Windows 7 64-bit system, the PlotRange from AbsoluteOptions is not consistent with the real range. And the angle a seems to do nothing with it.

Additional tests in my system suggest this problem is not restricted on the attendance of RotationTransform, but comes with the GeometricTransformation. And it happens not only on Graphics but also on Graphics3D.

So my questions are:

• What is going on here?

• How can I obtain the real PlotRange of the Graphics/Graphics3D when there are GeometricTransformations in it?

Answer 1

AbsoluteOptions is known as very buggy function and the bug in determining the true PlotRange has very long history...

You could try my Ticks-based workaround for getting the complete PlotRange (with PlotRangePadding added):

completePlotRange[plot:(_Graphics|_Graphics3D)] := 
 Quiet@Last@
   Last@Reap[
     Rasterize[
      Show[plot, Axes -> True, Ticks -> (Sow[{##}] &), 
       DisplayFunction -> Identity], ImageResolution -> 1]]

Manipulate[
 DynamicModule[{pic}, 
  Column[{pic = 
     Graphics[{FaceForm[], EdgeForm[Black], 
       GeometricTransformation[Rectangle[], RotationTransform[a]], 
       Red, Point[p]}, Frame -> True, PlotRangePadding -> 0], p, 
    AbsoluteOptions[pic, PlotRange], completePlotRange[pic]}]], {{a, 
   4}, 0, 2 Pi}, {{p, {.1, -.6}}, {-2, -2}, {2, 2}, Locator}, 
 ContinuousAction -> False, SynchronousUpdating -> False]

EDIT

One can get the exact PlotRange (without the PlotRangePadding added) with the following function:

plotRange[plot : (_Graphics | _Graphics3D)] := 
 Quiet@Last@
   Last@Reap[
     Rasterize[
      Show[plot, PlotRangePadding -> None, Axes -> True, 
       Ticks -> (Sow[{##}] &), DisplayFunction -> Identity], 
      ImageResolution -> 1]]

Manipulate[
 DynamicModule[{pic}, 
  Column[{pic = 
     Graphics[{FaceForm[], EdgeForm[Black], 
       GeometricTransformation[Rectangle[], RotationTransform[a]], 
       Red, Point[p]}, Frame -> True], p, 
    AbsoluteOptions[pic, PlotRange], plotRange[pic]}]], {{a, 4}, 0, 
  2 Pi}, {{p, {.1, -.6}}, {-2, -2}, {2, 2}, Locator}, 
 SynchronousUpdating -> False]

EDIT 2

Here is timing comparison of various ways to get real PlotRange:

completePlotRange[plot : (_Graphics | _Graphics3D)] := 
 Quiet@Last@
   Last@Reap[
     Rasterize[
      Show[plot, Axes -> True, Ticks -> (Sow[{##}] &), 
       DisplayFunction -> Identity], ImageResolution -> 1]]
completePlotRange[plot : (_Graphics | _Graphics3D), format_] := 
 Quiet@Last@
   Last@Reap[
     ExportString[
      Show[plot, Axes -> True, Ticks -> (Sow[{##}] &), 
       DisplayFunction -> Identity, ImageSize -> 1], format]]

pic = Graphics[{FaceForm[], EdgeForm[Black], 
    GeometricTransformation[Rectangle[], RotationTransform[.3]]}, 
   Frame -> True];
Print[{#, 
     AbsoluteTiming[
      First@Table[
        completePlotRange[pic, #], {100}]]}] & /@ {"RawBitmap", "BMP",
    "WMF", "EMF", "SVG", "PDF", "EPS"};

{RawBitmap,{5.546875,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

{BMP,{5.531250,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

{WMF,{10.093750,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

{EMF,{9.265625,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

{SVG,{7.078125,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

{PDF,{39.328125,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

{EPS,{20.656250,{{-0.32158,0.981396},{-0.0250171,1.27587}}}}

AbsoluteTiming[First@Table[completePlotRange[pic], {100}]]

{6.125000, {{-0.32158, 0.981396}, {-0.0250171, 1.27587}}}

One can see that Exporting to "RawBitmap" and "BMP" is a bit faster than Rasterize (at least in this case).

Answer 2

A completely stupid workaround that perhaps someone knows how to automate:

• Create a Graphics object
  Graphics[{GeometricTransformation[Rectangle[], RotationTransform[1.]]}]
• Right click the Graphics and select Get Coordinates
• Drag around a bit in the graphics
• AbsoluteOptions[< Put the object here >, PlotRange] gives the correct PlotRange

It also works by opening Drawing Tools and making a point (or anything else)