Mdthbs

Update -

Here's probably one of the simplest and fastest solutions (Thanks to answer from G. Grothendieck). Simply knowing whether the value is NA on either side of any NA is sufficient information. Therefore, using lead and lag from dplyr package -

na2zero <- function(x) {

  x[is.na(lag(x, 1, 0)) & is.na(lead(x, 1, 0)) & is.na(x)] <- 0

  x

}



na2zero(x = c(3, 4, NA, NA, NA, 3, 3))

[1]  3  4 NA  0 NA  3  3



na2zero(x = c(3, 4, NA, NA, NA, NA, NA, 3, 3))

[1]  3  4 NA  0  0  0 NA  3  3



na2zero(x = c(3, 4, NA, NA, NA, 3, 3, NA, NA, 1, NA, 0, 0, rep(NA, 4L)))

[1]  3  4 NA  0 NA  3  3 NA NA  1 NA  0  0 NA  0  0 NA

Previous Answer (also fast) -

Here's one way using rle and replace from base R. This method turns every NA, that is not an endpoint in the running length, into a 0 -

na2zero <- function(x) {

  run_lengths <- rle(is.na(x))$lengths

  replace(x, 

    sequence(run_lengths) != 1 &

    sequence(run_lengths) != rep(run_lengths, run_lengths) &

    is.na(x),

  0)

}



na2zero(x = c(3, 4, NA, NA, NA, 3, 3))

[1]  3  4 NA  0 NA  3  3



na2zero(x = c(3, 4, NA, NA, NA, NA, NA, 3, 3))

[1]  3  4 NA  0  0  0 NA  3  3

Updated Benchmarks -

set.seed(2)

x <- c(3, 4, NA, NA, NA, 3, 3)

x <- sample(x, 1e5, T)



microbenchmark(

  Rui(x),

  Shree_old(x), Shree_new(x),

  markus(x),

  IceCreamT(x),

  Uwe1(x), Uwe2(x), Uwe_Reduce(x),

  Grothendieck(x),

  times = 50

)



all.equal(Shree_new(x), Rui(x)) # [1] TRUE

all.equal(Shree_new(x), Shree_old(x)) # [1] TRUE

all.equal(Shree_new(x), markus(x)) # [1] TRUE

all.equal(Shree_new(x), Uwe1(x)) # [1] TRUE

all.equal(Shree_new(x), Uwe2(x)) # [1] TRUE

all.equal(Shree_new(x), Uwe_Reduce(x)) # [1] TRUE

all.equal(Shree_new(x), Grothendieck(x)) # [1] TRUE





Unit: milliseconds

           expr        min         lq        mean     median          uq        max neval

         Rui(x) 286.026540 307.586604  342.620266 318.404731  363.844258  518.03330    50

   Shree_old(x)  51.556489  62.038875   85.348031  65.012384   81.882141  327.57514    50

   Shree_new(x)   3.996918   4.258248   17.210709   6.298946   10.335142  207.14732    50

      markus(x) 853.513854 885.419719 1001.450726 919.930389 1018.353847 1642.25435    50

   IceCreamT(x)  12.162079  13.773873   22.555446  15.021700   21.271498  199.08993    50

        Uwe1(x) 162.536980 183.566490  225.801038 196.882049  269.020395  439.17737    50

        Uwe2(x)  83.582360  93.136277  115.608342  99.165997  115.376903  309.67290    50

  Uwe_Reduce(x)   1.732195   1.871940    4.215195   2.016815    4.842883   25.91542    50

Grothendieck(x) 620.814291 688.107779  767.749387 746.699435  850.442643  982.49094    50

Here's a data.table option

library(data.table)



na0_dt <- function(x){

  replace(x, rowid(r <- rleid(xna <- is.na(x))) > 1 & rev(rowid(rev(r))) > 1 & xna, 0)

}

Benchmark and equality comparison.

x <- c(3, 4, NA, NA, NA, 3, 3)

x <- sample(x, 1e5, T)



all.equal(Rui(x), na0_dt(x))

# [1] TRUE

all.equal(Rui(x), markus(x))

# [1] TRUE

all.equal(Rui(x), Shree(x))

# [1] TRUE

all.equal(Rui(x), Uwe1(x))

# [1] TRUE

all.equal(Rui(x), Uwe2(x))

# [1] TRUE



library(microbenchmark)

microbenchmark(

  Rui(x),

  Shree(x),

  markus(x),

  na0_dt(x),

  Uwe1(x),

  Uwe2(x),

  times = 50

)

# Unit: milliseconds

#       expr       min        lq       mean    median         uq        max neval   cld

#     Rui(x) 262.80052 286.75909  323.24804 300.73305  344.75091  488.45805    50    d 

#   Shree(x)  55.30956  64.63756   82.52067  72.70157   85.11101  367.10743    50  b   

#  markus(x) 807.05592 882.74498 1007.31244 958.71506 1075.13111 1590.34609    50     e

#  na0_dt(x)  14.95426  16.75980   19.37040  18.53108   19.99180   38.43161    50 a    

#    Uwe1(x) 164.20027 178.59412  210.47365 198.76931  224.98389  327.70639    50   c  

#    Uwe2(x)  85.33296  97.42117  110.56380 102.55040  115.19759  192.73526    50  b   

Again with length 1e3

x <- c(3, 4, NA, NA, NA, 3, 3)

x <- sample(x, 1e3, T)



microbenchmark(

  Rui(x),

  Shree(x),

  markus(x),

  na0_dt(x),

  Uwe1(x),

  Uwe2(x),

  times = 50

)

