Skip to main content

image processing - Fitting a two-dimensional Gaussian to a set of 2D pixels


Imagine I have a set of data like the following:


data = {{0.0453803, 0.0427863, 0.0489815, 0.045243, 0.0488289, 0.0432898, 
0.04448, 0.0387732, 0.0388952}, {0.0507668, 0.0427863, 0.0502632,
0.0503395, 0.0634623, 0.0675822, 0.0529335, 0.047425,
0.0387121}, {0.042237, 0.0501259, 0.0595712, 0.0869001, 0.139559,

0.141512, 0.0868391, 0.0579232, 0.0408331}, {0.0478981, 0.0491646,
0.0652628, 0.130404, 0.218448, 0.220645, 0.143603, 0.0605173,
0.0424964}, {0.0462043, 0.0530861, 0.076051, 0.140017, 0.206943,
0.202502, 0.118791, 0.0614023, 0.0459907}, {0.0511788, 0.0582132,
0.105531, 0.166354, 0.181003, 0.13698, 0.0748302, 0.0557107,
0.0492103}, {0.0493629, 0.0539712, 0.0971695, 0.160769, 0.164477,
0.104768, 0.0591745, 0.0475319, 0.0452583}, {0.0510719, 0.0599374,
0.0730602, 0.0975814, 0.101289, 0.0691997, 0.0498054, 0.044892,
0.043122}, {0.0460517, 0.0567025, 0.0574044, 0.0587778, 0.0537118,
0.0487221, 0.0474098, 0.0413977, 0.04477}}


plot of data


How might I best fit a Gaussian curve to this set of datapoints, and extract properties such at the fit' semi-axes? I noticed that ComponentMeasurements has some functionality for best fit ellipsoids, but that doesn't seem to be workable here.


My objective here is to determine how "Gaussian" a set of points in an image are. My strategy is to sequentially fit a 2D Gaussian to each point, and then to measure it's eccentricity and spread (looking, for example, at the length and ratio of the semiaxes of the ellipsoid corresponding to the fit). The example here seems like it should yield a 2D Gaussian fit with significant spread and a ratio for the semiaxes significantly diverging from one.



Answer



Sjoerd's answer applies the power of Mathematica's very general model fitting tools. Here's a more low-tech solution.


If you want to fit a Gaussian distribution to a dataset, you can just find its mean and covariance matrix, and the Gaussian you want is the one with the same parameters. For Gaussians this is actually the optimal fit in the sense of being the maximum likelihood estimator -- for other distributions this may not work equally well, so there you will want NonlinearModelFit.


One wrinkle is that your data doesn't fall off to zero but to something like Min[data] $\approx 0.0387$, but we can easily get rid of that by just subtracting it off. Next, I normalize the array to sum to $1$, so that I can treat it like a discrete probability distribution. (All this really does is allow me to avoid dividing by Total[data, Infinity] every time in the following.)


min = Min[data];
sum = Total[data - min, Infinity];

p = (data - min)/sum;

Now we find the mean and covariance. Mathematica's functions don't seem to work with weighted data, so we'll just roll our own.


{m, n} = Dimensions[p];
mean = Sum[{i, j} p[[i, j]], {i, 1, m}, {j, 1, n}];
cov = Sum[Outer[Times, {i, j} - mean, {i, j} - mean] p[[i, j]], {i, 1, m}, {j, 1, m}];

We can easily get the probability distribution for the Gaussian with this mean and covariance. Of course, if we want to match the original data, we have to rescale and shift it back.


f[i_, j_] := PDF[MultinormalDistribution[mean, cov], {i, j}] // Evaluate;
g[i_, j_] := f[i, j] sum + min;


The match is not too bad, although the data has two humps where the Gaussian has one. You can also compare the fit through a contour plot. (Use the tooltips to compare contour levels.)


Show[ListPlot3D[data, PlotStyle -> None], 
Plot3D[g[i, j], {j, 1, 9}, {i, 1, 9}, MeshStyle -> None,
PlotStyle -> Opacity[0.8]], PlotRange -> All]
Show[ListContourPlot[data, Contours -> Range[0.05, 0.25, 0.025],
ContourShading -> None, ContourStyle -> ColorData[1, 1], InterpolationOrder -> 3],
ContourPlot[g[i, j], {j, 1, 9}, {i, 1, 9}, Contours -> Range[0.05, 0.25, 0.025],
ContourShading -> None, ContourStyle -> ColorData[1, 2]]]


enter image description here enter image description here


The variances along the principal axes are the eigenvalues of the covariance matrix, and the standard deviations (which I guess you're calling the semi-axes) are their square roots.


Sqrt@Eigenvalues[cov]
(* {1.86325, 1.50567} *)

Comments

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...