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?

|improve this question
$\endgroup$
  • $\begingroup$ What have you tried? $\endgroup$ – David G. Stork May 16 '18 at 15:56
  • $\begingroup$ You could use some sort of Fourier Transformation to get the main frequencies. $\endgroup$ – kiara May 16 '18 at 17:02
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.

|improve this answer
$\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

|improve this answer
$\endgroup$
  • $\begingroup$ I challenge the downvoter to give a reasonable explanation for his downvote. :) $\endgroup$ – Anton Antonov May 19 '18 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$ – Jack LaVigne May 19 '18 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$ – Jack LaVigne May 19 '18 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$ – Anton Antonov May 20 '18 at 0:41

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.