How can I digitize the vector figure?

Question

Consider the following figure in .pdf format. Its .png version is below:

I would like to digitize it, i.e., e.g., extract the data for the brown curve $a\to KK\pi$. How can I do this, using the fact the vector origin of the figure?

Answer 1

This answer seems to be version-dependent. It was created with

$Version

13.2.0 for Microsoft Windows (64-bit) (November 18, 2022)

Okay, let’s do this. We start off by loading the file into Mathematica while specifying that we want the graphics primitives:

imp = First@Import["a_rate.pdf", "PageGraphics"];

We notice that the graphics is mainly filled with joined curves which represents the lines. So we select them and plot this:

coordsLines = Cases[imp, _JoinedCurve, {0, Infinity}];
Graphics[coordsLines]

Okay cool, our sought-for line is there. Let’s filter the selection down a bit. We bet that our wanted line has a lot of coordinates. Let’s say, more than 100:

coordsLineSelected = Select[coordsLines, Length[#[[1, 1]]] > 100 &];
Graphics[coordsLineSelected]

We're getting there. It’s just 21 lines left. Let’s just select them by brute force looking:

Table[Graphics[{LightGray}~Join~coordsLineSelected[[;; (i - 1)]]~Join~
   coordsLineSelected[[(i + 1) ;;]]~
   Join~{Red, coordsLineSelected[[i]],
    Text[ToString[i], {0, 0}]}], {i, 1, Length@coordsLineSelected}]

Line 18 is the right one, right? So we have the coordinates. Unfortunately, they're in some coordinate system that we have to calibrate it against. However, we can extract the frame coordinates as well and thus get the minimum and maximum values of the respective components.

The x components are easy; they're linear. For y, we have to respect that it’s a log-scale.

sLineCoordinates=First[coordsLineSelected[[18,2]]]; (*get the coordinates of our line*)

frameLines=First@Select[coordsLines,2<Length[#[[1,1]]]<5&]; (*get the frame lines*)
{{xmin,xmax},{ymin,ymax}}=MinMax/@Transpose[frameLines[[2,1]]]; (*extract its coordinates*)

(*calibrate*)
x=(sLineCoordinates[[All,1]]-xmin)/(xmax-xmin)*3;
y=10^((sLineCoordinates[[All,2]]-ymin)/(ymax-ymin)*10-3);

(*plot*)
final=Transpose[{x,y}];
ListLogPlot[final,Joined->True,PlotRange->{{0,3},{10^-3,10^7}}]

It should be about right.

In Total:

ListLogPlot[Table[
  currentCoords = First[coordsLineSelected[[i, 2]]];
  Transpose[{(currentCoords[[All, 1]] - xmin)/(xmax - xmin)*3,
    10^((currentCoords[[All, 2]] - ymin)/(ymax - ymin)*10 - 3)}]
  , {i, 1, Length@coordsLineSelected}]
 , Joined -> True, PlotRange -> {{0, 3}, {10^-3, 10^7}}]

---

Edit to address the question of searching for a specific color.

Funnily enough, this is as easy as the last steps. We notice, that color in the primitives is always (at least in this specific plot) imparted by a Style call. The structure seems to be always the same: Style[{JoinedCurve[..]},style1,style2,...] So, we rewrite our Cases call to incorporate this information (and while we're at it, we convert the colors to RGB)

coloredElements=Cases[imp,
    Style[{curve_JoinedCurve,___},___,color_?ColorQ]:>{PadRight[ColorConvert[color,"RGB"],4,1],curve},
{0,Infinity}];

The PadRight is there to account for uniform transparency information so we always are presented with an {r,g,b,a} vector.

Now we define a color to search for

seekedForColor = Darker@Brown;

Now its just a matter of defining a distance-norm of the color of the line and the seeked for color. Sort this list and plot it:

colorSortedLines = SortBy[
   {
      #1, #2,
      Norm[
       (List @@ #1) - (PadRight[
          List @@ ColorConvert[seekedForColor, "RGB"], 4, 1])
       ]
      } & @@@ coloredElements,
   Last];

Graphics[{#1, #2}, PlotLabel -> #1] & @@@ colorSortedLines

The first two lines describe the lines we want to have (they're the same color and the first is the negative infinity stretching extensions of the second data line).

We successfully selected the right lines by color.