The following Mathematica code generates a highly oscillatory plot. I want to plot only the lower envelope of the plot but do not know how. Any suggestions wouuld be appreciated.

```
tk0 = \[Theta]'[t]*\[Theta]'[t] - \[Theta][t]*\[Theta]''[t]
tk1 = \[Theta]''[t]*\[Theta]''[t] - \[Theta]'[t]*\[Theta]'''[t]
a = tk0/Sqrt[tk1]
f = Sqrt[tk1/tk0]
s =
NDSolve[{\[Theta]''[t] + \[Theta][t] - 0.167 \[Theta][t]^3 ==
0.005 Cos[t - 0.5*0.00009*t^2], \[Theta][0] == 0, \[Theta]'[0] ==
0}, \[Theta], {t, 0, 1000}]
Plot[Evaluate [f /. s], {t, 0, 1000},
Frame -> {True, True, False, False},
FrameLabel -> {"t", "Frequency"},
FrameStyle -> Directive[FontSize -> 15], Axes -> False]
```

I don't know how fancy you want it to look, but here is a brute force approach which would be good enough for me as a starting point, and can probably be tweaked further:

```
tk0 = \[Theta]'[t]*\[Theta]'[t] - \[Theta][t]*\[Theta]''[t];
tk1 = \[Theta]''[t]*\[Theta]''[t] - \[Theta]'[t]*\[Theta]'''[t];
a = tk0/Sqrt[tk1];
f = Sqrt[tk1/tk0];
s = NDSolve[{\[Theta]''[t] + \[Theta][t] - 0.167 \[Theta][t]^3 ==
0.005 Cos[t - 0.5*0.00009*t^2], \[Theta][0] == 0, \[Theta]'[0] ==
0}, \[Theta], {t, 0, 1000}];
plot = Plot[Evaluate[f /. s], {t, 0, 1000},
Frame -> {True, True, False, False},
FrameLabel -> {"t", "Frequency"},
FrameStyle -> Directive[FontSize -> 15], Axes -> False];
Clear[ff];
Block[{t, x},
With[{fn = f /. s}, ff[x_?NumericQ] = First[(fn /. t -> x)]]];
localMinPositionsC =
Compile[{{pts, _Real, 1}},
Module[{result = Table[0, {Length[pts]}], i = 1, ctr = 0},
For[i = 2, i < Length[pts], i++,
If[pts[[i - 1]] > pts[[i]] && pts[[i + 1]] > pts[[i]],
result[[++ctr]] = i]];
Take[result, ctr]]];
(* Note: takes some time *)
points = Cases[
Reap[Plot[(Sow[{t, #}]; #) &[ff[t]], {t, 0, 1000},
Frame -> {True, True, False, False},
FrameLabel -> {"t", "Frequency"},
FrameStyle -> Directive[FontSize -> 15], Axes -> False,
PlotPoints -> 50000]][[2, 1]], {_Real, _Real}];
localMins = SortBy[Nest[#[[ localMinPositionsC[#[[All, 2]]]]] &, points, 2], First];
env = ListPlot[localMins, PlotStyle -> {Pink}, Joined -> True];
Show[{plot, env}]
```

What happens is that your oscillatory function has some non-trivial fine structure, and we need a lot of points to resolve it. We collect these points from Plot by Reap - Sow, and then filter out local minima. Because of the fine structure, we need to do it twice. The plot you actually want is stored in "env". As I said, it probably could be tweaked to get a better quality plot if needed.

Edit:

In fact, *much* better plot can be obtained, if we increase the number of PlotPoints from 50000 to 200000, and then repeatedly remove points of local maxima from localMin. Note that it will run slower and require more memory however. Here are the changes:

