3
$\begingroup$

I have a set of data (included below) that I want to fit to a sinusoidal envelope to see how closely it follows this pattern. The data is:

Data1={0.309071, 0.33515, 0.509679, 0.635752, 0.623349, 0.376292, 0.00702311, -0.247732, -0.288283, 0.0392362, 0.424462, 0.185524, 0.157014, -0.193954, 0.123598, 0.495541, 0.624529, 0.44186, 0.0727319, -0.20929, -0.179794, 0.149309, 0.184027, 0.180771, -0.162702, -0.0318286, 0.280962, 0.561242, 0.518519, 0.177428, -0.13503, -0.17717, 0.0472761, 0.187547, 0.197198, -0.101749, 0.0631292, 0.382762, 0.52321, 0.422893, 0.133342, -0.068269, -0.0465858, 0.211891, 0.205344, 0.18894, 0.190942, -0.057206, -0.018655, 0.161711, 0.407714, 0.44038, 0.314649, 0.0467926, -0.0846743, 0.197518, 0.202479, 0.147582, 0.0171371, 0.0711502, 0.206846, 0.366559, 0.356282, 0.256973, 0.0971488, 0.00206637, 0.190533, 0.21806, 0.226478, 0.298721, 0.284167, 0.192472, 0.110618, 0.0577778, 0.121448, 0.249658, 0.341592, 0.199183, 0.19315, 0.195232, 0.237282, 0.285631, 0.257908, 0.163031, 0.104114, 0.119962, 0.17615, 0.227583, 0.162638, 0.17692, 0.188076, 0.238142, 0.215275, 0.241336, 0.206312, 0.195018, 0.167541, 0.188019, 0.196394, 0.233276, 0.211437, 0.196104, 0.196805, 0.235119, 0.211475, 0.207491, 0.212745, 0.181352, 0.230285, 0.185054, 0.200672, 0.209156, 0.234059, 0.175968, 0.178012, 0.128228, 0.178259, 0.211292, 0.18542, 0.185805, 0.155408, 0.221904, 0.222765, 0.20993, 0.203248, 0.218133, 0.209671, 0.207186, 0.237372, 0.271545, 0.223714, 0.203778, 0.194717, 0.209947, 0.1795, 0.158245, 0.231815, 0.270194, 0.229028, 0.214345, 0.178967, 0.147468, 0.203715, 0.213661, 0.213279, 0.172309, 0.143847, 0.147826, 0.230358, 0.210431, 0.261791, 0.207865, 0.156438, 0.131477, 0.222499, 0.205672, 0.233718, 0.23413, 0.204448, 0.157382, 0.164233, 0.216498, 0.24449, 0.258621, 0.230947, 0.208378, 0.211446, 0.220309, 0.226997, 0.165953, 0.160112, 0.213768, 0.239196, 0.271349, 0.252204, 0.165489, 0.20023, 0.178357, 0.203997, 0.230865, 0.276264, 0.248909, 0.228895, 0.143152, 0.195306, 0.210185, 0.229889, 0.218724, 0.235904, 0.246969, 0.173281, 0.177513, 0.208786, 0.221224, 0.261342, 0.262841, 0.212207, 0.160277, 0.229143, 0.202113, 0.203961, 0.249503, 0.238434, 0.213757, 0.25397, 0.229209, 0.182187, 0.216175, 0.23034, 0.229909, 0.202815, 0.242284, 0.218549, 0.256111, 0.221454, 0.205487, 0.207981, 0.237192, 0.204759, 0.217205, 0.221754, 0.200389, 0.238324, 0.243082, 0.217888, 0.201374, 0.198798, 0.189414, 0.228472, 0.227368, 0.2442, 0.200464, 0.193633, 0.159162, 0.209135, 0.262962, 0.278533, 0.253368, 0.203009, 0.135398, 0.123181, 0.204614, 0.20029, 0.222763, 0.224768, 0.299789, 0.261344, 0.210455, 0.13148, 0.146101, 0.17487, 0.249837, 0.30369, 0.202594, 0.248258, 0.294337, 0.304376, 0.2777, 0.220565, 0.111778, 0.106131, 0.144807, 0.235485, 0.283122, 0.19426, 0.21609, 0.0931201, 0.14347, 0.211519, 0.311878, 0.312163, 0.272518, 0.17686, 0.0848083, 0.120368, 0.200508, 0.197732, 0.25629, 0.339277, 0.309214, 0.256057, 0.174898, 0.0983865, 0.125015, 0.185359, 0.285428, 0.244608, 0.242815, 0.146848, 0.122946, 0.122114, 0.179348, 0.285598, 0.329529, 0.281544, 0.219595, 0.115432, 0.233389, 0.211577, 0.15348, 0.109439, 0.0885411, 0.185185, 0.300772, 0.335077, 0.292058, 0.207472, 0.101263, 0.223388, 0.216962, 0.188757, 0.0858888, 0.173627, 0.248867, 0.329886, 0.334462, 0.267857, 0.149218, 0.0939199, 0.205009, 0.204213, 0.180405, 0.220802, 0.299368, 0.319144, 0.311618, 0.192534, 0.149804, 0.0977141, 0.170934, 0.211812, 0.230457, 0.146043, 0.147742, 0.214149, 0.313017, 0.310056, 0.295263, 0.232353, 0.192809, 0.131725, 0.205076, 0.181839, 0.254358, 0.215729, 0.189337, 0.118086, 0.133628, 0.191204, 0.245922, 0.293993, 0.261041, 0.189409, 0.240371, 0.269324, 0.296122, 0.161646, 0.133229, 0.141756, 0.226917, 0.231886, 0.246886, 0.227295, 0.223463, 0.190347, 0.155447, 0.16225, 0.220588, 0.221309, 0.260858, 0.245372, 0.224228, 0.19766, 0.211557, 0.211861, 0.207691, 0.232002, 0.177278, 0.195422, 0.214852, 0.207025, 0.206766, 0.235009, 0.221069, 0.17925, 0.235326, 0.204984, 0.248338, 0.269855, 0.263508, 0.236014, 0.23071, 0.24772, 0.223968, 0.228462, 0.168735, 0.213937, 0.220366, 0.263239, 0.225068, 0.219187, 0.24838, 0.22138, 0.199448, 0.224209, 0.233003, 0.231807, 0.199574, 0.197298, 0.215652, 0.196667, 0.182118, 0.214451, 0.261312, 0.219363, 0.20681, 0.174271, 0.179097, 0.201217, 0.214468, 0.221119, 0.217908, 0.155635, 0.169446, 0.200914, 0.230277, 0.224512, 0.211738, 0.188873, 0.210123, 0.187306, 0.217841, 0.275159, 0.246055, 0.23013, 0.168858, 0.201035, 0.220072, 0.230789, 0.244695, 0.219828, 0.198347, 0.268312, 0.274949, 0.210661, 0.200858, 0.200994, 0.192099, 0.212076, 0.229709, 0.267034, 0.216645, 0.199789, 0.248571, 0.21012, 0.187611, 0.213273, 0.20734, 0.245058, 0.231637, 0.20592, 0.18638, 0.242921, 0.233676, 0.209621, 0.19435, 0.192956, 0.194512, 0.204144, 0.224806, 0.235779, 0.251603, 0.2053, 0.22598, 0.224877, 0.232533, 0.211332, 0.224546, 0.197367, 0.187678, 0.212382, 0.249761, 0.233594, 0.19201, 0.201084, 0.213968, 0.249826, 0.234896, 0.217118, 0.176485, 0.189911, 0.208698, 0.213005, 0.221254, 0.238774, 0.193031, 0.214946, 0.194444, 0.21477, 0.22283, 0.2485, 0.247803, 0.227941, 0.158324, 0.161366, 0.169061, 0.208237, 0.205385, 0.17892, 0.19634, 0.187137, 0.219079, 0.234997, 0.270446, 0.227186, 0.19585, 0.189501, 0.192457, 0.226828, 0.205672, 0.242684, 0.250321, 0.264016, 0.217203, 0.181052, 0.164646, 0.150746, 0.192029, 0.212988, 0.220697, 0.213644, 0.148598, 0.125564, 0.189824, 0.230994, 0.263338, 0.250261, 0.271088, 0.210566}

