How do I get the crosshair behavior of Wolfram|Alpha 2D graphics in Mathematica?

Question

When the mouse cursor is over a 2D plot in Wolfram|Alpha, a pair of grey lines appear that help you read the coordinates off the x and y axes. For example, I have the mouse over one of the turning points in the following plot of the Airy function.

The above can also be obtained inside Mathematica using

WolframAlpha["Plot Ai(x)", {{"Plot", 1}, "Content"}]

which has the added advantage of some sort of locator showing the coordinates.

---

How can I emulate such behavior in a normal Mathematica graphics/plot?

Answer 1

Here's another approach using Nearest, that's a bit different from Simon's:

plot = Plot[{Sin[x], Cos[x]}, {x, -2 Pi, 2 Pi}];
With[{nf = Nearest[Flatten[Cases[Normal[plot], Line[p_, ___] :> p, Infinity], 1]]},
   Show[plot, 
      Epilog -> 
         Dynamic[DynamicModule[{
            pt = First[nf[MousePosition[{"Graphics", Graphics}, {0, 0}]]], 
            scaled = Clip[MousePosition[{"GraphicsScaled", Graphics}, {0, 0}], {0, 1}]
            }, 
           {
            {If[scaled === None, {}, 
               {Lighter@Gray, Line[{
                   {Scaled[{scaled[[1]], 1}], Scaled[{scaled[[1]], 0}]}, 
                   {Scaled[{1, scaled[[2]]}], Scaled[{0, scaled[[2]]}]}
                   }]
               }]}, 
            {AbsolutePointSize[7], Point[pt], White, AbsolutePointSize[5], Point[pt]},
            Text[Style[NumberForm[Row[pt, ", "], {5, 2}], 12, Background -> White], Offset[{7, 0}, pt], {-1, 0}]}
         ]]
    ]
 ]

This was put together from example I had laying around. (I don't like the free-floating drop-lines combined with the point tracking; either on its own feels fine.)

Answer 2

Here is one with the features you requested in comments:

locatorPlot[func_, r : {var_, __}, other___] :=
 LocatorPane[
   Dynamic[pos, (pos = {#, func /. var -> #}) & @@ # &],
   Column[{Plot[func, r, other], Dynamic@pos}],
   AutoAction -> True,
   Appearance ->
     Graphics[{Gray, Line @ {{{-1, 0}, {1, 0}}, {{0, -1}, {0, 1}}}},
       ImageSize -> Full]
 ]

locatorPlot[AiryAi[z], {z, -11, 5}, ImageSize -> 400]

---

Here is a rather clunky update to handle your new requests:

locatorPlot[func_List, r : {var_, __}, other___] :=
 DynamicModule[{pos, pos2},
  LocatorPane[
   Dynamic[pos, (pos = #; (pos2 = {#, First@Nearest[func /. var -> #, #2]}) & @@ #) &],
   Plot[func, r, other,
     Epilog ->
      {Text[\[GrayCircle], Dynamic@pos2], Text[Dynamic@pos2, Dynamic@pos2, {-1.2, 0}]}
   ],
   AutoAction -> True,
   Appearance -> 
     Graphics[{Gray, Line@{{{-1, 0}, {1, 0}}, {{0, -1}, {0, 1}}}}, ImageSize -> Full]
   ]
  ]

locatorPlot[{AiryAi[z], Sin[z]}, {z, -11, 5}, ImageSize -> 400]

Answer 3

Here's my version that behaves similarly to the Wolfram|Alpha output, except for its handling of multiple plots. In the W|A graphics, the circle and the text jump to the nearest curve, and disappear completely when the cursor is not over the graphics. It would be nice to add in the missing functionality and maybe make the code more flexible.

WAPlot[fns_, range : {var_Symbol, __}] := 
 DynamicModule[{pos, fn = fns},
  If[Head[fn] === List, fn = First[Flatten[fn]]];
  LocatorPane[Dynamic[pos, (pos = {var, fn} /. var -> #[[1]]) &], 
   Plot[fns, range, Method -> {"GridLinesInFront" -> True},
    GridLines->Dynamic[{{#,Gray}}&/@MousePosition[{"Graphics",Graphics},None]]],
   AutoAction -> True, 
   Appearance -> Dynamic[Graphics[{Circle[pos, Scaled[.01]], 
       Text[Framed[Row[pos, ", "], RoundingRadius -> 5, 
         Background -> White], pos, {-1.3, 0}]}]]]]

Then, e.g.

WAPlot[{{AiryAi[x], -AiryAi[x]}, AiryBi[x]}, {x, -10, 2}]

---

Here's a new version that uses MousePosition instead of LocatorPane and steals Mr W's code to make the circle move to the nearest curve. The behaviour is now almost identical to the WolframAlpha output.

WAPlot[fns_, range : {var_Symbol, __}] := 
 DynamicModule[{fnList = Flatten[{fns}]}, Plot[fnList, range,
   GridLines -> 
    Dynamic[{{#, Gray}} & /@ MousePosition[{"Graphics", Graphics}]],
   Method -> {"GridLinesInFront" -> True},
   Epilog -> Dynamic[With[{mp = MousePosition[{"Graphics", Graphics}, None]},
      If[mp === None, {}, 
       With[{pos = {#1, First@Nearest[fnList /. var -> #1, #2]}& @@ mp},
        {Text[Style["\[EmptyCircle]", Medium, Bold], pos], 
         Text[Style[NumberForm[Row[pos, ", "], 2], Medium], pos, 
          {If[First[MousePosition["GraphicsScaled"]] < .5, -1.3, 1.3], 0}, 
          Background -> White]}]]]]
   ]]

The output looks very similar to the previous version so I won't post a screenshot.