Fit image of mountain to gaussian

A careful method of finding the mountain boundary including what is masked by the snow but not including the clouds:

i = Import@"http://i.stack.imgur.com/1Ui83.jpg";
edge = Closing[
  DeleteSmallComponents[Binarize[GradientFilter[Sharpen[i], 2], .1], 
   4000], {{1, 1, 1, 1, 1, 1}}]

image

(UPDATE: If one considers that at the left bottom corner we have not a snow but clouds, one can completely remove them beforehand with the following code:

dims = ImageDimensions[i];
mask = Graphics[{White, Rectangle[{0., 364}, {70, 431}]}, Background -> Black, 
   ImageSize -> dims, PlotRange -> Transpose[{{0, 0}, dims}]];
ImageApply[If[#[[1]] > .7, {.6, .8, .9}, #] &, i, Masking -> mask]

image

).

Extract the upper pixels and compare with the original image:

data = SortBy[Max /@ Transpose[#] & /@ GatherBy[ImageValuePositions[edge, White], First], 
   First];
Show[i, Graphics[{Red, Thick, Line[data]}]]

image

Sequentially fit the data by sums of Gaussians:

gauss[i_] := s[i]*PDF[NormalDistribution[a[i], b[i]], x]
model[n_] := base + Sum[gauss[i], {i, n}];
style[n_] := 
  Sequence[Evaluated -> True, 
   PlotStyle -> {{Red, Thick, Dashing[{}]}, 
     Sequence @@ 
      Take[{{Green, Dashed}, {Blue, Dashed}, {Yellow, Dashed}, {Magenta, Dashed}}, 
       n], {Red, Thick, Dashed}}];
toPlot[n_] := Join[{model[n]}, Table[base + gauss[i], {i, n}], {base}] /. fit[n]
fit[1] = FindFit[data, 
  base + gauss[1], {{base, 300}, {a[1], 1000}, {b[1], 100}, {s[1], 2*10^5}}, x]
Show[i, Plot[{model[n] /. fit[1], base /. fit[1]}, {x, 0, 1900}, 
  PlotStyle -> {{Red, Thick, Dashing[{}]}, {Red, Thick, Dashed}}], ImageSize -> 600]
{base -> 426.193, a[1] -> 983.737, b[1] -> 365.883, s[1] -> 359741.}

image

fit[2] = FindFit[
  data, {base + gauss[1] + gauss[2], base >= 0 && And @@ Table[b[i] > 0, {i, 2}]}, 
  List @@@ Join[fit[1], Rest[fit[1]] /. (p_[1] -> v_) :> {p[2], .95 v}], x]
Show[i, Plot[toPlot[2], {x, 0, 1900}, Evaluate[style[2]]], ImageSize -> 600]
{base -> 3.98312*10^-7, a[1] -> 1061.57, b[1] -> 1171.57, s[1] -> 1.7309*10^6, 
 a[2] -> 946.356, b[2] -> 265.231, s[2] -> 161146.}

image

fit[3] = FindFit[
  data, {base + gauss[1] + gauss[2] + gauss[3], 
   base >= 0 && And @@ Table[b[i] > 0, {i, 3}]}, 
  List @@@ Join[fit[2], Rest[fit[1]] /. (p_[1] -> v_) :> {p[3], v}], x]
Show[i, Plot[toPlot[3], {x, 0, 1900}, Evaluate[style[3]]], ImageSize -> 600]
{base -> 320.683, a[1] -> 1792.98, b[1] -> 267.814, s[1] -> 87111.7, a[2] -> 961.519, 
 b[2] -> 371.918, s[2] -> 471238., a[3] -> 233.468, b[3] -> 190.528, s[3] -> 37203.8}

image

fit[4] = FindFit[
  data, {base + gauss[1] + gauss[2] + gauss[3] + gauss[4], 
   base >= 0 && And @@ Table[b[i] > 0, {i, 4}]}, 
  List @@@ Join[fit[3], Rest[fit[1]] /. (p_[1] -> v_) :> {p[4], v}], x]
Show[i, Plot[toPlot[4], {x, 0, 1900}, Evaluate[style[4]]], ImageSize -> 600]
{base -> 57.7774, a[1] -> 1865.96, b[1] -> 342.875, s[1] -> 289761., a[2] -> 4.27395, 
 b[2] -> 883.184, s[2] -> 626611., a[3] -> 254.158, b[3] -> 159.113, s[3] -> 22215.1, 
 a[4] -> 992.112, b[4] -> 385.078, s[4] -> 582369.}

image


A rough draft of a solution:

img = Import["http://i.stack.imgur.com/1Ui83.jpg"];
data = ImageValuePositions[
   EdgeDetect@
    DeleteSmallComponents[
     MorphologicalBinarize[ImageTake[img, -840], {0.595, 0.9958}]], 
   White];
nlm = NonlinearModelFit[data, 
  c + s*PDF[NormalDistribution[a, b], x], {{a, 1000}, {b, 100}, {c, 300}, {s, 2*10^5}}, x];
Show[ListPlot[data, PlotStyle -> Black], 
 Plot[nlm[x], {x, 0, 1900}, PlotStyle -> Red], Frame -> True]

Solution


A method not needing "magic numbers":

i     = Import@"http://i.stack.imgur.com/1Ui83.jpg";
id    = ImageDimensions@i; 
mask  = {⌊#/2⌋, ⌊#/4⌋} &@ Reverse@id;
p     = ImageValuePositions[Image@WatershedComponents[i, mask], 0];

model = a E^(-b (x - x0)^2) + c;
fit   = FindFit[p, model, {{a, Max[Last /@ p]}, b, c, {x0, First@id/2}}, x];
j     = Plot[model /. fit, {x, 0, First@id}, Axes -> False, PlotStyle -> Thick];

Show[i, j, ImageSize -> 400]

Mathematica graphics