24
$\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

Improve this question
$\endgroup$
4
  • 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, 2015 at 14:26
  • 1
    $\begingroup$ Check out MaxFilter. $\endgroup$
    – N.J.Evans
    Sep 16, 2015 at 15:24
  • 1
    $\begingroup$ Use ConvexHull[] on the reciprocals. $\endgroup$
    – Eric Towers
    Sep 16, 2015 at 18:20
  • $\begingroup$ @EricTowers This will work for a convex envelope like this, but not in general. $\endgroup$
    – Igor Rivin
    Sep 16, 2015 at 18:21

4 Answers 4

Reset to default
30
$\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.

Improve this answer
$\endgroup$
2
  • $\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, 2015 at 17:11
  • 9
    $\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, 2015 at 17:20
28
$\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.)

Improve this answer
$\endgroup$
9
$\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

Improve this answer
$\endgroup$
1
  • $\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, 2016 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

Improve this answer
$\endgroup$
2
  • $\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, 2016 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, 2016 at 22:34

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.