# Obtain Data points from a graph on an image without axes

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["http://i.stack.imgur.com/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 :)

-

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.

-
Thank you for your answer! But unfortunately I don't understand much of it. In the array you've named "data" you have for each point in the x-y-plane a value between 0 and 1, with white correspondig to 1 and black to 0 and in between is what? And to which image belong those, to the inverted one or the original? And that explained what does the function Total[Table[i*#[[i]], {i,Length@#}]]/Total@# & /@ Transpose[data]; actually do (I do not understand the syntax - I'm not that strong with mathematica & image processing at all). –  user4621 Nov 12 '12 at 23:03
And finally the curvature of your plot does not agree with the one in the original and neither with the 1/x transformed original!? (This got cut off from tobi's "answer"...) –  Guess who it is. Nov 13 '12 at 0:19