The same range on each plot in a grid

Question

Suppose I have a bunch of graphics that I want to display in a grid:

GraphicsGrid[{
  {Graphics[Circle[], Frame -> True],
   Graphics[{Circle[], Circle[{2, 2}]}, Frame -> True]},
  {Graphics[{Circle[{5, 5}, 2], Circle[{9, 9}, 2]}, Frame -> True],
   Graphics[Circle[{100, 100}, 2], Frame -> True]}}]

Each graphic is roughly the same size, but the range they cover differs. You can only see this by looking at the numbers on the axes. What I'd like to do is automatically replot the graphics over the same range so that objects are correctly sized relative to each other. Something like:

So given an array of graphics, how would I extract all the plot ranges and determine a new plot range for each one?

Answer 1

First figure out which plot has the largest x and y ranges:

vals = Map[PlotRange, {{Graphics[Circle[], Frame -> True],   Graphics[{Circle[], Circle[{2, 2}]},   Frame -> True]}, {Graphics[{Circle[{5, 5}, 2],   Circle[{9, 9}, 2]}, Frame -> True],   Graphics[Circle[{100, 100}, 2], Frame -> True]}}, {2}]
xrange = {Max@#, Min@#} &@vals[[All, 1]];
yrange = {Max@#, Min@#} &@vals[[All, 2]];
prange = PlotRange ->  {xrange, yrange}

Then replot

GraphicsGrid[{{Graphics[Circle[], Frame -> True],    Graphics[{Circle[],Circle[{2, 2}]}, Frame -> True, 
prange]}, {Graphics[{Circle[{5, 5}, 2], Circle[{9, 9}, 2]},
Frame -> True, prange],   Graphics[Circle[{100, 100}, 2], Frame -> True, prange]}}]

Answer 2

 grlist = {{Graphics[Circle[], Frame -> True],
       Graphics[{Circle[], Circle[{2, 2}]}, Frame -> True]}, 
     {Graphics[{Circle[{5, 5}, 2], Circle[{9, 9}, 2]}, Frame -> True], 
       Graphics[Circle[{100, 100}, 2], Frame -> True]}};

To get the plot ranges of the graphics in your list, you can use something like:

Map[PlotRange, grlist, {2}]
(* {{{{-1., 1.}, {-1., 1.}}, 
      {{-1., 3.}, {-1., 3.}}}, 
      {{{3., 11.}, {3., 11.}},
      {{98., 102.}, {98., 102.}}}} *)

Update: Re-plotting with new plot range values:

It is convenient to flatten to the list first and partition the final list before passing into GraphicsGrid. So,

 (* plot-ranges of the graphics in the flattened array *)
 PlotRange /@ Flatten[grlist]
 (* {{{-1.`,1.`},{-1.`,1.`}},{{-1.`,3.`},{-1.`,3.`}},{{3.`,11.`},{3.`,11.`}},
     {{98.`,102.`},{98.`,102.`}}}*)

 (* define new values for the plot-ranges, say: *)
 newPlotRanges = {{{-1.`, 3.`}, {-1.`, 3.`}}, {{-1.`, 3.`}, {-1.`,  3.`}},
    {{0.`, 15.`}, {0.`, 15.`}}, {{95.`, 105.`}, {95.`, 105.`}}}
 (* construct new `PlotRange`options and `ImagePadding` to help with alignments*) 
 optionslist = ({PlotRange -> PlotRange[#], ImagePadding -> 20, 
   ImageSize -> 200} & /@ Flatten[grlist]) /.
   Thread[PlotRange /@ Flatten[grlist] -> newPlotRanges];
 (* Put them altogether: *)
 GraphicsGrid[#, Frame -> True] &@ Partition[#, 2] &@
   MapThread[(#1 /. Graphics[x__] :> Graphics[x, Sequence @@ #2]) &, 
    {Flatten[grlist], optionslist}]

Answer 3

None of the answers so far are what I'm after, but they have inspired me to create my own solution:

ClearAll[reRange];
reRange[g_, o : OptionsPattern[]] :=
  Module[{ranges, rangePattern, xSpread, ySpread, reRanges},
    ranges = Map[PlotRange, g, {2}];
    rangePattern = {{xmin_?NumberQ, xmax_?NumberQ}, {ymin_?NumberQ, ymax_?NumberQ}};
    xSpread = 1.05 Max[ranges /. rangePattern -> xmax - xmin];
    ySpread = 1.05 Max[ranges /. rangePattern -> ymax - ymin];
    reRanges = ranges /. rangePattern -> 
      0.5 {{xmin + xmax - xSpread, xmin + xmax + xSpread},
           {ymin + ymax - ySpread, ymin + ymax + ySpread}};
    GraphicsGrid @ MapThread[Show[#1, PlotRange -> #2, FilterRules[{o}, Options[Graphics]]] &,
      {g, reRanges}, 2]
 ];

First we extract the plot ranges from our array of graphics (who knew PlotRange also worked as a function? - thanks kguler). Next we work out the biggest spread in x and y values, and add 5% for a bit of clearance. Then for each range, we expand to this biggest spread centred about the existing central value. Lastly we show the graphics with the new ranges.

In action:

reRange[{
  {Graphics[Circle[], Frame -> True], 
   Graphics[{Circle[], Circle[{2, 2}]}, Frame -> True]},
  {Graphics[{Circle[{5, 5}, 2], Circle[{9, 9}, 2]}, Frame -> True], 
   Graphics[Circle[{100, 100}, 2], Frame -> True]}
  }, ImagePadding -> 13]

For those of you playing at home, there is a bit of a catch that tripped me up for a long while. You can't seem to get the PlotRange when FilledCurves are involved:

borked = Line[RandomReal[{-100, 100}, {100, 2}]];
PlotRange @ Graphics @ borked
PlotRange @ Graphics @ FilledCurve @ borked

{{-99.2167, 97.1469}, {-95.717, 97.8384}}

{{0., 1.}, {0., 1.}}