4
$\begingroup$

I'm trying to fit this following set of data:

data={{0, 1.3433}, {128, 1.038}, {256, 0.942054}, {384, 0.942054}, {512,0.837381}, {640, 0.819936}, {768, 0.793768}, {896, 0.689095}, {1024,0.80249}, {1152, 0.750154}, {1280, 0.741431}, {1408, 0.80249}, {1536,0.793768}, {1664, 0.793768}, {1792, 0.872272}, {1920, 0.750154}, {2048, 0.863549}, {2176, 1.038}, {2304, 1.26479}, {2432, 1.32585}, {2560, 1.4218}, {2688, 1.67476}, {2816, 1.39564}, {2944, 1.44797}, {3072, 1.33458}, {3200, 1.1514}, {3328, 1.14268}, {3456, 0.959499}, {3584, 0.915886}, {3712, 0.70654}, {3840, 0.776322}, {3968, 0.767599}, {4096, 0.846104}, {4224, 0.99439}, {4352, 0.662927}, {4480, 0.767599}, {4608, 0.750154}, {4736, 0.70654}, {4864, 0.819936}, {4992, 0.837381}, {5120, 0.767599}, {5248, 1.18629}, {5376, 1.30841}, {5504, 1.39564}, {5632, 1.29969}, {5760, 1.46542}, {5888, 1.47414}, {6016, 1.70093}, {6144, 1.18629}, {6272, 1.19501}, {6400, 0.99439}, {6528, 0.99439}, {6656, 0.933331}, {6784, 0.70654}, {6912, 0.837381}, {7040, 0.689095}, {7168, 0.636759}, {7296, 0.654204}, {7424, 0.689095}, {7552, 0.811213}, {7680, 0.819936}, {7808, 0.584422}, {7936, 0.880995}, {8064, 0.880995}, {8192, 0.924608}, {8320, 1.05545}, {8448, 1.09034}, {8576, 1.36074}, {8704, 1.57881}, {8832, 1.46542}, {8960, 1.47414}, {9088, 1.37819}, {9216, 1.29096}, {9344, 1.16884}, {9472, 1.16012}, {9600, 0.793768}, {9728, 0.907163}, {9856, 0.828658}, {9984, 0.732709}, {10112, 0.689095}, {10240, 0.776322}, {10368, 0.776322}, {10496, 0.628036}, {10624, 0.750154}, {10752, 0.566977}, {10880, 0.70654}, {11008, 0.689095}, {11136, 0.776322}, {11264, 1.01184}, {11392, 1.06417}, {11520, 1.33458}, {11648, 1.44797}, {11776, 1.50903}, {11904, 1.59626}, {12032, 1.3433}, {12160, 1.49159}, {12288, 1.30841}, {12416, 1.09034}, {12544, 0.99439}, {12672, 0.924608}, {12800, 0.70654}, {12928, 0.645481}, {13056, 0.880995}, {13184, 0.785045}, {13312, 0.758877}, {13440, 0.619313}, {13568, 0.785045}, {13696, 0.680372}, {13824, 0.70654}, {13952, 0.828658}, {14080, 0.697818}, {14208, 0.837381}, {14336, 0.985667}, {14464, 1.00311}, {14592, 1.33458}, {14720, 1.43925}, {14848, 1.52648}, {14976, 1.49159}, {15104, 1.50031}, {15232, 1.32585}, {15360, 1.11651}, {15488, 1.13395}, {15616, 0.950777}, {15744, 0.715263}, {15872, 0.880995}, {16000, 0.785045}, {16128, 0.811213}, {16256, 0.785045}, {16384, 0.767599}, {16512, 0.645481}, {16640, 0.628036}, {16768, 0.680372}, {16896, 0.697818}, {17024, 0.732709}, {17152, 0.671649}, {17280, 1.07289}, {17408, 0.89844}, {17536, 1.10779}, {17664, 1.26479}, {17792, 1.31713}, {17920, 1.31713}, {18048, 1.43925}, {18176, 1.5352}, {18304, 1.35202}, {18432, 1.20374}, {18560, 1.04673}, {18688, 0.950777}, {18816, 0.915886}, {18944, 0.758877}, {19072, 0.793768}, {19200, 0.723986}, {19328, 0.723986}, {19456, 0.811213}, {19584, 0.584422}, {19712, 0.889717}, {19840, 0.776322}, {19968, 0.70654}, {20096, 0.732709}, {20224, 0.662927}, {20352, 0.872272}, {20480, 0.854827}, {20608, 0.985667}, {20736, 1.36947}, {20864, 1.55264}, {20992, 1.32585}, {21120, 1.57881}, {21248, 1.40436}, {21376, 1.37819}, {21504, 1.24735}, {21632, 1.20374}, {21760, 0.950777}, {21888, 0.985667}, {22016, 0.846104}, {22144, 0.697818}, {22272, 0.924608}, {22400, 0.837381}, {22528, 0.828658}, {22656, 0.785045}, {22784, 0.715263}, {22912, 0.697818}, {23040, 0.767599}, {23168, 0.750154}, {23296, 0.785045}, {23424, 0.776322}, {23552, 0.889717}, {23680, 1.16012}, {23808, 1.19501}, {23936, 1.31713}, {24064, 1.38691}, {24192, 1.41308}, {24320, 1.32585}, {24448, 1.55264}, {24576, 1.09906}, {24704, 1.16884}, {24832, 1.038}, {24960, 0.959499}, {25088, 0.811213}, {25216, 0.950777}, {25344, 0.750154}, {25472, 0.70654}, {25600, 0.767599}, {25728, 0.750154}, {25856, 0.671649}, {25984, 0.654204}, {26112, 0.671649}, {26240, 0.776322}, {26368, 0.723986}, {26496, 1.02928}, {26624, 0.985667}, {26752, 1.18629}, {26880, 1.45669}, {27008, 1.2299}, {27136, 1.59626}, {27264, 1.36947}, {27392, 1.39564}, {27520, 1.31713}, {27648, 1.26479}, {27776, 0.985667}, {27904, 0.811213}, {28032, 0.907163}, {28160, 0.959499}, {28288, 0.741431}, {28416, 0.758877}, {28544, 0.741431}, {28672, 0.723986}, {28800, 0.907163}, {28928, 0.540809}, {29056, 0.732709}, {29184, 0.732709}, {29312, 0.628036}, {29440, 0.89844}, {29568, 0.907163}, {29696, 0.959499}, {29824, 1.30841}, {29952, 1.32585}, {30080, 1.57881}}