and the plot is given by

l = Table[l, {l, 0, 538}];
data = MapThread[List, {l, Data1}];
ListLinePlot[data, PlotRange -> All]

This gives the plot shown in the figure.

enter image description here

I want to see how well a damped sinusoidal envelope can be fitted to this. How can I do this?

$\endgroup$
2
  • $\begingroup$ What have you tried? $\endgroup$ Commented May 16, 2018 at 15:56
  • $\begingroup$ You could use some sort of Fourier Transformation to get the main frequencies. $\endgroup$
    – kiara
    Commented May 16, 2018 at 17:02

2 Answers 2

3
$\begingroup$

Here's one way to approach this: begin by finding the upper envelope of the curve, then fit that envelope to a nonlinear model of the desired form:

ListLinePlot[{Abs[Data1], 
  env = GaussianFilter[MaxFilter[Abs[Data1], 7], 7]}, PlotRange -> All]

enter image description here

NonlinearModelFit[env, d + c Exp[-a x] Abs[Cos[b x]], 
   {{a, .005}, {b, .01}, {c, 0.6}, {d, 0.2}}, x]
eqn[x_] = Normal[%];

fit = Table[eqn[x], {x, 1, Length[Data1]}];
ListLinePlot[{Abs[Data1], fit}, PlotRange -> All]

