1
$\begingroup$

I have a density plot in image form and would like to extract the data points from it. How would I go about using Mathematica to accomplish this? My ideal output would be something in list form (x,y,value) so I can use Interpolate.

The particular example I have in mind is from here and is shown below: enter image description here

In this example, the whited-out bands are regions where the value is very large (effectively =1) and the vertical axis is a log plot, but presumably these are a minor complications.

$\endgroup$
  • $\begingroup$ Since the Figure 4 you are interested in is present as a vector image in the PDF of the paper you could Import it directly as vector Graphics object, and then apply approach similar to what I show here. $\endgroup$ – Alexey Popkov Jul 2 '17 at 12:05
2
$\begingroup$

This relies heavily on the .png quality: It looks at all pixels in the plot and convert the pixel indices to x, y coordinates. The value chosen for each is a list of colors, because in the legend some colors appear in multiple rows corresponding to nearby values. E.g a data point could be {2278.5863,6.0270489,{3.5349811 10^-10,3.6012362 10^-10}}. If a pixel color is not found on the legend that x-y-point is excluded.

pal = ImageData[ImageTake[im, {36, 36 + 394}, {865, 865 + 21}]];
cols = Round[255 pal[[All, 1]]];

colToVal = With[{f = InterpolatingPolynomial[{{1, -10}, {373, -7}}, #] &},
  With[{val = Power[10, f /@ N[Range[Length[cols]]]]}, Append[Map[val[[#]] &,
    PositionIndex[Reverse[cols]]], {255, 255, 255} -> {1.}]]];

plot = ImageTake[im, {37, 429}, {147, 858}];
dim = ImageDimensions[plot];

x[i_] = N[Expand[InterpolatingPolynomial[{{120, 1000}, {601, 4000}}, i]]];
y[i_] = Power[10, N[Expand[InterpolatingPolynomial[{{dim[[2]], -1}, {11, 3}}, i]]]];

ClearAll[a]
data = Catenate[Module[{col = Union[cols, {255, 255, 255}], pos},
          pos = PositionIndex[Flatten[Round[255 ImageData[plot]], 1]];
           MapThread[If[# =!= Indeterminate, Thread[{x[Mod[#2, dim[[1]], 1]],
                     y[Quotient[#2, dim[[1]], 1 - dim[[1]]]], a}] /. a -> #, {}] &,
                      {Lookup[colToVal, Keys[pos], Indeterminate], Values[pos]}]]];
$\endgroup$
  • $\begingroup$ I suggest you try the following code, it's very interesting :ChromaticityPlot3D[Image[im],"RGB",PlotStyle->PointSize[ 0.015],PlotTheme->"Marketing"]and ChromaticityPlot3D[Image[pal],"RGB",PlotStyle->PointSize[ 0.015],PlotTheme->"Marketing"] $\endgroup$ – andre314 Jul 1 '17 at 16:58

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.