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

4 Answers 4

Reset to default
33
$\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$ Commented 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$ Commented Sep 16, 2015 at 17:20
29
$\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$
10
$\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$ Commented May 25, 2016 at 22:59
6
$\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$ Commented 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$ Commented May 25, 2016 at 22:34

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.