# Unit: microseconds

#       expr      min       lq      mean   median        uq       max neval  cld

#     Rui(x) 2543.180 2668.719 3084.0056 2847.386  3286.566  4820.105    50  bc 

#   Shree(x)  530.462  584.206  651.1348  600.821   653.949  1170.052    50 a   

#  markus(x) 7036.721 7604.517 9467.0319 8507.491 11014.979 24400.421    50    d

#  na0_dt(x) 1008.001 1092.513 1179.9802 1160.001  1247.591  1564.308    50 a   

#    Uwe1(x) 2907.078 3190.976 3773.5566 3424.207  4162.873  9388.723    50   c 

#    Uwe2(x) 2299.489 2566.155 2803.8250 2703.386  2996.104  4038.155    50  b  

Functions from other answers used in this benchmark

Rui <- function(x){

  ave(x, cumsum(abs(c(0, diff(is.na(x))))), FUN = function(y){

    if(anyNA(y)){

      if(length(y) > 2) y[-c(1, length(y))] <- 0

    }

    y

  })

}

Shree <- function(x) {

  run_lengths <- rle(is.na(x))$lengths

  replace(x, 

    sequence(run_lengths) != 1 &

    sequence(run_lengths) != rep(run_lengths, run_lengths) &

    is.na(x),

  0)

}

markus <- function(x, gap = 1) {



  stopifnot(gap >= 0)



  if (gap == 0) {

    x[is.na(x)] <- 0

    x } else {

      grp <- with(rle(is.na(x)), rep(seq_along(lengths), times = lengths))

      tmp <- ave(x, grp, FUN = function(x) pmin(cumsum(is.na(x)), rev(cumsum(is.na(x)))))

      replace(x, tmp > gap, 0)

    }

}

na0_dt <- function(x){

  replace(x, rowid(r <- rleid(xna <- is.na(x))) > 1 & rev(rowid(rev(r))) > 1 & xna, 0)

}

Uwe1 <- function(x){

  data.table(x)[, x := replace(x, which(is.na(x))[-c(1L, .N)], 0), by =.(rleid(is.na(x)))]$x

}

Uwe2 <- function(x){

  x[data.table(x)[, .I[is.na(x)][-c(1L, .N)], by =.(rleid(is.na(x)))]$V1] <- 0

  x

}

For the sake of completeness, here are three other data.table approaches:

x <- c(3, 4, NA, NA, NA, 3, 3, NA, NA, 1, NA, 0, 0, rep(NA, 4L))



library(data.table)

data.table(x)[, x := replace(x, which(is.na(x))[-c(1L, .N)], 0), by =.(rleid(is.na(x)))]$x

[1]  3  4 NA  0 NA  3  3 NA NA  1 NA  0  0 NA  0  0 NA

x[data.table(x)[, .I[is.na(x)][-c(1L, .N)], by =.(rleid(is.na(x)))]$V1] <- 0

x

[1]  3  4 NA  0 NA  3  3 NA NA  1 NA  0  0 NA  0  0 NA

shift() & Reduce()

I was so focused on finding the right way to create groups that I started to think about the straightforward approach rather late. The rule is quite simple:

Replace all NAs by zero which are preceeded and succeeded by another NA.

This can be accomplished by zoo::rollapply() as in G. Grothendieck's answer or by using lag() & lead() like in Shree's latest edit.

However, my own benchmark (not posted here to avoid duplication with Shree' benchmark) shows that data.table::shift() and Reduce() is the fastest method so far.

  isnax <- is.na(x) 

  x[Reduce(`&`, data.table::shift(isnax, -1:1))] <- 0

  x

It is also slightly faster than using lag() & lead() (please, note that this differs from Shree's version as is.na() is only called once):

  isnax <- is.na(x) 

  x[isnax & dplyr::lag(isnax) & dplyr::lead(isnax)] <- 0

  x

Based on the example, I assume what you mean is that if the value is NA and adjacent values in both directions are NA (or in one direction if the value is first or last) then replace the value with 0. Using a centered rolling window of length 3 return TRUE if it is all NA and then replace the TRUE positions with 0. This gives the following one-liner

library(zoo)



replace(x, rollapply(c(TRUE, is.na(x), TRUE), 3, all), 0)

## [1]  3  4 NA  0 NA  3  3

Another base approach

x <- c(3, 4, NA, NA, NA, 3, 3, NA, 3, NA, NA, NA, NA, 1)

Create a grouping variable

grp <- with(rle(is.na(x)), rep(seq_along(lengths), lengths)) # same as rleid(is.na(x))

For each group calculate the parallel minimum of cumsum(is.na(x)) and its reverse (which will be greater than one for values 'which are more than 2 intervals from a valid data point' away)

tmp <- ave(x, grp, FUN = function(x) pmin(cumsum(is.na(x)), rev(cumsum(is.na(x)))))

Finally use this as an identifier to replace desired values in x

replace(x, tmp > 1, 0)

# [1]  3  4 NA  0 NA  3  3 NA  3 NA  0  0 NA  1

Written as a function

f <- function(x, gap = 1) {



  stopifnot(gap >= 0)



  if (gap == 0) {

    x[is.na(x)] <- 0

    x } else {

      grp <- with(rle(is.na(x)), rep(seq_along(lengths), times = lengths))

      tmp <- ave(x, grp, FUN = function(x) pmin(cumsum(is.na(x)), rev(cumsum(is.na(x)))))

      replace(x, tmp > gap, 0)

    }

}

f(x)