enter image description here

Not a very good fit... so you will need to figure out what nonlinearity you really want to use.

$\endgroup$
3
$\begingroup$

You can do this using Quantile Regression.

In order to get a good fit I used Cos instead of Sin for the upper envelope.

In order to get a different/better fit, you can experiment with different number of Sin/Cos functions and the scales of their arguments.

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/QuantileRegression.m"]

qs = {0.01, 0.99};
qFuncs1 = 
 QuantileRegressionFit[data, 
  Table[Sin[2 \[Pi]/3000*i*x], {i, 0, 100, 1}], x, {0.01}]; 
qFuncs2 = 
 QuantileRegressionFit[data, 
  Table[Cos[2 \[Pi]/3000*i*x], {i, 0, 100, 1}], x, {0.99}];
qFuncs = Join[qFuncs1, qFuncs2];

qFuncs3 = qFuncs /. {(x_?NumberQ /; Abs[x] < 10^-4) -> 0};

Show[
 Plot[qFuncs3, {x, Min[data[[All, 1]]], Max[data[[All, 1]]]}, PlotStyle -> Red, PlotRange -> All], 
 ListLinePlot[data, PlotRange -> All]]

enter image description here

Here is a screenshot of the envelope functions:

enter image description here

$\endgroup$
4
  • $\begingroup$ I challenge the downvoter to give a reasonable explanation for his downvote. :) $\endgroup$ Commented May 19, 2018 at 15:32
  • $\begingroup$ When I use Data1 rather than data I get an error about "The first argument is expected to be a matrix of numbers with two columns". What are the missing steps used to create data from Data1? Thank you in advance. $\endgroup$ Commented May 19, 2018 at 23:32
  • 1
    $\begingroup$ I created data from Data using data = Transpose[Join[{Range[Length@Data1]}, {Data1}]]; and it seemed to be the missing step. $\endgroup$ Commented May 19, 2018 at 23:39
  • $\begingroup$ @JackLaVigne Yes, you are correct. QuantileRegression requires the first argument to have the form {{_?NumericQ, _?NumericQ}..}. I was considering to have Transpose[{Range[Length[arg1]],arg1}] in case the first argument is a vector, but in a fair amount of cases Rescale[Range[Length[arg1]]] was a better choice than Range[Length[arg1]]. So, I left the t-axis addition to be done by the user. $\endgroup$ Commented May 20, 2018 at 0:41

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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