11
$\begingroup$

I have some noisy data

data = Uncompress[FromCharacterCode[
   Flatten[ImageData[Import["http://i.stack.imgur.com/RZcpj.png"],"Byte"]]]]

Plot looks like this

I was using the guassian filter to fit

There is noise in certain region, it occured because of the overflow and underflow of the mathemtica.

I used GuassianFilter such as

Table[Show[ListPlot[
   Select[
    GaussianFilter[
     Select[data, 0.00005 > # > 10^-8 &], l], 
    0.00005 > # >= 10^-8 &], Frame -> True, Axes -> False, 
   FrameTicks -> None, Joined -> True, PlotStyle -> Red, 
   ImageSize -> 300], ListPlot[data]]
 , {l, 0, 30, 5}]

enter image description here

Above figure shows, filtering the data by increasing the filtering size. As I increase the value of the filter, it change data that I do not want to change the shape of the plot

Any advice for smoothing the data?

Here is another example data2,

data2=Uncompress[FromCharacterCode[
  Flatten[ImageData[Import["http://i.stack.imgur.com/WYcxd.png"],"Byte"]]]]
$\endgroup$
  • $\begingroup$ How about 2nd order polynomial fit? $\endgroup$ – yohbs May 23 '17 at 15:49
10
$\begingroup$

For impulsive noises, you are probably better off with a Median filter than with a Gaussian Filter, since it is better able to remove the effect of outliers.

data = Uncompress[FromCharacterCode[
   Flatten[ImageData[Import["http://i.stack.imgur.com/RZcpj.png"],"Byte"]]]];
smoothed = MedianFilter[data, 5];
Show[ListPlot[data], ListPlot[smoothed, PlotStyle -> Green]]

enter image description here

And here is the same filtering applied to your second data set:

data2 = Uncompress[FromCharacterCode[
   Flatten[ImageData[Import["http://i.stack.imgur.com/WYcxd.png"], "Byte"]]]]; 
Show[ListPlot[data2], ListPlot[MedianFilter[data2, 5], PlotStyle -> Green]]

enter image description here

$\endgroup$
  • $\begingroup$ Thank you! it works much better! $\endgroup$ – Saesun Kim May 24 '17 at 19:57
11
$\begingroup$

This gets the data:

data1 = Get["https://pastebin.com/raw/Z3GGhH2b"];

There are outliers in the data. This can be seen with this command:

qs = Range[0, 0.95, 0.25]~Join~Range[0.95, 1, 0.01];
TableForm[Transpose[{qs, Quantile[Abs[Log10@data1], qs]}]]

enter image description here

Or with this plot:

ListPlot[data1, PlotRange -> All]

enter image description here

This finds the outlier positions:

Import["https://raw.githubusercontent.com/antononcube/\
MathematicaForPrediction/master/OutlierIdentifiers.m"]
olPos = OutlierPosition[data1, SPLUSQuartileIdentifierParameters]

(* {92, 93, 95, 99, 105, 109, 112, 114} *)

Here is the plot of the data without the outliers:

 ListPlot[Delete[data1, List /@ olPos], PlotRange -> All]

enter image description here

We have identified that the outlier presence causes the problems in question. There are three ways to deal with that situation:

  1. ignore the outliers (this answer),

  2. replace the outlier values with average from neighbors (george2079 answer),

  3. use a more robust filter, MedianFilter, (bill s answer).

Below is the modified GaussianFilter plots code in the question over data with ignored outliers. Note that ignoring the outliers is not a simple removal from the original 1D data array. We remove the outliers of the corresponding time series (2D array) and then do the filtering. Also, we have to use TimeSeries in order to make GaussianFilter work over the 2D array.

Block[{data = Transpose[{Range[Length[data1]], data1}]},
 data = Delete[data, List /@ olPos];
 Table[Show[{
    ListPlot[data, PlotTheme -> "Detailed"],
    ListLinePlot[GaussianFilter[TimeSeries[data], l], PlotStyle -> Red]
    }, PlotLabel -> Row[{"l=", l}], ImageSize -> 300], {l, 0, 30, 
   10}]]

enter image description here

$\endgroup$
  • $\begingroup$ Get["https://pastebin.com/raw/Z3GGhH2b"] will get nothing here $\endgroup$ – yode May 23 '17 at 16:19
  • $\begingroup$ @yode I just verified it (still) works for me... $\endgroup$ – Anton Antonov May 23 '17 at 16:30
7
$\begingroup$

One thing to beware of, if you simply delete your outliers you are effectively shifting all of the following data. This may or may not be important obviously depending on what you want to do with the result, and on how many outliers you need to drop.

Here is an approach where we keep the outlier positions and replace the bad values with local averages:

outliers = Flatten[Position[data , x_ /; x >  1 || x < 0]]
(data[[#]] = Mean[Select[data[[# - 3 ;; # + 3]], 0 < # < 1 &]] )  & /@ 
  outliers;
Show[{
  ListPlot[GaussianFilter[data, 3], Joined -> True] , 
  ListPlot[data, PlotStyle -> Red]}]

enter image description here

If you want you can go back and replace the outlier values with the filter data.

data[[outliers]] = GaussianFilter[data, 3][[outliers]] 

Now look at the data we "made up"

Show[{
  ListPlot[GaussianFilter[data, 3], Joined -> True] , 
  ListPlot[data, PlotStyle -> Red]}, 
 Epilog -> {PointSize[0.015], 
   Point[Transpose[{outliers, data[[outliers]]}]]},
  PlotRange -> {{60, 140}, {0, 10^-5}}, AxesOrigin -> {60, 0}]

enter image description here

$\endgroup$
  • $\begingroup$ I changed the code in my answer so the shifting of the data does not happen. I remove the outliers of the corresponding time series (2D array) -- not the original 1D array -- and then I do the filtering. $\endgroup$ – Anton Antonov May 24 '17 at 15:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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