# Automatic data evaluation and elimination

I have an experimental data set:

data1 = {{71.6, 0.41}, {27.2, 4.96}, {59.3, 0.18}, {46.,2.72},
{42.2, 1.06}, {89.1, 3.75}, {88.6, 1.9}, {62.3,1.8},
{35.5,1.84}}


In order to eliminate unrealistic data points step by step automatically, I fit and plot a relation between data in the two columns as below:

Show[{Plot[Evaluate[lm = Fit[Transpose[{dtx = data1[[All, 1]],
dty = data1[[All, 2]]}], {1,x}, x],
{x, mn = Min[dtx, dty], mx = Max[dtx, dty]},
PlotLabels -> "Expressions"],
PlotRange -> {{Min[dtx],Max[dtx]} , {Min[dty], Max[dty]}}],
ListPlot[Transpose[{dtx, dty}],
PlotStyle ->PointSize[.1],
PlotMarkers -> Automatic,
PlotStyle -> Automatic]},
Axes -> True, GridLines -> Automatic, ImageSize -> 600,
LabelStyle -> Medium, Frame -> True,
FrameLabel -> {{"y", ""}, {"x ", ""}}]


The found relation is: $$y = 2.87217 - 0.0138549 x$$

I want to use data x in the first column to calculate value y corresponding to the x and compare to the data in the second column. If the absolute relative difference is greater than 10% or absolute difference is greater than 1.5, I want to remove the abnormal data points (row) then refit again and continue to eliminate again. I don't know how to make it run automatically. It is great if each step I can eliminate 2 data points then refit and re-eliminate again. Please advise me on the code.

• Maybe look up the RANSAC algorithm? Feb 2, 2020 at 20:06
• The data and/or model aren't very good - it looks like all of the points are more than 10% away from the model, so would all be eliminated in the first round. Feb 2, 2020 at 20:47
• @MelaGo, thank you, can you recommend for the first step of the code with the elimination of the first 2 data having the biggest difference?
– Anh
Feb 2, 2020 at 20:51
• @Roman, thank you. Can you recommend a Mathematica code?
– Anh
Feb 2, 2020 at 20:55

### LinearModelFit - Influence Measures

You can use LinearModelFit and make use of the properties "CookDistances", "FitDifferences" or "SingleDeletionVariances" to identify influential observations.

data = {{71.6, 0.41}, {27.2, 4.96}, {59.3, 0.18}, {46., 2.72}, {42.2,
1.06}, {89.1, 3.75}, {88.6, 1.9}, {62.3, 1.8}, {35.5, 1.84}};
lm = LinearModelFit[data, x, x];

threshold = .1;


Two observations in data have "CookDistances" that exceed threshold:

removed = data[[Flatten @ Position[UnitStep[lm["CookDistances"] - threshold ], 1]]]


{{27.2, 4.96}, {89.1, 3.75}}

Row[{ListPlot[data,
PlotStyle -> Directive[PointSize[Medium], Opacity[1, Black]],
Epilog -> {First@Plot[lm[x], {x, 0, 100}], Opacity[.5], Red,
PointSize[Large], Point[removed]},
Frame -> True, ImageSize -> 400, PlotLabel -> lm[x]],
ListPlot[lm["CookDistances"], Frame -> True, PlotRange -> All,
ImageSize -> 400, PlotLabel -> "CookDistances", Filling -> 0]},
Spacer[10]]


