Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Zoom2D and GetGraphicsCoordinates palettes combined

• To: mathgroup at smc.vnet.net
• Subject: [mg83125] Zoom2D and GetGraphicsCoordinates palettes combined
• From: "Ingolf Dahl" <ingolf.dahl at telia.com>
• Date: Mon, 12 Nov 2007 05:12:33 -0500 (EST)

To MathGroup,

Daniel [dh at metrohm.ch] recently posted a really nice Zoom2D palette. I have
earlier posted a GetGraphicsCoordinates palette. I have now tried to combine
these palettes, in such a way that it is possible to zoom 2D-graphics, and
then select points inside the zoomed picture (with better accuracy). I have
thus made some changes to Daniel's palette:

The palette is now self-contained, and does not require reloading of code if
the Kernel is restarted. If the palette is installed as palette, it might be
loaded from the Palette drop down menu.

I have changed the way to set the AspectRatio. One setting allows keeping
the proportions of the scales of the axes, another allows setting a chosen
fixed value of the AspectRatio.

Now it is possible to choose the cell bracket (or the graphics itself) of a
graphics cell to operate with the palette. The palette does not accept
graphics with dynamic content.

As in Daniel's palette, the Zoom button opens a new notebook containing two
graphic areas: one containing a copy of the chosen graphics, where a zoom
window can be set interactively, and another area where the zoomed window is
shown. In the zoomed window you might click to create "locators". There is
an InputField where the coordinates of the locators are shown, and where
they also might be edited. Then there is also a button, which copies these
coordinates to the clipboard and also sets the variable $LocatorPositions.
You can use "Paste" to paste the coordinates wherever you like (inside or
outside Mathematica).

Another button copies the zoomed graphics, with the chosen AspectRatio, but
without the LocatorPane and the locators.

Copy the code below to Mathematica (6.0.0 or later) and evaluate. A small
palette appears in the upper right corner. To save it, move it with the
mouse and close it. Save as a file. I save it at "C:\Documents and
Settings\Username\Application
Data\Mathematica\Applications\Palettes\FrontEnd\Palettes", but you might
instead save it anywhere and install it from the Mathematica Palette menu,
if you prefer.

Do not forget to save any important work in any open program, and do not
blame me if Mathematica crashes...

No, there is no object snap or curve snap included. That would be a quite
different tool, or rather many different tools, to satisfy all the different
demands that might be put on such a tool.

Best regards

Ingolf Dahl
http://web.telia.com/~u31815170/Mathematica/

