mathematica envelope detection data smoothing

Question

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 appre

Answer 1

An Image based solution

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]}]]]

. .