Noise filtering of observation data

Question

I have a set of observation data {x,y} and need to make some statistical analysis. I made a density plot as follows and the blue line is the best fit of the data.

However, it seems that the blue line does not fit to the data very much. I wonder it may be affected by some noisy data (those with little counts).

Is it possible to filter the data with little counts (i.e. the data over purple area) before making the plot and best fit?

Many thank in advance!!

Answer 1

2D envelopes

One approach to get what OP wants is described in the posts

• "FInding outliers in multiple dimensions" (MSE), and

• "Finding outliers in 2D and 3D numerical data" (WordPress).

Here is code following the latter post.

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/QuantileRegression.m"]

data = Import["~/data.txt", "CSV"];

Histogram3D[data]

Find a threshold for what are considered outliers:

qreg = QuantileEnvelopeRegion[data, 0.98, 20];   
Show[{Graphics[{Opacity[0.02], Point[data]}, PlotRange -> All],
   BoundaryDiscretizeRegion[qreg], 
  Graphics[{Opacity[0.02], Red, Point[data]}]}, Frame -> True, 
 ImageSize -> 500]

Next we separate the outlier points from the rest:

rmFunc = RegionMember[qreg];

AbsoluteTiming[pred = rmFunc /@ data;]

(* {3.89161, Null} *)

Tally[pred]

(* {{True, 91123}, {False, 13330}} *)

Graphics[{Gray, Point[Pick[data, pred]], Red, 
  Point[Pick[data, Not /@ pred]]}, Frame -> True, ImageSize -> 500]

Note that some high count points are considered outliers. A more faithful algorithm can be devised using Quantile Regression.

Quantile regression

First we reverse a 10% sample of the data:

data2 = Map[Reverse, RandomSample[data, 10000]];

Next we select outlier thresholds and find regression quantiles:

qs = {0.1, 0.9};
AbsoluteTiming[
 qFuncs = QuantileRegression[data2, 20, qs];
 ]

(* {24.8839, Null} *)

Plot the transposed data sample and the found regression quantiles:

Show[{
  Graphics[{Opacity[0.2], Pink, Point[data2]}, PlotRange -> All],
  ListLinePlot[
   Table[{#, rq[#]} & /@ Sort[data2[[All, 1]]], {rq, qFuncs}], 
   PlotLegends -> qs]
  }, Frame -> True]

As in the 2D envelope procedure above, find the separation predicate:

AbsoluteTiming[
 pred2 = Map[#[[2]] >= qFuncs[[1]][#[[1]]] && #[[2]] <= 
       qFuncs[[2]][#[[1]]] &, Reverse /@ data];
]

(* {23.2092, Null} *)

Tally[pred2]

(* {{True, 83680}, {False, 20773}} *)

Plot the outlier (low counts) points and the rest:

Graphics[{Gray, Point[Pick[data, pred2]], Red, 
  Point[Pick[data, Not /@ pred2]]}, Frame -> True, ImageSize -> 500]