```
(*Note:takes some time*)
points = Cases[
Reap[Plot[(Sow[{t, #}]; #) &[ff[t]], {t, 0, 1000},
Frame -> {True, True, False, False},
FrameLabel -> {"t", "Frequency"},
FrameStyle -> Directive[FontSize -> 15], Axes -> False,
PlotPoints -> 200000]][[2, 1]], {_Real, _Real}];
localMins = SortBy[Nest[#[[localMinPositionsC[#[[All, 2]]]]] &, points, 2], First];
localMaxPositionsC =
Compile[{{pts, _Real, 1}},
Module[{result = Table[0, {Length[pts]}], i = 1, ctr = 0},
For[i = 2, i < Length[pts], i++,
If[pts[[i - 1]] < pts[[i]] && pts[[i + 1]] < pts[[i]],
result[[++ctr]] = i]];
Take[result, ctr]]];
localMins1 = Nest[Delete[#, List /@ localMaxPositionsC[#[[All, 2]]]] &, localMins, 15];
env = ListPlot[localMins1, PlotStyle -> {Pink}, Joined -> True];
Show[{plot, env}]
```

Edit: here is the plot (done as `GraphicsGrid[{{env}, {Show[{plot, env}]}}]`

)

I don't claim this one neither robust nor general. But it's quick and fun. It uses Image Transformations to find the edges (possible because the heavy oscillatory character of your function):

Function:

```
envelope[plot_] := Module[{boundary, Pr, rescaled},
(* "rasterize" the plot, identify the lower edge and isolate pixels*)
boundary = Transpose@ImageData@Binarize@plot /. {x___, 0, 1, y___} :>
Join[Array[1 &, Length[{x}]], {0}, Array[1 &, Length[{y}] + 1]];
(* and now rescale *)
Pr = PlotRange /. Options[plot, PlotRange];
rescaled = Position[boundary, 0] /.
{x_, y_} :> {
Rescale[x, {1, Dimensions[boundary][[1]]}, Pr[[1]]],
Rescale[y, {1, Dimensions[boundary][[2]]}, Reverse[Pr[[2]]]]
};
(* Finally, return a rescaled and slightly smoothed plot *)
Return[ListLinePlot@
Transpose@{( Transpose[rescaled][[1]])[[1 ;; -2]],
MovingAverage[Transpose[rescaled][[2]], 2]}]
]
```

Testing code:

```
tk0 = phi'[t] phi'[t] - phi[t] phi''[t];
tk1 = phi''[t] phi''[t] - phi'[t] phi'''[t];
a = tk0/Sqrt[tk1];
f = Sqrt[tk1/tk0];
s = NDSolve[{
phi''[t] + phi[t] - 0.167 phi[t]^3 ==
0.005 Cos[t - 0.5*0.00009*t^2],
phi[0] == 0,
phi'[0] == 0},
phi, {t, 0, 1000}];
plot = Plot[Evaluate[f /. s], {t, 0, 1000}, Axes -> False];
Show[envelope[plot]]
```

**Edit**

Fixing a bug in the code above, the results are more accurate:

```
envelope[plot_] := Module[{boundary, Pr, rescaled},
(*"rasterize" the plot,
identify the lower edge and isolate pixels*)
boundary =
Transpose@ImageData@Binarize@plot /. {x___, 0, 1, y___} :>
Join[Array[1 &, Length[{x}]], {0}, Array[1 &, Length[{y}] + 1]];
(*and now rescale*)
Pr = PlotRange /. Options[plot, PlotRange];
rescaled = Position[boundary, 0] /. {x_, y_} :>
{Rescale[
x, {(Min /@ Transpose@Position[boundary, 0])[[1]], (Max /@
Transpose@Position[boundary, 0])[[1]]}, Pr[[1]]],
Rescale[y, {(Min /@
Transpose@Position[boundary, 0])[[2]], (Max /@
Transpose@Position[boundary, 0])[[2]]}, Reverse[Pr[[2]]]]};
(*Finally,return a rescaled and slightly smoothed plot*)
Return[ListLinePlot[
Transpose@{(Transpose[rescaled][[1]])[[1 ;; -2]],
MovingAverage[Transpose[rescaled][[2]], 2]},
PlotStyle -> {Thickness[0.01]}]]]
```

. .

Similar Questions

I Cannot find how to use relative paths in mathematica. My directory structure is simple. Import[G:\\Research\\Acc and Vel Runs\\5-24\\Mathematica\\Data\\250 \ Acc.xls][[1]] // TableForm That Demon

