问题

I have a graph as a result of executing ListPlot[] function. I can manually edit this graph by moving points to a different location and also adding new points using the Drawing Tools.

How do I get the coordinates of new and changed points from the edited graphics?

回答1:

This approach makes every data point a locator that can be moved. New locators can be added and old ones deleted as appropriate. The best fit and variance are updated after every change.

Here's some data of some exponential growth with some errors and a data point missing

data = Delete[Table[{t, (1 + RandomReal[{-.2, .2}])Exp[t]}, {t, 0, 2, .2}], 6];

A little formatting command:

nForm = NumberForm[#, {2, 2}, NumberPadding -> {"", "0"}] &;

Finally, here's the code to make the manipulable graphics. New locators/data points are added using Alt-Click (or Ctrl-Alt-Click on linux). If you click on the list of points on the left, then a new window is opened containing the points in input form.

Manipulate[
 LocatorPane[Dynamic[pts, {None, Temporary, Automatic}],
  nlm = Block[{a,b,t}, NonlinearModelFit[Sort[pts], a Exp[t] + b, {a, b}, t]]; 
  Show[Plot[{Exp[t], nlm[t]}, {t, 0, 2}, 
    PlotStyle -> {{Thick, LightGray}, Dotted}, PlotRangePadding -> Scaled[0.1]], 
   ListPlot[data, PlotStyle -> Blue], AxesLabel -> Block[{t,f}, {t, f[t]}]],
  LocatorAutoCreate -> True, Appearance -> Style["\[CircleDot]", Red]],
 {nlm, None}, {{pts, data}, None},
 Dynamic[Pane[EventHandler[
    nForm@Grid[Prepend[pts, {"x", "y"}], Dividers -> {False, 2 -> True}], 
    {"MouseClicked" :> (CreateDocument[{ExpressionCell[nlm["Data"], "Output"]}, 
     WindowTitle -> "Data"])}], ImageSize -> {100, 250}, 
   ImageSizeAction -> "Scrollable", Scrollbars -> {False, True}]],
 Pane[Dynamic[nForm@Row@{nlm,Row[{"\tvariance = ",nlm["EstimatedVariance"]}]}]],
 ControlPlacement -> {Left, Left, Left, Top}]

In the above I've used the locators to correct a couple of outliers and restored the missing data point.

回答2:

I'm not sure if the following is anything like what you want,but nevertheless:

If I use ListPlot as follows:

lp1 = Labeled[
   ListPlot[Diagonal@Table[{x, y}, {x, 0, 5}, {y, 5}], 
    PlotStyle -> {Directive[Red, PointSize[Large]]}], "lp1"];

By double clicking on one of the red points twice to get the selection to the level of the points, I can then move the individual points, e.g., to make the points lie on a curve (rather than a straight line). I now want to extract these points (and say use them in a new ListPlot) [see plots below]

If I click on the bracket of the plot graphic and use "Show Expression" (Command Shift E on a Mac), I can 'see' the coordinates of the modified points which may then be extracted. For example:

expr = Cell[
   BoxData[GraphicsBox[{RGBColor[1, 0, 0], PointSize[Large], 
      PointBox[{{0., 1.}, {0.8254488458250212, 
         2.886651181634783}, {1.9301795383300084`, 
         3.925201233010209}, {3.046546974446661, 
         4.597525796319094}, {4., 5.}}]}, 
     AspectRatio -> NCache[GoldenRatio^(-1), 0.6180339887498948], 
     Axes -> True, PlotRange -> Automatic, 
     PlotRangeClipping -> True]], "Input", 
   CellChangeTimes -> {{3.504427833788156*^9, 3.50442786823486*^9}}];

Modifying a very useful approach originally suggested by Yaroslav Bulatov, which may be found here

modpoints = Flatten[Cases[expr, PointBox[___], Infinity][[All, 1]], {{2, 1}}]

EDIT

As pointed out by belisarius, it is desirable to be able to extract 'manually' added points (which may be added to the generated plot using 'point' from the Drawing Tools palette). A better way of extracting (after 'Show Expression' ...) is probably the following:

modpoints = Cases[Cases[expr, PointBox[___], 
  Infinity], {_?NumericQ, _?NumericQ}, Infinity]

Of course, 'Show Expression' is not the only approach.
InputForm is another possibility. For example,

expr2 = InputForm[ListPlotGraphic]

modpoints = Cases[Cases[expr, Point[___], 
  Infinity], {_?NumericQ, _?NumericQ}, Infinity]

where "ListPlotGraphic" is the modified graphic (inserted by 'copy and paste'), will also work.

Example plots

Addendum

The above can be automated with a little notebook programming:

lp1 = Labeled[
  ListPlot[Diagonal@Table[{x, y}, {x, 0, 5}, {y, 5}], 
   PlotStyle -> {Directive[Red, PointSize[Large]]}],
  Button["Print points",
   With[{nb = ButtonNotebook[]},
    SelectionMove[nb, All, CellContents];
    Print[Cases[NotebookRead[nb], 
       PointBox[{{_?NumericQ, _?NumericQ} ..}] | 
       PointBox[{_?NumericQ, _?NumericQ}], Infinity]]]]]

Running the above, moving the last two original (red) points and adding a couple of extra points in blue with the drawing tools then pressing the button yields

You can see that there is a single PointBox for the original data and a new PointBox for each of the added points. Of course, by modifying the above code, you can do more than simply print out the raw point coordinates.

回答3:

The easy option is to use the "Get Coordinates" menu option. If you right click on the graphic, in the pop-up menu you'll see "Get Coordinates" which allows you to mouse-over a point and see that point's coordinates. Of course this isn't going to be accurate... but the way you're editing the graphic isn't very accurate either.

You could use the InputForm (or FullForm) function, but I am not sure how well this works...

In[1]:= a = ListPlot[{{1, 0}, {0, 1}, {1, 1}}];
        a // InputForm

Out[2]//InputForm=
Graphics[{{{}, {Hue[0.67, 0.6, 0.6], Point[{{1., 0.}, {0., 1.}, {1., 1.}}]}, 
   {}}}, {AspectRatio -> GoldenRatio^(-1), Axes -> True, AxesOrigin -> {0, 0}, 
  PlotRange -> {{0., 1.}, {0., 1.}}, PlotRangeClipping -> True, 
  PlotRangePadding -> {Scaled[0.02], Scaled[0.02]}}]

You'll notice that there's a Point expression in there.

The third option would be to use Locator in some way I guess.

来源：https://stackoverflow.com/questions/4726317/getting-coordinates-of-manually-drawn-points

标签

wolfram-mathematica

Getting coordinates of manually drawn points

问题

回答1:

回答2:

EDIT

Addendum

回答3: