2
$\begingroup$

I have this scatter plot and regression line for which I wish I had the original data. I know I can use the coordinates tool in Mathematica to get individual points but that is very tedious and time-consuming. Assuming (a) there are no overlaps, and (b) neither axis is log- or other scaled, is there a way to automate that? All the examples I was able to find on this site are for lines, curves, or functions.

enter image description here

Improve this question
$\endgroup$
2
  • 2
    $\begingroup$ See the links mentioned in comments to this previous question, and Alexei's pre-packaged function. Give any of those methods a good try and then let us know if something does not work out. Please include the code you tried when you do so. $\endgroup$
    – MarcoB
    Jan 11, 2022 at 3:49
  • $\begingroup$ I learned a lot about what is necessary to do this and how it affected by the complication that I want only the points, not the line. In the end, tedious though it was, using the Get Coordinates tool worked and the line I produced with the data was a near perfect match. $\endgroup$
    – Rogo
    Jan 12, 2022 at 3:17

3 Answers 3

Reset to default
0
$\begingroup$

Here I present an alternative approach, which might give better results in some cases because it makes use of the grayscale information from the original image.

img = ColorNegate@
   ColorConvert[RemoveAlphaChannel@Import["https://i.stack.imgur.com/8OFWu.png"], "Grayscale"];

Select a kernel representing the most typical point on the plot:

ker = ImageTake[img, {157, 166}, {186, 195}];
ImageResize[ker, Scaled[10]]

image

Make a mask for our points:

mask = ColorNegate@Closing[MorphologicalBinarize@ColorNegate@img, 1]

image

Perform image deconvolution with our kernel and masked image:

imgDec = ImageDeconvolve[img*mask, ker, Method -> "RichardsonLucy"];
% // ImageAdjust

image

Isolate the points and visualize the results (click to enlarge!):

maxDec = MaxDetect[imgDec];
ImageResize[imgPts = ImageAdd[ColorNegate@img, ImageMultiply[maxDec, Red]], Scaled[2]]

image

Visual inspection of the result convinces us that the points are isolated perfectly in all cases.

Check how the center of the point is determined in the case of our kernel:

ImageTake[imgPts, {157, 166}, {186, 195}];
ImageResize[%, Scaled[10]]

image

The maximum is not exactly at the center of the kernel because the kernel has even dimensions:

ImageDimensions[ker]

{10, 10}

Upsizing the original image with a factor of 3 might give more precise results.

Determine the point coordinates and the axes origin, then overlay the points and the lines with the original image:

pts = Values@ComponentMeasurements[maxDec, "Centroid"];
lines = ImageLines[Binarize@img];
axesOrigin = RegionIntersection[lines[[1]], lines[[3]]][[1, 1]];
HighlightImage[ColorNegate@img, {Opacity[.5], Green, lines, 
                     Yellow, PointSize[.01], Point[pts], 
                     Red, Point[axesOrigin]}]

image

Improve this answer
$\endgroup$
3
  • $\begingroup$ Just what I need. Many thanks. I tried my original image which was JPG and it did not work. But mine was scaled differently so that could have been the reason. I adapted the scale and all went well. Does your method require PNG? $\endgroup$
    – Rogo
    Jan 16, 2022 at 20:07
  • $\begingroup$ @Rogo JPG is a lossy format, it introduces artifacts, from which the image in some cases will have to be specially cleaned in order for my method to work correctly. But in many cases, it still should work, if JPEG quality is high enough. If it doesn't work, look at the mask produced by my code - it may require adapting. $\endgroup$
    – Alexey Popkov
    Jan 17, 2022 at 5:51
  • $\begingroup$ @Rogo The main problem with JPEG is that, apart from introducing artifacts, it also corrupts original grayscale information. If the corruption is significant, it may be better to fall back to the other method I posted here, which doesn't use grayscale information. $\endgroup$
    – Alexey Popkov
    Jan 17, 2022 at 6:05
