23
$\begingroup$

Here is a ListPlot[] of some data. Clearly, there is a fairly smooth upper envelope - the question is whether there is an nice way of extracting it...

enter image description here

$\endgroup$
  • 1
    $\begingroup$ Why not start with a maximizing over a moving window, and then smooth the result? Also, if you could send the data (or a small subset of it) it would be hlepful $\endgroup$ – yohbs Sep 16 '15 at 14:26
  • 1
    $\begingroup$ Check out MaxFilter. $\endgroup$ – N.J.Evans Sep 16 '15 at 15:24
  • 1
    $\begingroup$ Use ConvexHull[] on the reciprocals. $\endgroup$ – Eric Towers Sep 16 '15 at 18:20
  • $\begingroup$ @EricTowers This will work for a convex envelope like this, but not in general. $\endgroup$ – Igor Rivin Sep 16 '15 at 18:21
29
$\begingroup$

One could imagine a more detailed question (e.g. with data, and a clear statement of whether it is the upper points, or a function, that is wanted).

Here is an approach to this.

First set up an example.

pts = RandomReal[{1, 5}, {10^4, 2}];
pts2 = Select[pts, #[[1]]*#[[2]] <= 5 &];
pts2 // Length
ListPlot[pts2]

enter image description here

We use an internal function to extract the envelope points.

upper = -Internal`ListMin[-pts2];
Length[upper]
ListPlot[upper]

(* Out[212]= 111 *)

enter image description here

Now guess a formula.

FindFormula[upper]

(* Out[209]= 4.92582954108/#1 & *)

More generally if one has in mind say a small set of monomials and wants to find an algebraic relation amongst the points, then there are various fitting functions that can be used.

$\endgroup$
  • $\begingroup$ I am not sure what the significance of "Internal" is. Does it mean that this is something that could change at any moment? $\endgroup$ – Igor Rivin Sep 16 '15 at 17:11
  • 8
    $\begingroup$ In theory yes. In this example, no. It is somethig we have used for the better part of a decade in FrobeniusNumber code and maybe elsewhere. For the life of me I don't know why it has not been promoted to System context. Uses the Bentley-Clarkson-Levine algorithm, by the way. $\endgroup$ – Daniel Lichtblau Sep 16 '15 at 17:20
26
$\begingroup$

This is an almost perfect application for Quantile Regression. (See these blog posts for Quantile Regression implementations and applications in Mathematica.)

Here is some data (as in Daniel Lichtblau's answer):

pts = RandomReal[{1, 5}, {10^4, 2}];
pts2 = Select[pts, #[[1]]*#[[2]] <= 5 &];
pts2 // Length
ListPlot[pts2]

enter image description here

Load the package QuantileRegression.m:

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/QuantileRegression.m"]

Apply Quantile Regression (using a basis of five B-splines of order 3) so that 99% of the points are below the regression quantile curve:

qFunc = QuantileRegression[pts2, 5, {0.99}][[1]];

Plot the result:

Show[{
  ListPlot[pts2],
  Plot[qFunc[x], {x, Min[pts2[[All, 1]]], Max[pts2[[All, 1]]]}, 
   PlotStyle -> Red]}, PlotRange -> All]

enter image description here

Here is how the function looks like:

qFunc[x] // Simplify

enter image description here

Using Quantile Regression also works in more complicated cases:

pts = RandomReal[{0, 3 Pi}, 20000];
pts = Transpose[{pts, RandomReal[{0, 20}, Length[pts]]}];
pts2 = Select[pts, Sin[#[[1]]/2] + 2 + Cos[2*#[[1]]] >= #[[2]] &];
Length[pts2]
ListPlot[pts2, PlotRange -> All]

enter image description here

qFunc = QuantileRegression[pts2, 16, {0.996}][[1]];

Show[{
  ListPlot[pts2],
  Plot[qFunc[x], {x, Min[pts2[[All, 1]]], Max[pts2[[All, 1]]]}, 
   PlotStyle -> Red]}, PlotRange -> All]

enter image description here

(I was not able to obtain good results using Internal`ListMin in this case.)

$\endgroup$
7
$\begingroup$

Since this question has popped up again, here is a way to use MaxFilter followed by smoothing with a GaussianFilter.

pts = RandomReal[{1, 5}, {10^4, 2}];
pts2 = Select[pts, #[[1]]*#[[2]] <= 5 &];
{xs, ys} = Transpose[Sort[pts2, #1[[1]] < #2[[1]] &]];
Show[{ListPlot[pts2], 
  ListLinePlot[Transpose[{xs, GaussianFilter[MaxFilter[ys, 50], 50]}],
    PlotStyle -> Red]}]

enter image description here

$\endgroup$
  • $\begingroup$ Nice and simple (+1). Also, works fairly well for the second dataset in my answer -- see this image. (And it is much faster...) $\endgroup$ – Anton Antonov May 25 '16 at 22:59
5
$\begingroup$

Just for record by a function used in this site rarely:EstimatedBackground

pts = RandomReal[{1, 5}, {10^4, 2}];
pts2 = Select[pts, #[[1]]*#[[2]] <= 5 &];
ListPlot[pts2]

enter image description here

ListLinePlot[-EstimatedBackground[-Reverse@
     SortBy[pts2, Last][[All, 2]]], 
 DataRange -> MinMax[pts2[[All, 1]]], Epilog -> {Red, Point[pts2]}]

enter image description here

$\endgroup$
  • $\begingroup$ Very interesting solution! Unfortunately, does not seem to be working for even slightly different data. E.g. pts2 = Select[pts, #[[1]]*#[[2]] <= 2 &]. $\endgroup$ – Anton Antonov May 25 '16 at 21:59
  • $\begingroup$ @AntonAntonov Thanks for your foresight.The answer's code to should adjust to be-EstimatedBackground[-Reverse@SortBy[pts2,Last][[All,2]],25] to fit your pts2.It seems that I this way is not so good to do this. $\endgroup$ – yode May 25 '16 at 22:34

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.