Cleaning away data points which are enveloped within a function

Question

I have some data taken in an experiment which I want to fit and analyse. But before I start fitting function, I want to clean points away in a robust but elegant way.

I first provide some sample data (apologies, the data before had the trailing digits hidden so when copying from M, it turned all the $y$-values constant, this is now fixed):

SampleData = {{43.10530996322632`, 2.9610372883599`*^7}, {86.2056188583374`, 
  2.9610373000033`*^7}, {129.31993007659912`, 
  2.9610373037403`*^7}, {172.42124128341675`, 
  2.9610373115104`*^7}, {215.53155136108398`, 
  2.9610373218762`*^7}, {258.6408619880676`, 
  2.9610373315972`*^7}, {301.7471733093262`, 
  2.9610373389542`*^7}, {344.8574833869934`, 
  2.9610373468751`*^7}, {387.9627933502197`, 
  2.9610373547716`*^7}, {431.06610345840454`, 
  2.9610373593744`*^7}, {474.1744132041931`, 
  2.9610373624969`*^7}, {517.2807245254517`, 
  2.9610373656209`*^7}, {560.388035774231`, 
  2.9610373672456`*^7}, {603.4873456954956`, 
  2.9610373687505`*^7}, {646.5896544456482`, 
  2.9610373718757`*^7}, {689.6949653625488`, 
  2.9610373718734`*^7}, {732.8042755126953`, 
  2.9610373718761`*^7}, {775.9205865859985`, 
  2.961037377287`*^7}, {819.0348963737488`, 
  2.9610373843758`*^7}, {862.1362056732178`, 
  2.9610373875002`*^7}, {905.2375154495239`, 
  2.9610373906252`*^7}, {948.3458256721497`, 
  2.9610373906256`*^7}, {991.4481363296509`, 
  2.9610373888359`*^7}, {1034.556447505951`, 
  2.9610373894297`*^7}, {1077.656756401062`, 
  2.9610373111623`*^7}, {1120.7750673294067`, 
  2.9610373944853`*^7}, {1163.8853783607483`, 
  2.9610373930747`*^7}, {1206.9916882514954`, 
  2.9610373937476`*^7}, {1250.1079993247986`, 
  2.9610373968739`*^7}, {1293.2153091430664`, 
  2.9610373999998`*^7}, {1336.3306202888489`, 
  2.9610374047823`*^7}, {1379.4399313926697`, 
  2.9610374078782`*^7}, {1465.656551361084`, 2.9610374093756`*^7}}

If I plot this data with Show[ListPlot[SampleData], Frame -> True, AspectRatio -> 1, PlotRange -> {All, {Min[SampleData[[1 ;;, 2]]], Max[SampleData[[1 ;;, 2]]]}}] then we see:

Circled in red, we can see a point which doesn't fit the trend and I want to clean it away. Just for additional information the trend is described by $y(t) = a (1 - b e^{t / \tau})$.

Because the point is within the bounds of the function, I'm struggling to think of an appropriate method to clean such points away. When the bad points are above or below the maximum and minimum values (when sitting on the function I referenced) it's easy I can just select all points within a threshold. I could use the point-to-point jitter to clean but if I have to subsequent bad points near each other this also won't help, and again for points within the function envelope there is no way to distinguish them

I have hundreds of this sets to clean and fit, so a robust approach to cleaning data would be best -- if anyone has any ideas I'd be very grateful

Answer 1

Update with the new, corrected data

(For more details see the section with my first answer below...)

With the new, corrected data (SampleData) in order to get good results I had to change the interpolation order and use special visualization with Show (as it is done in the question).

cleanData =
  QRMonUnit[SampleData]⟹
   QRMonQuantileRegression[6, 0.5, InterpolationOrder -> 2, Method -> {LinearProgramming, Method -> "InteriorPoint", Tolerance -> 10^(-3)}]⟹
   QRMonFit[8]⟹
   QRMonPlot["Echo" -> False]⟹
   QRMonEchoFunctionValue[Show[#, PlotRange -> {All, MinMax[SampleData[[All, 2]]]}] &]⟹
   QRMonErrorPlots["RelativeErrors" -> False, PlotRange -> All]⟹
   QRMonPickPathPoints[0.12]⟹
   QRMonTakeValue;

cleanData = cleanData[0.5];

Show[#, PlotRange -> {All, MinMax[SampleData[[All, 2]]]}] &@
 ListPlot[{SampleData, cleanData}, 
  PlotStyle -> {{PointSize[0.03], Pink}, Blue}, 
  PlotLegends -> {"data", "clean data"}, PlotRange -> All, 
  PlotTheme -> "Scientific"]

Also, note the difference of the magnitudes of the fit errors for the two datasets.

First answer

Import the QRMon package:

Import["https://raw.githubusercontent.com/antononcube/\
MathematicaForPrediction/master/MonadicProgramming/MonadicQuantileRegression.m"]

Assign data (the data in the question has constant y-values):

data =
{{1387.5, 2.665*^7}, {1302.5, 2.635*^7}, {1222.5, 2.455*^7}, {1182.5, 2.385*^7}, 
 {1142.5, 2.315*^7}, {1097.5, 2.305*^7}, {852.5, 2.245*^7}, {897.5, 2.245*^7}, 
 {977.5, 2.225*^7}, {937.5, 2.205*^7}, {812.5, 2.175*^7}, {732.5, 1.955*^7}, 
 {652.5, 1.835*^7}, {692.5, 1.835*^7}, {567.5, 1.765*^7}, {527.5, 1.725*^7}, 
 {447.5, 1.625*^7}, {362.5, 1.455*^7}, {322.5, 1.275*^7}, {282.5, 1.095*^7}, 
 {242.5, 9.35*^6}, {202.5, 7.15*^6}, {157.5, 4.85*^6}, 
 {1017.9003407155026, 4.79701873935264*^6}, {77.5, 1.55*^6}};

Apply Quantile Regression, find and plot the fit errors, pick points close to fitted curve by using an appropriate threshold.

cleanData =
  QRMonUnit[data]y⟹
   QRMonQuantileRegression[12, 0.5, Method -> {LinearProgramming, Method -> "InteriorPoint", Tolerance -> 10^(-3)}]⟹
   QRMonPloty⟹
   QRMonErrorPlots["RelativeErrors" -> False]⟹
   QRMonPickPathPoints[10^6]⟹
   QRMonTakeValue;

Obtain the clean data from the monad application result and plot it together with the original data. (The outlier point is not in the clean data.)

cleanData = First[Values[cleanData]];

ListPlot[{data, cleanData}, PlotStyle -> {{PointSize[0.03], Pink}, Blue}, 
 PlotLegends -> {"data", "clean data"}, PlotRange -> All, PlotTheme -> "Scientific"]