1
$\begingroup$

None of the earlier code seemed to work on my image. Not sure why.

I did figure out a check on the brute strength method. Using GetCoordinates one click at a time produced the points below. I deliberately left one out and deliberately clicked where there was no point.

Here is the original image, named img in the code

enter image description here

Here are the coordinates for nearly all of them

pts = {{251.8181818181818`,

109.22585227272731}, {252.34280303030306, 102.40577651515154}, {241.32575757575762, 53.878314393939434}, {238.44034090909093, 67.78077651515156}, {235.55492424242425, 83.5194128787879}, {234.24337121212125, 97.68418560606064}, {224.01325757575762, 106.34043560606064}, {229.5217803030303, 117.88210227272731}, {229.2594696969697, 132.83380681818187}, {213.25852272727275, 147.7855113636364}, {208.79924242424244, 118.93134469696973}, {208.01231060606062, 121.5544507575758}, {196.99526515151516, 137.29308712121215}, {198.5691287878788, 108.70123106060609}, {192.27367424242425, 111.84895833333337}, {191.48674242424244, 104.2419507575758}, {193.8475378787879, 85.88020833333337}, {184.14204545454547, 78.01089015151518}, {188.07670454545456, 74.8631628787879}, {174.17424242424244, 73.02698863636368}, {173.64962121212122, 70.92850378787881}, {180.7320075757576, 86.66714015151518}, {176.7973484848485, 99.25804924242428}, {173.91193181818184, 95.32339015151518}, {169.45265151515153, 91.1264204545455}, {165.78030303030303, 87.45407196969701}, {157.64867424242425, 86.66714015151518}, {171.28882575757578, 107.65198863636367}, {165.78030303030303, 108.9635416666667}, {158.43560606060606, 122.07907196969701}, {189.125946969697, 122.07907196969701}, {179.94507575757578, 159.85179924242428}, {168.4034090909091, 143.0639204545455}, {153.71401515151516, 154.34327651515156}, {141.12310606060606, 129.94839015151518}, {140.59848484848487, 118.14441287878792}, {145.84469696969697, 111.84895833333337}, {155.8125, 105.0288825757576}, {147.94318181818184, 94.53645833333337}, {149.25473484848487, 91.38873106060609}, {144.00852272727275, 81.15861742424246}, {155.0255681818182, 81.15861742424246}, {158.69791666666669, 73.55160984848487}, {164.73106060606062, 55.97679924242428}, {139.28693181818184, 73.8139204545455}, {148.46780303030303, 51.517518939393966}, {146.3693181818182, 39.45123106060609}, {136.40151515151516, 11.383996212121247}, {123.02367424242425, 34.205018939393966}, {130.10606060606062, 65.94460227272731}, {128.7945075757576, 64.10842803030306}, {123.28598484848487, 61.74763257575762}, {116.99053030303031, 63.32149621212125}, {115.15435606060606, 71.45312500000003}, {115.15435606060606, 75.65009469696975}, {136.40151515151516, 91.91335227272731}, {133.7784090909091, 93.74952651515154}, {132.46685606060606, 101.09422348484853}, {132.46685606060606, 86.14251893939397}, {127.48295454545456, 81.94554924242428}, {123.81060606060606, 86.14251893939397}, {129.0568181818182, 93.22490530303034}, {128.7945075757576, 97.68418560606064}, {124.8598484848485, 101.09422348484853}, {128.00757575757578, 103.97964015151518}, {127.74526515151516, 107.91429924242428}, {123.81060606060606, 115.25899621212125}, {124.59753787878788, 118.14441287878792}, {123.54829545454547, 152.76941287878793}, {114.89204545454547, 106.07812500000004}, {110.43276515151516, 96.3726325757576}, {108.85890151515153, 94.53645833333337}, {103.08806818181819, 69.8792613636364}, {103.35037878787881, 79.06013257575762}, {103.6126893939394, 76.43702651515156}, {100.98958333333334, 76.43702651515156}, {100.98958333333334, 84.30634469696975}, {102.56344696969697, 91.91335227272731}, {101.77651515151516, 95.06107954545458}, {95.21875, 116.57054924242428}, {91.28409090909092, 131.5222537878788}, {88.92329545454547, 105.55350378787882}, {86.82481060606061, 107.91429924242428}, {85.77556818181819, 94.53645833333337}, {65.57765151515152, 115.52130681818186}, {72.66003787878789, 93.48721590909095}, {83.67708333333334, 82.20785984848487}, {86.82481060606061, 81.42092803030306}, {88.66098484848486, 74.07623106060609}, {81.05397727272728, 71.19081439393943}, {88.92329545454547, 67.51846590909093}, {91.80871212121212, 60.173768939393966}, {89.18560606060606, 59.38683712121215}, {75.02083333333334, 61.2230113636364}, {63.47916666666667, 26.598011363636402}, {42.756628787878796, 77.22395833333337}, {50.363636363636374, 49.94365530303034}, {16.78787878787879, 67.25615530303034}, {14.427083333333336, 93.74952651515154`}}

