Re: envelope of an oscillatory InterpolatingFunction
- To: mathgroup at smc.vnet.net
- Subject: [mg49832] Re: envelope of an oscillatory InterpolatingFunction
- From: Paul Abbott <paul at physics.uwa.edu.au>
- Date: Tue, 3 Aug 2004 01:11:04 -0400 (EDT)
- Organization: The University of Western Australia
- Sender: owner-wri-mathgroup at wolfram.com
Hi Stergios:
>Thanks very much! Your RootsInRange is much better than my loop
>using NMaximize. I do have one final detail to ask about.
>RootsInRange returns results of the form (where t is my
>variable):
>
>{t$9472 -> 3.3268729370875564`*^-7}
Actually, I broke the code by changing the variables (to avoid posting
code with Greek symbols). I've appended the correct code below.
Also note that Ted Ersek's package at
http://library.wolfram.com/infocenter/MathSource/4482/
is more robust that RootsInRange for finding all the roots of a function.
Cheers,
Paul
Notebook[{
Cell[CellGroupData[{
Cell["Envelope", "Section"],
Cell[TextData[{
"Why not compute the values of the extrema of the ",
Cell[BoxData[
FormBox[
StyleBox["InterpolatingFunction",
"Input"], TraditionalForm]]],
" and then use ",
Cell[BoxData[
FormBox[
StyleBox["FindFit",
"Input"], TraditionalForm]]],
" to determine the envelope? For example,"
}], "Text"],
Cell[BoxData[
RowBox[{"nsol", "=",
RowBox[{"First", "[",
RowBox[{"NDSolve", "[",
RowBox[{
RowBox[{"{",
RowBox[{
RowBox[{
RowBox[{\(5\ y[x]\), "+",
RowBox[{
SuperscriptBox["y", "\[Prime]",
MultilineFunction->None], "[", "x", "]"}], "+",
RowBox[{"10", " ",
RowBox[{
SuperscriptBox["y", "\[Prime]\[Prime]",
MultilineFunction->None], "[", "x", "]"}]}]}],
"\[Equal]", "0"}], ",", \(y[0] \[Equal] 1\), ",",
RowBox[{
RowBox[{
SuperscriptBox["y", "\[Prime]",
MultilineFunction->None], "[", "0", "]"}],
"\[Equal]",
"0"}]}], "}"}], ",", "y", ",", \({x, 0, 50}\)}],
"]"}],
"]"}]}]], "Input"],
Cell[BoxData[
\(Plot[Evaluate[y[x] /. \[InvisibleSpace]nsol], {x, 0, 50},
PlotRange \[Rule] All]\)], "Input"],
Cell[TextData[{
"Compute the (absolute) values of the extrema of the ",
Cell[BoxData[
FormBox[
StyleBox["InterpolatingFunction",
"Input"], TraditionalForm]]],
":"
}], "Text"],
Cell[BoxData[
RowBox[{
RowBox[{\({x, Abs[y[x]]}\), "/.", "\[InvisibleSpace]",
RowBox[{"RootsInRange", "[",
RowBox[{
RowBox[{"Evaluate", "[",
RowBox[{
RowBox[{
SuperscriptBox["y", "\[Prime]",
MultilineFunction->None], "[", "x", "]"}], "/.",
"\[InvisibleSpace]", "nsol"}], "]"}], ",", \({x, 0,
50}\)}],
"]"}]}], "/.", "\[InvisibleSpace]", "nsol"}]], "Input"],
Cell["\<\
and then fit to find the envelope (here assuming exponential form):\
\
\>", "Text"],
Cell[BoxData[
\(FindFit[%, c + a\/\[ExponentialE]\^\(b\ x\), {a, b, c}, x]\)],
"Input"],
Cell[CellGroupData[{
Cell["Roots in Range", "Subsubsection"],
Cell["\<\
Here is some code for finding the roots of a function over a \
specified range:\
\>", "Text"],
Cell[BoxData[
\(Needs["\<Utilities`FilterOptions`\>"]\)], "Input",
InitializationCell->True],
Cell[BoxData[
\(RootsInRange[\[Delta]_, {\[Lambda]_, \[Lambda]min_,
\[Lambda]max_},
opts___] :=
Module[{p, pts, x, f = Function[\[Lambda], Evaluate[\[Delta]]]},
p = Plot[f[\[Lambda]], {\[Lambda], \[Lambda]min, \[Lambda]max},
Compiled \[Rule] False, Evaluate[FilterOptions[Plot,
opts]]];
pts = Cases[First[p], Line[{x__}] \[Rule] x, \[Infinity]];
pts = Map[First,
Select[Split[pts, Sign[Last[#2]] \[Equal]
\(-Sign[Last[#1]]\) &],
Length[#1] \[Equal] 2 &], {2}]; \((FindRoot[
f[\[Lambda]] \[Equal] 0, {\[Lambda], Sequence @@ ##1},
Evaluate[FilterOptions[FindRoot, opts]]] &)\) /@
pts]\)], "Input",
InitializationCell->True],
Cell[BoxData[
\(RootsInRange::"\<usage\>" = "\<RootsInRange[f,{x,xmin,xmax}]
generates \
a plot of f as a function of x from xmin to xmax and then uses FindRoot
to \
determine the roots of f in the range (xmin,xmax).\>"; \)], "Input",
InitializationCell->True]
}, Open ]]
}, Open ]]
},
FrontEndVersion->"5.0 for Macintosh",
ScreenRectangle->{{0, 1436}, {0, 878}},
AutoGeneratedPackage->None,
WindowSize->{861, 787},
WindowMargins->{{124, Automatic}, {Automatic, 24}}
]
--
Paul Abbott Phone: +61 8 9380 2734
School of Physics, M013 Fax: +61 8 9380 1014
The University of Western Australia (CRICOS Provider No 00126G)
35 Stirling Highway
Crawley WA 6009 mailto:paul at physics.uwa.edu.au
AUSTRALIA http://physics.uwa.edu.au/~paul