0
$\begingroup$

There is an elegant way to obtain the envelope of an oscillation function explained here https://mathematica.stackexchange.com/a/27854/15966

My question is how to modify the code below so I can fit data to the obtained envelope with a parameter. How do I introduce a parameter into the module so it can be used later for fitting when the result of the module is an interpolation function.

Lets' generate some data 

a = RandomReal[{20, 30}];  
b = RandomReal[{5, 10}];
data = Table[{x, Cos[a*x]^2*Exp[-b*x]}, {x, 0, 1, 0.001}];
ListPlot[data, PlotRange -> All]

The code generates something like this:

data

Now the module below produces envelope for the given oscillating function

FunctionEnvelope[f_, {t_, a_, b_}, n_: 40] := 
 Module[{seeds, x, y, points, progress = 0, tempf, union}, 
  seeds = Rescale[Range[0, 1, 1/n] + 1/(2 n), {0, 1}, {a, b}];
  points = 
   Last[Last[
     Reap[Monitor[
       Do[Quiet@
         Check[progress++; {y, x} = FindMaximum[Abs[f], {t, x0}];
          x = t /. x; If[a <= x <= b, Sow[{x, y}]], Null], {x0, 
         seeds}], 
       ProgressIndicator[progress, {0, Length[seeds]}]]]]];
  union[] := 
   points = 
    Union[points, 
     SameTest -> (Abs[First[#1] - First[#2]]/
          Replace[Max[Abs[First[#1]], Abs[First[#2]]], 
           u_ /; u == 0 :> 1] < 10^-6 &)];
  union[];
  tempf = Interpolation[points];
  points = Quiet[Join[{{a, tempf[a]}}, points, {{b, tempf[b]}}]];
  union[];
  Interpolation[points]]

It can be used as follows:

q = 50;
f[t_] := E^(- 10*Abs[t]) * Cos[1000*t]/2 + 
  E^(-10*Abs[t])*Cos[(1000 + q)*t ]/2
g = FunctionEnvelope[f[x], {x, 0, 1}, 200];
Plot[{f[x], g[x]}, {x, 0, 1}, PlotRange -> All]

enter image description here

My question is how can I modify the module above to make it a function of the parameter q, so that the resulting interpolation function can be used to fit the data to get the optimal parameter q.

(The function f[t] is in principle can be moved to the definition of the module, I'm not going to change it.)

Thanks!

|improve this question
$\endgroup$
  • $\begingroup$ Pretty sure the envelope of your function is just E^(-10 Abs[t]) Abs[Cos[q t/2]]. $\endgroup$ – Rahul Jun 18 '14 at 9:30
  • $\begingroup$ Thank you for your reply. This is certainly true for the example. However, in general I'm going to have a function like this f[t_] := E^(- g1*Abs[t]) * Cos[1000*t]/2 + E^(-g2*Abs[t])*Cos[(1000 + q)*t ]/2 where g1 and g2 will have to be found to fit the initial data. I simplified it here for convenience, to understand how to insert a parameter into the definition of a module. $\endgroup$ – Mikayel Jun 18 '14 at 12:13
4
$\begingroup$

still unclear what you are asking - is this close?

 f[q_, t_] := E^(-10*Abs[t])*Cos[1000*t]/2 + E^(-10*Abs[t])*Cos[(1000 + q)*t]/2
 g[qq_?NumericQ] := g[qq] = Evaluate[Block[{x}, FunctionEnvelope[f[qq, x], {x, 0, 1}, 200]]];

 Plot[{f[50, x], g[50][x]}, {x, 0, 1}, PlotRange -> All]

same as yours

 Plot[Table[g[q][x], {q, {2, 10, 50}}], {x, 0, 1}, PlotRange -> All]

enter image description here

edit

the is s useful thing to do whenever having issues with fitting parameters:

 Manipulate[
     Plot[g[q][x], {x, 0, 1}, PlotRange -> {0, 1}], {{q, 50}, 48, 52}]

If you run this you'll see the function jumps around somewhat erratically for small changes in the parameter. This is why you get an error " the gradient is larger than the tolerance " when running NonlinearModelFit

|improve this answer
$\endgroup$
  • $\begingroup$ Thanks for the reply. I mean. that the command NonlinearModelFit[data, g[q][x], q, x] does not go, also for your definition of g[q]. $\endgroup$ – Mikayel Jun 19 '14 at 8:15
  • $\begingroup$ fix g to take only numeric arguments (see edit) then it works with NonlinearModelFit (crummy fit though if you mean to fit to the same data ) $\endgroup$ – george2079 Jun 19 '14 at 16:35
  • $\begingroup$ I guess it's crummy, because it does not work -). $\endgroup$ – Mikayel Jun 20 '14 at 8:13
  • $\begingroup$ I guess it's crummy, because it does not work -). Let's try data = Table[{x, Abs[Cos[44*x/2]]*Exp[-10*x]}, {x, 0, 1, 0.001}]; This generates data, that fits the envelope with q=44 very well (check Show[Plot[{g[44][x]}, {x, 0, 1}, PlotRange -> All, PlotStyle -> {Thick, Red}], ListPlot[data, PlotRange -> All]] ). If we now let NonlinearModelFit try to find it near q=40: nlm = NonlinearModelFit[data, g[q][x], {{q, 40}}, x] nlm["BestFitParameters"] with your new definition of g[q], it does not work: NonlinearModelFit::sszero: The step size in the search has become.. {q -> 41.} $\endgroup$ – Mikayel Jun 20 '14 at 8:21
  • 1
    $\begingroup$ it works in the sense that it is in a form suitable for input to NonlinearSolve. The fact you don't get a good result has to do with the behavior of your function, which is an entirely different issue. There are a bunch of questions on this site dealing with fitting difficulties. Typically you need to get very close with an initial guess at the solution. $\endgroup$ – george2079 Jun 20 '14 at 12:02

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.