This makes it easy to find missing ones

ptsFound =   ListPlot[pts, PlotStyle -> {PointSize[.013], Red, Opacity[.3]},PlotMarkers -> "OpenMarkers"];Show[{img, ptsFound}]

Thus enter image description here

Another attempt involved ImageCorners, but it would not align with the original image in the same way.

corners = ImageCorners[img, 2, .002, 20, MaxFeatureDisplacement -> 5]

That only finds 55 coordinates and they are scaled way off the pts coord values so the Show[ ] with both does not work well.

ListPlot[corners, PlotStyle -> {PointSize[.013], Red, Opacity[.3]},PlotMarkers -> "OpenMarkers",Prolog -> {Texture[img],Polygon[{Scaled[{-0.000, -0.03}], Scaled[{1, -0.03}],Scaled[{1, 1}], Scaled[{-0.000, 1}]},VertexTextureCoordinates ->{{-0.02, -0.02}, {0.99, -0.02}, {0.99,0.99}, {-0.02, 0.99}}]}]

Not much help

enter image description here

Improve this answer
$\endgroup$
1
$\begingroup$ 
img = RemoveAlphaChannel@Import["https://i.stack.imgur.com/8OFWu.png"];

Remove lines from the image and find their coordinates:

img1 = Closing[MorphologicalBinarize@img, 1]
lines = ImageLines@ColorNegate[Binarize@img]

image

{Line[{{0., 9.36579}, {791., 9.36579}}], 
 Line[{{0., 198.374}, {791., 316.896}}], 
 Line[{{11.1547, 492.}, {10.408, 0.}}]}

Isolate the points and visualize the results (click to enlarge!):

dtmax = Pruning@MaxDetect@DistanceTransform@ColorNegate@img1;
ImageResize[ImageAdd[img, ImageMultiply[dtmax, Red]], Scaled[2]]

image

Visual inspection of the result convinces us that the points are isolated perfectly in all cases.

Determine the point coordinates and the axes origin and overlay the points and the lines with the original image:

pts = Values@ComponentMeasurements[dtmax, "Centroid"];
axesOrigin = RegionIntersection[lines[[1]], lines[[3]]][[1, 1]];
HighlightImage[img, {Opacity[.5], Green, lines, Yellow, PointSize[.01], Point[pts], 
  Red, Point[axesOrigin]}]

image

Translate the coordinates to the origin and plot the data:

tr = TranslationTransform[-axesOrigin];
data = tr@pts;
lp = ListPlot[data, Prolog -> {Green, tr@lines[[2]]}, ImageSize -> 720]

image

Bonus: fit the linear model and plot it along with the recovered data:

lm = LinearModelFit[data, x, x];
Show[lp, Plot[lm[x], {x, 0, 730}]]

plot

Improve this answer
$\endgroup$

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.