*******************************************************************
CreatePalette[
  Button["Zoom",
   Module[{g, g0, g1, pp1, pp2, arorg},
    g0 = NotebookRead[SelectedNotebook[]];
    g0 = Cases[g0, Graphics[__] | GraphicsBox[__], {0, Infinity}, 1];
    g1 = Catch[
      If[g0 === {}, Throw[{}]];
      g =
       If[Head[g0[[1]]] == GraphicsBox, ToExpression[g0[[1]]],
        g0[[1]]];
      If[Length[Cases[g0, Dynamic[__], {0, Infinity}, 1]] > 0,
       Throw[{}]];
      {pp1, pp2} = (PlotRange /. AbsoluteOptions[g]);
      If[And[MatchQ[pp1, {_?NumberQ, _?NumberQ}],
        MatchQ[pp2, {_?NumberQ, _?NumberQ}]], {pp1, pp2} =
        Transpose[{pp1, pp2}], Throw[{}]];
      {pp1, pp2} = {0.75 pp1 + 0.25 pp2, 0.25 pp1 + 0.75 pp2};
      arorg = (AspectRatio /. AbsoluteOptions[g]);
      If[Not[NumberQ[arorg]], Throw[{}]];
      DynamicModule[{p1 = pp1, p2 = pp2, lp = {0, 0},
        aspectswitch = 0, pts = {{0, 0}}, aspectslider = 1,
        arorgdyn = arorg*(pp2[[1]] - pp1[[1]])/(pp2[[2]] - pp1[[2]])},
        Column[{LocatorPane[Dynamic[{p1, p2}],
         
          Show[{g,
            Graphics[{Opacity[0.1],
              Rectangle[Dynamic[p1], Dynamic[p2]]}]},
           ImageSize -> Small]],
         TextCell["Zoom corners:"],
         InputField[Dynamic[p1], FieldSize -> 14],
         InputField[Dynamic[p2], FieldSize -> 14],
         Row[{TextCell["AspectRatio set by slider:"],
           Checkbox[Dynamic[aspectswitch], {0, 1}]}],
         Dynamic[If[aspectswitch == 1,
           Row[{Slider[Dynamic[aspectslider], {0.2, 5., 0.1},
              ImageSize -> 150],
             InputField[Dynamic[aspectslider], FieldSize -> 3]}],
           TextCell["AspectRatio is kept as zoomed area."]]],
         LocatorPane[Dynamic[pts],
          Show[g, PlotRange :> Dynamic[Transpose[{p1, p2}]],
           Frame -> True, ImageSize -> Full,
           AspectRatio ->
            Dynamic[
             Which[aspectswitch == 0,
              Abs[arorgdyn*(p2[[2]] - p1[[2]])/(p2[[1]] - p1[[1]])],
              aspectswitch == 1, aspectslider]]],
          LocatorAutoCreate -> True],
         TextCell["Use Alt+Click to add or delete locators!"],
         TextCell["Locator positions:"],
         InputField[Dynamic[pts], FieldSize -> 14],
         Button[
          Copy locator positions, (SelectionMove[ButtonNotebook[],
            All, ButtonCell];
           SelectionMove[ButtonNotebook[], All, CellContents];
           SelectionMove[ButtonNotebook[], All, CellContents];
           FrontEndExecute[FrontEndToken[ButtonNotebook[], "Copy"]];
           Module[{b}, b = NotebookRead[ButtonNotebook[]];
            If[Length[b] >= 2, b = b[[1, 5]]; $LocatorPositions = =
b;
             SelectionMove[ClipboardNotebook[], All, Notebook];
             NotebookWrite[ClipboardNotebook[], ToBoxes[b], All];
             SelectionMove[ClipboardNotebook[], All, Notebook];
             SelectionMove[ButtonNotebook[], Before, Cell]]])],
         Button[Copy zoomed graphics, (SelectionMove[ButtonNotebook[],
             All, ButtonCell];
           SelectionMove[ButtonNotebook[], All, CellContents];
           FrontEndExecute[FrontEndToken[ButtonNotebook[], "Copy"]];
           Module[{b}, b = NotebookRead[ButtonNotebook[]];
           
            If[Length[b] >= 2,
             b = Cell[BoxData[#1],
                 "Output"] &@(b[[2, 1, 1, 7, 1,
                  2]] /. {(PlotRange :> _) -> (PlotRange ->
                    Transpose[
                    b[[1, {1,
                    2}]]]), (AspectRatio -> _) -> (AspectRatio ->
                    Which[b[[1, 4]] == 0,
                    Abs[b[[1,
                    7]]*(b[[1, 2]][[2]] -
                    b[[1, 1]][[2]])/(b[[1, 2]][[1]] -
                    b[[1, 1]][[1]])], b[[1, 4]] == 1,
                    b[[1, 6]]]), (ImageSize -> Full) -> Sequence[]});
             SelectionMove[ClipboardNotebook[], All, Notebook];
             NotebookWrite[ClipboardNotebook[], b, All];
             SelectionMove[ClipboardNotebook[], All, Notebook];
             SelectionMove[ButtonNotebook[], Before, Cell]]])],
         Dynamic[MousePosition["Graphics"]]}, Center]]];
    If[g1 === {}, CreateDialog[{TextCell["Zoom:
       
        No proper input available. Select some 2D, Mathematica-6 type \
grahics and \npress the Zoom button again! Please avoid dynamic \
content!"], DefaultButton[]}],
     CreateDocument[g1, WindowSize -> {290, All},
      WindowTitle -> "Zoom-DHID",
      WindowElements -> {"VerticalScrollBar"},
      WindowFrame -> "Palette", Background -> GrayLevel[0.96]]]]],
  WindowTitle -> "Zoom2D"];

• Follow-Ups:
  • Version 3: Zoom2D and GetGraphicsCoordinates palettes combined
    • From: "Ingolf Dahl" <ingolf.dahl@telia.com>
  • RE: Zoom2D and GetGraphicsCoordinates palettes combined
    • From: "Ingolf Dahl" <ingolf.dahl@telia.com>