5
$\begingroup$

Can Mathematica be used to create a ListPlot with the feature shown below; a line around the cloud of points?

I am not entirely sure what rule would create the desired effect (i.e., what points actually make up the red-lined circumference), but I guess the line should be drawn such that no point is "outside". On the other hand, that leaves quite some room.

The data is available at the link below:

Data

Data available here

Improve this question
$\endgroup$
5
  • 1
    $\begingroup$ Certainly, if you define how the line should be drawn. For instance, you could consider perhaps adding the convex hull of those points (see ConvexHullMesh). $\endgroup$
    – MarcoB
    Nov 17, 2019 at 20:17
  • $\begingroup$ @MarcoB It appears that ConvexHullMesh will draw a line from {0,0.1} to {1,0.14} in the diagram above. Is there some other know algorithm? Perhaps like ConvexHullMesh, with a further restiction of minimizing the enclosed area. $\endgroup$
    – user120911
    Nov 17, 2019 at 20:40
  • $\begingroup$ You may want a concave hull then. That's not as straightforward, but it has been done before in the linked post and elsewhere. $\endgroup$
    – MarcoB
    Nov 17, 2019 at 20:42
  • 1
    $\begingroup$ If you could post the points for people to play with, you would be certain to attract a lot more help. People need to be able to test their suggestions on your real problem. $\endgroup$
    – MarcoB
    Nov 17, 2019 at 20:44
  • $\begingroup$ @MarcoB I have added a link to the data. $\endgroup$
    – user120911
    Nov 17, 2019 at 20:58

2 Answers 2

Reset to default
10
$\begingroup$

This question is strongly related to the question upper envelope of data. This question is, essentially, how to find the upper and lower envelope of a list of points.

Using bill s's answer, one can get something that works fairly well.

Sample data

pts = Transpose[{
    RandomReal[{0, 10 Pi}, 2000],
    RandomReal[{0, 10}, 2000]
    }];
inRegionQ[{x_, y_}] := y > 3 + Sin[x] && y < 5 + Sin[x]
pts = Select[pts, inRegionQ];

plot = Plot[
  {3 + Sin[x], 5 + Sin[x]},
  {x, 0, 10 Pi},
  PlotRange -> {{0, 10 Pi}, {0, 10}},
  Epilog -> {Gray, Point[pts]}
  ]

Mathematica graphics

Solution

sorted = SortBy[pts, First];
xvalues = sorted[[All, 1]];
yvalues = sorted[[All, 2]];
max = Transpose[{xvalues, GaussianFilter[MaxFilter[yvalues, 5], 5]}];
min = Transpose[{xvalues, GaussianFilter[MinFilter[yvalues, 5], 5]}];

ListLinePlot[{min, max}, Epilog -> {Gray, Point[pts]}]

Mathematica graphics

One can play with the parameters to get smoother lines or lines that fit more or less snugly.

Improve this answer
$\endgroup$
2
$\begingroup$

The following seems to have slightly less "wiggle" and doesn't need tuning:

ClearAll[allXValues,minY,maxY,nearestMax,nearestMin]
allXValues = Sort[pts[[;; , 1]]];
{minY, maxY} = MinMax[pts[[;; , -1]]];
nearestMax = {#, First[Nearest[pts, {#, maxY}]][[-1]]} & /@ 
  allXValues;
nearestMin = 
  {#, First[Nearest[pts, {#, minY}]][[-1]]} & /@ 
    allXValues;
ListLinePlot[{nearestMax, nearestMin}, Epilog -> {Gray, Point[pts]}]

enter image description here

I wish that it did a better job of the lower envelope for rising data. Probably using a local minimum rather than the global minimum would help.

Improve this answer
$\endgroup$

Your Answer

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

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