5
$\begingroup$

I have the following PDF:

enter image description here

The image contains four datasets: a solid curve, a dashed curve, big dots with error bars, and small dots with error bars.

I need to reproduce these data from this image.

First, one tries to read the content of PDF:

f = Import["C:\\Users\\...\\Downloads\\1.pdf", {"PDF", "PageGraphics"}]
curvs = Cases[f[[1, 1]], JoinedCurve[___], {0, Infinity}];
Table[{i, Graphics[curvs[[i]]]}, {i, Length[curvs]}]

Then, from that, we can write:

dataA = Apply[Join, curvs[[#]][[2, 1]] & /@ Range[189, 190]];
dataB = Apply[Join, curvs[[#]][[2, 1]] & /@ Range[30, 80]];
data = Join[dataA, dataB];
{dataRangesX, dataRangesY} = {MinMax[data[[All, 1]]], MinMax[data[[All, 2]]]}
{physRangesX, physRangesY} = {{650, 1200}, {0, 110}}
{aX, bX} = Rescale[#, dataRangesX, physRangesX] & /@ {dataA[[All, 1]], dataB[[All, 1]]};
{aY, bY} = Rescale[#, dataRangesY, physRangesY] & /@ {dataA[[All, 2]], dataB[[All, 2]]};

ListLinePlot[{Transpose[{aX, aY}], Transpose[{bX, bY}]}, 
PlotRange -> {All, {0, 110}}, FrameLabel -> {"x", "y"}, 
PlotTheme -> {"Frame", "Monochrome"}, PlotMarkers -> None]

which gives:

enter image description here

However, I'm not able to get the Mathematica to reproduce the dots and their error bars.

Any help is appreciated!

Improve this question
$\endgroup$
2

1 Answer 1

Reset to default
12
+50
$\begingroup$

This is a case of spelunking. Here's a method that might help you get what you want:

Starting with your f Get the graphical elements:

elements = Flatten[List @@ f];

Extract the JoinedCurves associated with lines:

lines = Flatten[
Cases[elements, 
JoinedCurve[{{{0, 2, 0}}}, a__, CurveClosed -> {0}] :> a, 
Infinity],
   1]

Grab the verticals and horizontal lines:

verticals = Cases[lines, {{a_, b_}, {a_, c_}}];
horizontals = Cases[lines, {{a_, c_}, {b_, c_}}];

How are we doing so far?

Graphics[{{Red, Line /@ horizontals}, {Blue, Line /@ verticals}}]

lines

The points are composed of a loop of points:

pointLoops = 
 Cases[elements,
 FilledCurve[{{{1, 4, 3}, {1, 3, 3}, {1, 3, 3}, {1, 3, 3}}},
 {a__}]  :> a, Infinity]

Extracting the "center":

points = Mean /@ pointLoops

Selecting which type of point by the radius of the pointLoop:

bigCircles = 
 Pick[points, Thread[Norm /@ StandardDeviation /@ points > 2]];
smallCircles = 
  Pick[points, Thread[Norm /@ StandardDeviation /@ points < 2]];

How are we doing so far?

Graphics[{{Red, Line /@ horizontals}, {Blue, Line /@ verticals}, 
  PointSize[0.01], Point[bigCircles], Point[smallCircles]}]

lines and points

To get error bars associated with the bigCircles:

nearBig = Nearest[First /@ bigCircles -> All]
nearestBigPoints = 
  Union@Flatten[nearBig /@ (First[Mean[#]] & /@ verticals)]

The Union is there because there are some duplicate points.

Select those meeting a nearness criteria

sel = Select[nearestBigPoints, #Distance < 0.02 &]

Extract the vertical lines according to that selection:

Extract[verticals, List /@ sel[[All, "Index"]]]

The two ends of those lines give you the error bars.

And, the same thing for the smallCircles.

I hope that is enough to get you started.

----------post edit in response to comment--------- Getting the coordinate bounds from the graphic:

{plotMinX, plotMaxX} = MinMax[First /@ horizontals]
{plotMinY, plotMaxY} = MinMax[Last /@ verticals]

Estimating the values from the graphic:

valueXMin = 600;
valueXMax = 1200;
valueYMin = -10;
valueYMax = 120;

Writing functions for the scaling:

xValue[xPlot_] := valueXMin + (valueXMax - 
         valueXMin) (xPlot - plotMinX)/(plotMaxX - plotMinX)
yValue[yPlot_] := 
     valueYMin + (valueYMax - 
         valueYMin) (yPlot - plotMinY)/(plotMaxY - plotMinY)

Example of getting values for the bigCircles:

bigCircles /. {x_, y_} :> {xValue[x], yValue[y]}

And so on, for the other values you want.

Improve this answer
$\endgroup$
4
  • 1
    $\begingroup$ It looks like the original pdf is not available, so I can give a testable answer. However, if the coordinates of, for instance, bigCircles are not the values you want, then you can transform them by finding the coordinates of the bounding box--you can extract those from the horizontal and vertical lines for the frame (red and blue) above. Then you can do a transformation because you know the values at the corners, something like xPlot = xPlotMinimum + xPlotMaximum x/(xPlotMaximum-xPlotMinimum) Did I answer your question though??? $\endgroup$ Commented Jul 11 at 9:14
  • 1
    $\begingroup$ @user106999 I edited my answer. I hope this answers your queston. $\endgroup$ Commented Jul 12 at 6:16
  • 1
    $\begingroup$ The code above should have been: smallCircles = Pick[points, Thread[Norm /@ StandardDeviation /@ pointLoops < 2]] Does this now answer your qurestion? $\endgroup$ Commented Jul 12 at 16:58
  • $\begingroup$ It works for me. Perhaps trying it from a fresh kernel? $\endgroup$ Commented Jul 13 at 7:25