NonlinearModelFit Problem

Question

I have some problems with the NonlinearModelFit:

NonlinearModelFit[data, A (1 + Cos[a x]) + B (1 + Cos[b x]) + c , {A, B, a, b, c}, x]

The model should fit my data:

I tried all sort of things described in this thread.

The best Fit Mathematica gave me was a really noisy horizontal line. Even if I constrain c on a reasonable Value and give a good guess, things don't get much better. I don't know what to try next and hope to find help here in the forum.

---

Thank you again.

I can't really give you more data, since this data is the result of a quantum chemical calculation and because of the periodicity I would just get the same data again for the next period (accuracy about 0.0000002).

Just if you are interested: The data represents the absolute Energy [Hartree] of a ethylene dichloride molecule as a function of the Dihedral angle Cl-C-C-Cl.

I did a little literature research and found that all the models you suggested here were at least once used to fit similar data in some papers. You are doing a great job in this forum, I much appreciate it.

Answer 1

The fact that your data are periodic changes thinking quite a bit. But to check this all out we need to deal with symmetric part of your data that can be interpreted as a complete single period:

data = Sort[data][[19 ;; -1]]; ListPlot[data, Frame -> True]

There could be something similar to interference effect going on, when around center both cosines amplify each other, and away from the center they cancel each other out and total intensity decays fast. I decided to check this idea with a simple demo:

Manipulate[ Plot[Cos[x] + Cos[f x], {x, -3 Pi, 3 Pi}], {{f, .45, 
   "frequency"}, .1, 2, Appearance -> "Labeled"}]

So there is this sweet spot in the frequency ratio f2 ~ .45 f1 that gives a shape that looks like your data a bit. This can be reflected in setting initial values to fitting parameters:

nlm = NonlinearModelFit[data,  A Cos[a x] + B Cos[b x] + 
   c, {{A, 0.01}, {B, 0.01}, {a, 0.05}, {b, .05 .45}, {c, -997.02}}, x];

nlm[x]

-997.019 + 0.0088702 Cos[0.0250939 x] + 0.00783324 Cos[0.0527904 x]

And it turned out to be quite good for just two cos functions:

Show[ListPlot[data], Plot[nlm[x], {x, -252, 180}, PlotStyle -> Red, PlotRange -> All], 
 Frame -> True]

The conclusion is that model needs to be analysed very carefully in order to provide wise initial values to fitting parameters. Now you can better your model by introducing more cos or something else.

Answer 2

After your new info about the periodicity, I made the following:

data = ... Your data ...
l1 = {-1, 1} # & /@ Select[data, #[[1]] < 0 &];
l2 = {-1, 1} # & /@ Select[data, #[[1]] > 0 &];
ListLinePlot[data1 = MovingAverage[Sort[Join[data, l1, l2]], 3]]
data3 = data1 /. {a_, b_} -> {a + 365, b};
data4 = data1 /. {a_, b_} -> {a + 730, b};
ListLinePlot[data5 = Sort@Join[data1, data3, data4]]

Then I used that data as an input to Formulize

And I got the following function (two frequencies and one phase involved):

f1 = 0.0518618;
f2 = 0.0172907;
d  = 0.0463127; 
yy[u_] := -997.024 + 1/200 (      Cos[d - f1 u] + 
                          1.28314 Cos[f2 u] + 
                         0.649146 Cos[f2 u]^2 + 
                         0.760871 Cos[d - f1 u] Cos[f2 u]^4 + 
                          1.10543 Cos[d - f1 u] Cos[f2 u]^5)

Show[{ListPlot[data5, PlotRange -> Full], 
          Plot[yy[x], {x, -200, 1000}, PlotStyle -> Directive[Red]]}]

Of course not a simple Cos[] combination ... tell your supervisor :)

Edit

Please note that:

$f1 \approx 1/(6 \pi)$ and $f2 \approx 1/(18 \pi)$

but of course that may be just a coincidence.

Edit 2

You could always find the Fourier expansion

l1 = {-1, 1} # & /@ Select[data, #[[1]] < 0 &];
l2 = {-1, 1} # & /@ Select[data, #[[1]] > 0 &];
data2 = Last /@ GatherBy[Sort[Join[data, l1, l2]], #[[1]] &];
data3 = Plus[#, {0, 997.03}] & /@ data2[[2 ;; -2]];
cc = FourierDCT[data3[[All, 2]], 3]/Sqrt[Length@data3];
(*Now plotting*)
xg = N[Range[0, Length@data3 - 1]]/Length@data3;
fp = ListPlot[Transpose[{xg, data3[[All, 2]]}], PlotRange -> All];
Show[fp, Plot[Sum[cc[[r]]*Cos[Pi (r - 1/2) x], {r, Length[cc]}], 
              {x, -.99, .99}, PlotRange -> All]]

And the spectra is something like:

ListPlot[cc]