Extracting intensity from density plot image given color bar

Question

I have an image showing a density plot from a paper, as well as the corresponding color bar. I am trying to convert this back to a 2D array of intensities.

Here's what I did, which works but seems to be imperfect.

imagedata = ImageData[plotimage]
colordata = ImageData[colorimage][[row]]

where row is a number which selects a single row out of the center of the color bar. imagedata is a rank 2 array of {R,G,B} values, while colordata is a rank 1 array of {R,G,B} values (between 0 and 1). I assume the color bar goes from 2 to 7. I then sample a number of colors from the bar with equal spacings,

colorbar = colordata[[1;;-1;;step]] for some integer step such as step = Round[Length@colordata/30.]. Let ncols = Length@colorbar, the number of color samples. This looks like

cols = RGBColor@@#&/@colordata[[2 ;;]]

Since the image has a lot of white space which I want to differentiate, I add a single white element as the first element: colorbar = Prepend[colorbar,{1,1,1}].

Now my basic strategy is to get each pixel's {R,G,B} (I downsample the image to make this process not take forever because it's rather inefficient) and associate it to a single element of colorbar. I don't know the best way to do this, but my strategy right now is to minimize Norm[{R,G,B}-{R',G',B'}], to find the {R',G',B'} in colorbar which is "closest" by this metric to the color of the pixel, I don't know if this is a good method of color matching though. I define a function

f[c_] := Module[{n},
  n = First@First@Position[colordata,#]&@First@MinimalBy[colordata,Norm[c-#]&]-1;
  If[n==0, 0, 2. + 5 n/ncols]
]

which takes an {R,G,B} vector, uses MinimalBy to find the element of colorbar for which the Norm of the difference is minimal, and returns its index minus one. Since white was the first index, if the result it zero I return 0 while for non-white colors I scale the output between 2 and 5 like the original color scale.

Defining a color function from the sampled colors,

colorf[x_] := Blend[cols,(x-2)/5]

the plotted result looks like this:

imagedataConverted = ParallelTable[
   f[imagedata[[j, i]]],
   {j, 1, Dimensions[imagedata][[1]], 1},
   {i, 1, Dimensions[imagedata][[2]], 1}
];

ListDensityPlot[imagedataConverted,
 ColorFunction -> colorf,
 ColorFunctionScaling -> False,
 InterpolationOrder -> 0,
 PlotLegends -> Placed[BarLegend[{colorf, {2, 7}}], Above],
 PlotRange -> {2, 7},
 ImageSize -> Small]

This seems to work, but there are some subtle differences in the output. Overall it seems to me that the output is on average a bit lighter, and especially so near the edges. This is causing me some issues because I want the match to be as close as possible, and I cannot find a way to improve the accuracy of this method. Is there a simpler/more accurate way to do this? Bonus for efficiency.

Answer 1

My method seems to work, the only thing I needed to change is the color norm. Using ColorDistance improved the results significantly.

f[c_] := Module[{n},
  n = First@First@Position[colordata,#]&@First@MinimalBy[colordata,ColorDistance[RGBColor@c,RGBColor@#]&]-1;
  If[n==0, 0, 2.+5n/ncols]
]