Row[ListPlot[lm[#], Frame -> True, PlotRange -> All, ImageSize -> 300,
PlotLabel -> #, Filling -> 0] & /@ {"CookDistances",
"FitDifferences", "SingleDeletionVariances"}, Spacer[10]]


Alternative influence measures:

Row[ListPlot[lm[#], Frame -> True, PlotRange -> All, ImageSize -> 300,
PlotLabel -> #, Filling -> 0] & /@
{"CookDistances", "FitDifferences", "SingleDeletionVariances"}, Spacer[10]]


### Successive removal of influential observations:

A function that removes elements with specified influence measure above the specified threshold:

triM[measure_: "CookDistances", threshold_: .1] := #[[Flatten[
Position[UnitStep[LinearModelFit[#, x, x][measure] - threshold], 0]]]] &

triM["relativeError", threshold_: .1] := #[[Flatten[
Position[UnitStep[LinearModelFit[#, x, x]["FitResiduals"]/#[[All, -1]] -
threshold], 0]]]] &


Use triM with NestWhileList until triM cannot eliminate additional elements or the length of the input data is 3:

remainingData = NestWhileList[triM["relativeError"], data,
(UnsameQ[##] && Length[#2] > 3) &, 2];

fits = LinearModelFit[#, x, x] & /@ remainingData;

Show[Plot[Evaluate[Through[fits[x]]], {x, 20, 100}, Frame -> True,
Axes -> False, ImageSize -> Large, PlotStyle -> {Red, Blue, Green},
PlotLegends -> MapThread[Row[{##}, " :  "] &, {{"step 1", "step 2", "step 3"},
Through[fits[x]]}]],
ListPlot[BlockMap[Apply[Complement], Append[remainingData, {}], 2, 1],
PlotStyle -> Thread[Directive[AbsolutePointSize[7], {Red, Blue, Green}]],
PlotLegends -> {"removed in step 1", "removed in step 2", "remains"},
BaseStyle -> Opacity[1]],
PlotRange -> All]


If we replace triM["relativeError"] with triM[] in the above code to get the results for "CookDistances":

data1 = {{71.6, 0.41}, {27.2, 4.96}, {59.3, 0.18}, {46., 2.72}, {42.2, 1.06}, {89.1, 3.75}, {88.6, 1.9}, {62.3, 1.8}, {35.5, 1.84}}

lm = Fit[data1, {1, x}, x]
(* 2.87217 - 0.0138549 x *)

Show[
ListPlot[data1, PlotStyle -> PointSize[.02], PlotRange -> All],
Plot[lm, {x, 25, 90}],
Axes -> True, GridLines -> Automatic, ImageSize -> 600,
LabelStyle -> Medium, Frame -> True,
FrameLabel -> {{"y", ""}, {"x ", ""}}
]


Using a 10% cutoff will eliminate all of your data in the first round. I'm pretty sure it's not a good idea, but if you relax the threshold to 20%, you can see some iterative point elimination:

olddata = {};
newdata = data1;
While[Length[olddata] != Length[newdata],
{
olddata = newdata;
lm = Fit[olddata, {1, x}, x];
newdata =
Select[data1, Abs[#[[2]] - (lm /. x -> #[[1]])]/#[[2]] < .2 &];
}]


Resulting in

lm
(* 3.60545 - 0.0192488 x *)

newdata
(* {{46., 2.72}, {88.6, 1.9}} *)


Or, to just remove the two points with the largest relative difference from the model:

Calculated y's:

lm = Fit[data1, {1, x}, x];
modely = lm /. x -> data1[[All, 1]]
(* {1.88015, 2.49531, 2.05057, 2.23484, 2.28749, 1.63769, 1.64462, 2.009, 2.38032} *)


Relative difference between experimental and calculated y's:

diffs = Abs[data1[[All, 2]] - modely]/data1[[All, 2]]
(* {3.58574, 0.496913, 10.3921, 0.178368, 1.15801, 0.563282, 0.13441, 0.116114, 0.293651} *)


Keep all but the worst two (this reorders the points):

Sort[Transpose[{data1, diffs}], #1[[2]] > #2[[2]] &][[3 ;;]][[All, 1]]
(* {{42.2, 1.06}, {89.1, 3.75}, {27.2, 4.96}, {35.5, 1.84}, {46., 2.72}, {88.6, 1.9}, {62.3, 1.8}} *)

• Thank you very much
– Anh
Feb 2, 2020 at 22:09

As others have said, the original data is too far off a linear fit to have any points survive your constraint. I think this function will do what you want:

TrimDataWithLinearFit[{data_, relativeAbsDifferenceLimit_,
absoluteDifferenceLimit_}] :=
Block[{linearFit = Fit[data, {1, x}, x], newData},
newData = Append[#, linearFit /. x -> #[[1]]] & /@ data;
{Take[#, 2] & /@
Select[newData, (Abs[#[[2]] - #[[3]]] <
absoluteDifferenceLimit) && (Abs[#[[2]]/#[[3]] - 1] <
relativeAbsDifferenceLimit) &], relativeAbsDifferenceLimit,
absoluteDifferenceLimit}
]


Now we may use this to iterate until the criteria is met (using 20% and 1.5 as the criteria):

NestWhile[TrimDataWithLinearFit, {data1, .2, 1.5}, Equal, 2]


The first value returned is the list that survives repeated applications of the criteria.

EDIT:
I guess I wasn't clear that you have to take the first item from the NetwWhile operation. Here is an example along with a plot:

data2 = NestWhile[TrimDataWithLinearFit, {data1, 0.02, 0.02}, Equal,
2];
linearFit = Fit[data2[[1]], {1, x, x^2, x^3}, x]
(* -8.97342 + 0.314186 x + 0.632409 x^2 - 0.0366662 x^3 *)

Show[ListPlot[data2[[1]], PlotStyle -> PointSize[.02],
PlotRange -> All], Plot[linearFit, {x, 0, 10}], Axes -> True,
GridLines -> Automatic, ImageSize -> 600, LabelStyle -> Medium,
Frame -> True, FrameLabel -> {{"y", ""}, {"x ", ""}}]


• I use the data1={{4.19314, 0.76}, {4.28513, 1.09}, {4.32879, 1.28}, {4.45867, 1.74}, {4.52376, 2.03}, {4.69017, 2.63}, {4.71903, 2.75}, {4.74767, 2.84}, {4.8025, 3.06}} with your code and data2 = NestWhile[TrimDataWithLinearFit, {data1, 0.02, 0.02}, Equal, 2] // Flatten; linearFit = Fit[data2, {1, x, x^2, x^3}, x];; Show[ListPlot[data2, PlotStyle -> PointSize[.02], PlotRange -> All], Plot[linearFit, {x, 0, 10}], Axes -> True, GridLines -> Automatic, ImageSize -> 600, LabelStyle -> Medium, Frame -> True, FrameLabel -> {{"y", ""}, {"x ", ""}}]. Please see error
– Anh
Feb 8, 2020 at 0:41
• When you performed the NestWhile operation, did you take the first element? NestWhile needed the relativeAbsoluteDifferenceLimit and absoluteDifferenceLimit and returns them each time through, so when done, you need to take the first element. Feb 8, 2020 at 6:54