Mathematica envelope for the bottom of a plot, a generic function

Question

I have the following set-up:

xaxis = Table[x, {x, 0, 10, 0.01}];

yaxis = Table [Sin[x] + Abs[RandomReal[{-1, 1}]], {x, 0, 10, 0.01}];

ListLinePlot[Transpose[{ xaxis, yaxis}]]

My questions is how can I make a line that very simply envelopes the function coming up from the bottom. The envelope coming up from the bottom should be jagged such that it is a tight-fit (or overfitted). Perhaps this could be controlled by some sort of smoothing parameter where 1: very jagged, 10: very smooth.

The figure below shows a plot generated from the underlying function itself which obviously results in a very smooth fit.

Answer 1

You can also create a moving min (and max) and use BSplineCurve to render a smoothed curve.

These could be made more efficient. They find the min and max over a window.

windowMin[data_, w_][pt_] := {pt, 
  Min[Cases[data, {x_, y_} /; pt - w <= x <= pt + w][[All, 2]]]}

windowMax[data_, w_][pt_] := {pt, 
  Max[Cases[data, {x_, y_} /; pt - w <= x <= pt + w][[All, 2]]]}

This function plots the original data with the BSplineCurve envelope. The parameter w sets the window width.

f[w_] := With[{data = Transpose[{xaxis, yaxis}]}, 
  Show[ListLinePlot[data, 
    PlotStyle -> Directive[{Blue, Opacity[.2]}]], 
   With[{pts = Table[windowMin[data, w][t], {t, 0, 10, w - w/10}]}, 
    Graphics[{Red, BSplineCurve[pts]}]], 
   With[{pts = Table[windowMax[data, w][t], {t, 0, 10, w - w/10}]}, 
    Graphics[{Red, BSplineCurve[pts]}]]]]

Some examples...

f[.2]

f[.1]

f[.025]

Edit: In response to the comment, here is a more general form of f which allows for a list of xdata and a list of ydata provided they are of equal length. The min and max of the Tables are chosen to be the range of the x data.

f[xdata_, ydata_, w_] /; Length[xdata] == Length[ydata] := 
 Block[{data = Transpose[{xdata, ydata}], xmin = Min[xdata], 
   xmax = Max[xdata]}, 
  Show[ListLinePlot[data, 
    PlotStyle -> Directive[{Blue, Opacity[.2]}]], 
   With[{pts = 
      Table[windowMin[data, w][t], {t, xmin, xmax, 
        w - w/(xmax - xmin)}]}, Graphics[{Red, BSplineCurve[pts]}]], 
   With[{pts = 
      Table[windowMax[data, w][t], {t, xmin, xmax, 
        w - w/(xmax - xmin)}]}, Graphics[{Red, BSplineCurve[pts]}]]]]

Answer 2

One possibility is going through the data with a window, and selecting the minimum or maximum value. I'm showing code only for the case where the points are equally spaced along the $x$ axis:

Manipulate[
 ListLinePlot[
  {data,
   {Mean[#[[All, 1]]], Min[#[[All, 2]]]} & /@ 
    Partition[data, window, 
     1], {Mean[#[[All, 1]]], Max[#[[All, 2]]]} & /@ 
    Partition[data, window, 1], Mean /@ Partition[data, window, 1]},
  PlotStyle -> {Thin, Thick, Thick, Thick}],
 {window, 1, 100, 1}]

Another possibility is selecting the actual minimum/maximum points instead of taking the average for the $x$ coordinate:

MaxBy[list_, fun_] := list[[First@Ordering[fun /@ list, -1]]]
MinBy[list_, fun_] := list[[First@Ordering[fun /@ list, 1]]]

Manipulate[
 ListLinePlot[
  {data,
   MaxBy[#, Last] & /@ Partition[data, window, 1], 
   MinBy[#, Last] & /@ Partition[data, window, 1], 
   Mean /@ Partition[data, window, 1]},
  PlotStyle -> {Thin, Thick, Thick, Thick}],
 {window, 1, 100, 1}]

Answer 3

Here is a method you may be able to use.

The first part plots the lower 1.4 standard deviation over a moving average, and the second part makes a polynomical fit.

xaxis = Table[x, {x, 0, 10, 0.01}];
yaxis = Table[Sin[x] + Abs[RandomReal[{-1, 1}]], {x, 0, 10, 0.01}];
plot = ListLinePlot[Transpose[{xaxis, yaxis}]];
n = 100;
part = Partition[Transpose[{xaxis, yaxis}], n, 1];
dNeg[x_List] := {Mean[x[[All, 1]]],
   Mean[#] - 1.4*StandardDeviation[#] &@x[[All, 2]]};
d = dNeg /@ part;
env = ListLinePlot[d];
Show[{plot, env}]

d2 = Fit[d, {1, x, x^2, x^3, x^4, x^5, x^6}, x];
Show[{plot, Plot[d2, {x, d[[1, 1]], d[[-1, 1]]}]}]

Answer 4

Given enough time, they will take all the fun tasks and make built-in functions out of them. To that end, we can use EstimatedBackground to easily find the envelope on either side of this noisy data:

Manipulate[
 ListLinePlot[{yaxis,
   EstimatedBackground[yaxis, y],
   -EstimatedBackground[-yaxis, y]},
  DataRange -> MinMax@xaxis],
 {y, 1, 20, .1, Appearance -> "Open"}]

Answer 5

If the data is equally distributed, use MaxFilter and MinFilter. Compared to Andy's answer it is much faster. I always try to avoid Cases as it is very slow. Apart from that is does essentially the same thing, with the difference that the radius window is given in data points rather than a radius given by the $x$-axis.