Replace elements in list larger than x times the magnitude of the previous value with the mean of its neighbours

Question

Say I have some list a. It is an increasing, noisy dataset; something like $a x + X$ where $X$ is a noisy variable. This is as expected from what I'm interested in. However, once every so often my dataset has an extreme ourlier: if we take a zoom in of the list, a = {1,1.2,1.4,1.1,0.9,4,0.9,1.1}, we see that there is suddenly a 4, which is unphysical in my situation. I know what's causing this issue, but I can't really get rid of it before post processing, so I will have to handle it this way.

In any case, what I'm looking for is a command that I could use to replace this 4, or more generally, every value $a_i > b a_{i-1}$ for some parameter $b$ that I can set. Moreover, I'd like the replacement to be such that $a_i = \frac{a_{i-1}+a_{i+1}}{2}$; I want to replace the point by the mean of its neighbours.

Now, I'm thinking this probably starts with something like creating a list of the fractions, where I divide each element by the value of the previous one. Then the comparison has to be made, and then the replacement. But to be honest I'm not quite sure of the most efficient way to tackle this.

Edit: as pointed out in the comments, the boundaries can be tricky. To keep it simple I'd just assume that they are not the problematic points and leave them as they are.

Answer 1

f[a_List, threshold_] := {First@a}~Join~
  Developer`PartitionMap[
   If[#[[2]] > #[[1]]*threshold, Mean@Drop[#, {2}], #[[2]]] &, a, 3, 1]~Join~{Last@a}

f[a, 2]

{1, 1.2, 1.4, 1.1, 0.9, 0.9, 0.9, 1.1}

Employs the criterion $If[a_i>ba_{i-1},....]$, where threshold is the $b$.

Answer 2

If you have a lot of data to process I propose a vectorized numeric approach for efficiency.

fn[dat_List, b_?NumericQ] :=
 Module[{Δ, m, d2 = Developer`ToPackedArray[dat, Real]},
    Δ = UnitStep[Differences[d2] - b] ~Prepend~ 0;
    m = ListCorrelate[{1/2, 0, 1/2}, d2, 2];
    Δ*m + (1 - Δ) d2
  ]

Example:

fn[{1, 1.2, 1.4, 1.1, 0.9, 4, 0.9, 1.1}, 1]

{1., 1.2, 1.4, 1.1, 0.9, 0.9, 0.9, 1.1}

Answer 3

You may use FindPeaks to refine your peak criteria then assign the Mean to these positions while using Nothing for the indices exceeding the boundaries.

With

dat = {1, 1.2, 1.4, 1.1, 0.9, 4, 0.9, 1.1};

Then

(dat[[#]] = 
     Mean[dat[[{# - 1 /. {0 -> Nothing}, # + 1 /. Length@dat + 1 -> Nothing}]]]) & /@ 
  FindPeaks[dat, 2][[All, 1]];

Gives

dat

{1, 1.2, 1.4, 1.1, 0.9, 0.9, 0.9, 1.1}

You may also find the Linear and Nonlinear Filters guide of interest.

Hope this helps.

Answer 4

Edit to add a bit more explanation and fix error in Mean

I would suggest using Partition to get the sublists, then Map or Apply to do the test then recalculate the value:

test[in_List, n_] := If[
  in[[2]] > n*in[[1]], 
  Mean[{in[[1]], in[[3]]}],
  in[[2]]
];

recalculate[a_, n_] := Join[
 {First[a]}, 
  test[#, n] & /@ Partition[a, 3, 1], 
  {Last[a]}
];

recalculate[a, 2]
(*{1.2, 1.4, 1.1, 0.9, 0.9, 0.9, 0.9, 1.1, 1.1}*)

I just left the values at the beginning and end, but you could use that If statement to also process them if you like. The shorthands here are:

# and & are a Pure function - see here for more details

@@@ is Apply at level one, so it treats each sublist as the inputs to the pure function

Alternatively using PartitionMap:

<< Developer`
recalculate[a_, n_] := Join[{First[a]}, PartitionMap[test[#, n] &, a, 3, 1], {Last[a]}];

recalculate[a, 2]
(*{1.2, 1.4, 1.1, 0.9, 0.9, 0.9, 0.9, 1.1, 1.1}*)

Answer 5

f1 = With[{x = #, y = MeanFilter[#, 1] - #, u = Prepend[UnitStep[Rest@# - #2 Most@#], 0]},
          x + (3/2) u y] &;

f1[a, 2]

{1., 1.2, 1.4, 1.1, 0.9, 0.9, 0.9, 1.1}