whose plot is the following:

The set of data came from an experiment so actually I don't know what is physically happening and what is the exact mathematical behaviour. Anyway I think that it’s a clear oscillatory behaviour so I thought to fit it with a sine function. Unfortunatly I’m not getting any good result from NonLinearModelFit. I'm using:

model = a*Sin[omega*x + phi] + cost;
fitFunction = NonLinearModelFit[data, {model, a > 0, omega > 0, cost > 0}, {a, omega, phi, cost}, x, Method -> NMinimize]

and i get:

FittedModel[1.00092 - 0.103163 Sin[2.61993 - 1.67308 x]

(Notice that I copied here only a small part of all data; the original one goes from -100.000 to 100.000 with jumps of 128).

Could someone explain me what the problem might be? I have done the same work with OriginLab (which obviously is specialised in data fits) and I get immediately the correct fit. Why is it not possible with Mathematica? Is it possible that the x values are too large with respect to y values? One last observation is about the orange plotted function (the fit function): ok, it's not fitting properly the data, but since it has an exact mathematical form (1.00092 - 0.103163 Sin[2.61993 - 1.67308 x), why is it changing in some intervals? It should be a periodic function and the problem arise when the interval of x is too large.

Thank you!

$\endgroup$
  • $\begingroup$ Is it just me, or does this look a little more like the transmission spectrum of a Fabry-Pérot interferometer with low finesse? The peaks look narrower than the valleys. $\endgroup$ – Gilbert Nov 21 '20 at 3:08
  • $\begingroup$ @Gilbert Those data are actually coming from the g2 correlation function of a He:Ne laser. They are obtained through an Hanbury Brown-Twiss apparatus and I’m trying to understand why I observe those fluctuations (since the source is coherent). I’m new in the filed of quantum optics so I can’t say if it could be what you have just thought. $\endgroup$ – Tech Nov 22 '20 at 23:41
  • $\begingroup$ oh cool! Yeah, I think you have interference in one of your optical elements. Photons bouncing around in a dielectric slab will be delayed by the round-trip time, effectively folding the time delay on top of itself again and again. I’m not a quantum optics practitioner, but having seen this sort of thing repeatedly in classical optics experiments, that’s my guess. You can estimate the thickness of your interference slab by period of your fit result. $\endgroup$ – Gilbert Nov 23 '20 at 11:38
  • $\begingroup$ @Gilbert Thanks for your help! I'll try to study in detail this behaviour to give the correct answer. $\endgroup$ – Tech Nov 23 '20 at 11:49
8
$\begingroup$

You need a good staring estimate for NonlinearModelFit. I would first look at your data using Fourier to get the frequencies. Thus

ft = Fourier[data[[All, 2]], FourierParameters -> {-1, -1}];
nn = Length@data;
freq = Table[(n - 1)/(nn 128.), {n, nn}];
ListLinePlot[Transpose[{freq, Abs[ft]}], 
 PlotRange -> {{0, 0.002}, {0, 0.2}}]

Spectrrum

The plot shows a clear peak at a frequency of 0.00033 Hz. Also another peak at twice that frequency. Probably a harmonic. Now you have a good starting value for your fit.

model = a*Sin[omega*x + phi] + cost;
fit = fitFunction = 
  NonlinearModelFit[data, 
   model, {a, {omega, 2 π 0.00033}, phi, cost}, x]


Show[
 ListLinePlot[data, PlotStyle -> Blue],
 Plot[fit[x], {x, data[[1, 1]], data[[-1, 1]]}, PlotStyle -> Orange]

Overlay of data and fit

Hope that helps.

$\endgroup$
6
$\begingroup$

With a little help your attempt works, it's only necessary to limit omega (remember Nyquist–Shannon sampling theorem) ! Try

fitFunction =NonlinearModelFit[data , {a*Sin[omega*x + phi] + cost,
(2 Pi)/3000  2 > omega > 0 }, {a, omega, phi, cost}, x , Method -> NMinimize ]

Show[{ Plot[ fitFunction[x  ]  , {x, 0, data[[-1, 1]]}], ListPlot[data]} ]

enter image description here

$\endgroup$
  • $\begingroup$ "[...] remember Nyquist–Shannon sampling theorem [...]" -- Ulrich means the Kotelnikov theorem! $\endgroup$ – Anton Antonov Nov 21 '20 at 14:27
  • $\begingroup$ @AntonAntonov Thanks for the hint: Here in Germany Shannon Abtasttheorem was used years ago, Wikipedia actually proposed Nyquist–Shannon sampling theorem. My knowledge seems to be out of date. $\endgroup$ – Ulrich Neumann Nov 21 '20 at 14:32
  • $\begingroup$ I was mostly joking, by the way. After I moved to "The West" I was referencing in conversations to the "Kotelnikov theorem" and was getting puzzled faces / feedback. After I learned the "Western name" of that theorem, I charted the difference as an artifact of certain "East Bloc vs The West" type of ideological wars... It is an interesting question what name did The East Germans use? :) $\endgroup$ – Anton Antonov Nov 21 '20 at 14:40
1
$\begingroup$

Regarding the nonuniformity of the orange trace in your plot : this is a consequence of "luck". The plotting functions try to minimize the number of samples actually computed. For very smooth graphs, this works very well. However, when the function oscillates rapidly, the graph will become less accurate. A way to see this is to plot $\sin(1/x)$ near $x = 0$.

Plot[Sin[1/x],{x,-1/100, 1/100}]

Mathematica graphics

Farther from $x = 0$, the function is "smooth" and is properly approximated by sparser sampling. As the frequency increases, approaching $x = 0$, very sharp features (the local minima and maxima) suffer due to sampling missing the exact extremum. Very near $x = 0$, the sampling is essentially receiving random numbers for the $y$-coordinates of the points. Sometimes those "random numbers" behave like a smooth function for a few samples (this is where big chunks are lost).

It's easy enough to trade time and memory for an improved plot.

Plot[Sin[1/x],{x,-1/100, 1/100}, MaxRecursion->7]

Mathematica graphics

or as perfect as the rendering device can resolve.

Plot[Sin[1/x],{x,-1/100, 1/100}, MaxRecursion -> 12]

Mathematica graphics

Comparing timing,

RepeatedTiming[ Plot[Sin[1/x], {x, -1/100, 1/100}] ][[1]] / 
    RepeatedTiming[ Plot[Sin[1/x], {x, -1/100, 1/100}, MaxRecursion -> 12] ][[1]]
(* 26.0714 *)

the better plot takes $26$-times longer to produce.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.