Obtain Data points from a graph on an image without axes

Question

I have the following image: (which is a oscillation of the "magnetic susceptibility of gold" in y-direction, in arbitrary units, over the "magnetic field strength" from bmin = 36540 Gauss to bmax = 36784 Gauss, in x-direction).

pic = Import["https://i.sstatic.net/P6JOc.png"]

Even if it looks periodic, it should not be so, it must be periodic in 1/x (i.e. in the reciprocal of the field strength). Changing the image to a plot over 1/x I already succeeded in with the following Mathematica function:

bmin := 36540;

bmax := 36784;

f[a_, b_] := {1/(1/bmin - 1/bmax) (1/(a*(bmax - bmin) + bmin) - 1/bmax), b} 

img = ImageTransformation[pic, f[#[[1]], #[[2]]] &, PlotRange -> Automatic]

Now I get an image which looks quite similar and goes from 1/bmax to 1/bmin in the x-direction. From that image I now want to obtain the data points (along x) in y direction, such that I can do a Fourier Transform to obtain the frequencies and hence the periods in the reciprocal field strength.

How would I do that the easiest way?

btw: The background is that my professor wants us to obtain those frequencies in a problem set on the De-Haas-Van-Alphen-effct but obviously "by hand" with ruler and pen on a printed version of the graph...and I´m not gonna do that :)

Answer 1

Transform your image into a grayscale version, no alpha channel, and negate the color:

img = RemoveAlphaChannel[ColorNegate@ColorConvert[img, "Grayscale"]]

Then, extract the array of pixel values:

data = ImageData[ColorConvert[img, "Grayscale"]];
Dimensions@data
  (* return {156, 726} *)

In that array, white is 1 and black is 0. Then, simply calculate for each row the weighted average:

Total[Table[i*#[[i]], {i, Length@#}]]/Total@# & /@ Transpose[data];

(I'm sure there are more elegant ways to do that, without a table…) Then plot the result:

ListLinePlot[Flatten@%]

    

Voilà!

PS: I'd advise you to perform that on the original, scanned image instead, and only transform the coordinates afterward. (Also note: in that very narrow region of abscissa, the inversion $x \rightarrow 1/x$ is probably close enough to linear that you can neglect it…

---

Edit — okay, one mistake: the data as obtained by the above method has an inverted $y$ axis. You can fix it with:

t = Flatten[Total[Table[i*#[[i]], {i, Length@#}]]/Total@# & /@ Transpose[data]];
ListLinePlot[Dimensions[data][[1]] - # & /@ t]

Plotting the obtained data on top of the original picture reveals that it works well:

Show[
 pic,
 ListLinePlot[Dimensions[data][[1]] - # & /@ t, 
  PlotStyle -> Directive[Thick, Red]]]

However, you can see that some of the amplitude of the original data is lost due to the averaging procedure.