I am working on understanding how SOAP services work.My client is in Java and the service is using WCF (although in theory this shouldn't matter). If I am given an example of a SOAP envelope and do th

After using loess.smooth function in R on bootstrapped data, the bootstrapped dataset (n = 134560) reduced to (n = 50) observations. is there any way to replicate this effect in SAS? I am not very muc

Is mathematica a functional programming language? what i intend to ask his that i keep reading that mathematica is a conditional rewrite system. I want to know what is this conditional rewrite system?

I have some vectors of experimental data that I need to massage, for example: { {0, 61237, 131895, 194760, 249935}, {0, 61939, 133775, 197516, 251018}, {0, 60919, 131391, 194112, 231930}, {0, 60735, 1

I would like to know how to exchange data between Mathematica and a C/C++ with pipes. In the Mathematica tutorial it says that when you open a file or a pipe, Mathematica creates a 'stream object' th

I am trying to smoothen my hand drawn Bezier curves, but not able to achieve, it, I got the code of smoothing the curve from the book written by erica sudan , which I tried to implement , but dont kno

This question started me thinking about how Mathematica detects multiple functions being plotted. I find that I really do not understand the process. Consider: Plot[{1, Sequence[2, 3], 4}, {x, 0, 1},

I need to perform image smoothing. I've searched the web but I didn't find anything - every thing I tried doesn't preform like I want. for example: as you see there are bumps or something like stair

I'm trying to create a collision detection method that checks if two of my objects (2 oval shaped uiimages) collide with each other. if they do it should set the BOOL value to YES otherwise it should

I'm wanting to print a standard sized envelope from a webpage using c#. Does anyone know how to do something like this? I would load the data from the system for the address and pass it. I just need t

I have a question regarding Mathematica's global optimization capability. I came across this text related to the NAG toolbox (kind of white paper). Now I tried to solve the test case from the paper. A

Hey, I have this little equation that I am trying to solve on Mathematica, but for some reason I cannot get it to work. Any help would be appreciated. Thanks f[x_, t_] = x^2 - x^3; eso = x[t] /. DSolv

Which set is more random? Math.random() for Java or random for Mathematica? Java is in blue, Mathematica in red. numbers are from 0 to 50 (51?) EDIT: It's a histogram generated in Mathematica. Java

What's the best/easiest way to shuffle a long list in Mathematica?

I am interested in finding an antialiasing algorithm which can be used on a line of any shape (not just straight lines). I notice that Mathematica seems to have a very good algorithm and can draw fine

Given a table where the first column is seconds past a certain reference point and the second one is an arbitrary measurement: 6 0.738158581 21 0.801697222 39 1.797224596 49 2.77920469 54 2.839757536

I have a very large table of data something like: lista = {{2,8},{3,4},{5,2}..} I would like to add x to every element so it would be lista ={{x,2,8},{x,3,4},{x,5,2}.....} This seems to me like it sho

I am currently attempting to run a loop in Mathematica which will attempt to insert in position {i,4} of the date list the day of the week. For some reason i can't get dayint to increase when date[[i,

I remember that someone from WRI stated in the official newsgroup that Mathematica 7 still has a working old-fashioned Mathematica Help Browser from Mathematica 5 for compatibility purposes. But I can

I've got problems in using Mathematica with complex numbers. Am I doing something wrong? Two examples: ComplexExpand[(x + I y)^(1/2)] yields (x^2 + y^2)^(1/4) Cos[1/2 Arg[x + I y]] + I (x^2 + y^2)^(1

I could not understand how contour detection algorithm works on a 2D graph generally. Do the Contour detection algorithms check all points in the space to find each contour line? Can someone explain i

Could you please give me a hint how can I invoke a java project (written in eclipse) from Mathematica? I want to give values generated by my Mathematica program as input to a java project, and use the

Does anybody know if there is a built-in function in Mathematica for getting the lhs of downvalue rules (without any holding)? I know how to write the code to do it, but it seems basic enough for a bu

I have a lot of files. Every of which contains data. I can happy import one file to Mathematica. But there are more than 500 hundreds of files. I do it so: Import[~/math/third_ks/mixed_matrices/1.da

I am new to Mathematica and currently working with time series data. I have the following input data in Mathematica 9.0 data = {{{2011, 3, 13}, 10}, {{2011, 3, 14}, NA}, {{2011, 3, 15}, 20}, {{2011,

I have written a package for Mathematica called MathOO. In short, it allows you to use object orientation in Mathematica just like you do in Python. Please read the following article in Voofie/MathOO

How can I implement the normal reduction strategy for Combinators {S,K,I} in Mathematica? Here are the rules: S[x][y][z]->x[y][z[y]] K[x][y][z]->x Also we have an Y combinator ( fixed point) thu

I am working on speech signal with envelope extraction. I use the standard deviation (std) at each point of the envelope value. However, the std value changes when I amplify the speech. What is the lo

I have some fluorescence spectrometry data that has rather 'spiky' and hard-to-visualise lines on my ggplot graph. I've decided that using ggplot's smoothing function tidies up my data quite nicely, h

To get acquainted with Mathematica's solving functions, I tried to work out a solution to a MinuteMath problem: There is a list of seven numbers. The average of the first four numbers is 5, and the a

I'm puzzled by this behavior of mathematica. The two following expressions should return the same result: Simplify[(1 - w)^2 Sum[w^(k+kp) Sum[If[l == lp, 1, 0], {l, 0, k}, {lp, 0, kp}], {k,0, \[Infini

Using SoapUI I have built the following XML envelope and encapsulated it in a String. ProcessJournal is a method which has no parameters, and returns a string. String soapText = <Envelope xmlns:so

I wonder if there exists way to work with large files in Mathematica ? Currently I have a file about 500Mb with table data. Import[data.txt,Table]; What is alternate way?

I have a RPC encoded PHP webservice that returns a simple soap envelope with a boolean datatype. When doing the trace on the client side, the soap envelope looks like this right before it goes into th

I am evaluating Wolfram Mathematica 8 for a university course project. I am having difficulties to define a Goal Programming model. First because I am really scarce in math :) Second, because what I

I want to use the Manipulate function in Mathematica to fit an analytical function to a set of (x,y) data. I want to plot the dataset on the same axes that I use to manipulate the function (so I can g

Is there any way to send a Soap envelope using Groovy

I'm trying to make smoothing for images which loaded with loadclip(). I found function for smoothing and it works but only for movieclips located in _level0, for example _level0.mc, but I want to smoo

how can i write this command from mathematica to matlab? total = Apply[Plus, Flatten[mlat]]/L2 ,where L2 is a value and mlat a matrix.

I recently found out about Kleene algebra for manipulating and simplifying regular expressions. I'm wondering if this has been build into any computational software programs like Mathematica? It would

Is there any reason not to use font-smoothing: antialiased?

I have a question about using plot and disk together in one manipulate function in mathematica. I have this piece of code right now: Plot[h[t], {t, 0, ttot}, PlotRange -> {0, 30}] Manipulate[ Plot[

Is there a way to separate open Mathematica notebooks so that they don't share any variables? How about making it so some variables are shared but not all?

I am trying to plot multiple lists in the same plot in Mathematica (ListLinePlot) and use PlotMarkers and the PlotLegend Package to get the final figure. The issue is that Mathematica puts a marker fo

I'm a beginner in Mathematica programming. My code is not running as expected. I wonder if anyone could examine what goes wrong? Here is part of the code. F[{k_, n_, x_}] = Which[k == 0, f[a, b, x], k

In mathematica (I am using mma 5.0 ( guess pretty old)), if I type the following as one line: Needs[Graphics`Master`]; Animate[Plot[Sin[n x], {x, 0, 2 Pi}, Axes -> False], {n, 1, 6, 1}] I then g

I'm trying to write a ridge detection algorithm, and all of the sources I've found seem to conflate edge detection with ridge detection. Right now, I've implemented the Canny edge detection algorithm,

I want to send an envelope with an empty body like this: <v:Envelope xmlns:i=http://www.w3.org/2001/XMLSchema-instance xmlns:d=http://www.w3.org/2001/XMLSchema xmlns:c=http://schemas.xmlsoap.

how can I disable the font smoothing in the text editor of Visul Studio? On some machines I use this works but not in most of them. The text in the editor on the left is not really sharp. But the font