with - Rellene los NA en R con cero si el siguiente punto de datos válido está a más de 2 intervalos de distancia




tidyr replace na (4)

Tengo varios vectores con NA y mi intención de rellenar NA, que son más de 2 intervalos desde un punto de datos válido con 0. por ejemplo:

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

La salida esperada es,

3, 4, NA, 0, NA, 3, 3 

Aquí hay una opción data.table

library(data.table)

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

Aquí hay una solución "estúpidamente simple":

is_na <- is.na(x)       # Vector telling you whether each position in x is NA
na_before <- c(F,is_na[1:(length(x)-1)])    # Whether each position has an NA before it
na_after <- c(is_na[2:length(x),F)          # Whether each position has an NA after it
x[is_na & na_before & na_after] <- 0        # Set to 0 if all three are true

La creación de na_before y na_after se basa en desplazar uno a la derecha o uno a la izquierda. Para ilustrar cómo funciona esto, considere las letras a continuación (estoy escribiendo T y F como 1 y 0 para que sean más fáciles de distinguir):

              A  B  C  D  E
is_vowel      1  0  0  0  1
vowel_before  0  1  0  0  0
vowel_after   0  0  0  1  0

Cuando hagas vocal_ antes, tome la secuencia "10001" de is_vowel y gírela una a la derecha (porque cada letra ahora se refiere a la letra a su izquierda). Elimina el último 1 (no le importa que F tenga una vocal antes, porque F no está incluida) y agrega un 0 al principio (la primera letra no tiene ninguna letra antes y, por lo tanto, no puede tener una vocal delante de ella). vowel_after se crea con la misma lógica.

Editar. (Agregado por Rui Barradas)

Esta solución es, según mi punto de referencia, la más rápida.
Como una función:

TiredSquirrel <- function(x){
  is_na <- is.na(x)
  na_before <- c(FALSE, is_na[1:(length(x) - 1)])
  na_after <- c(is_na[2:length(x)], FALSE)
  x[is_na & na_before & na_after] <- 0
  x
}

Y el punto de referencia.

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

r <- na2zero(x)
all.equal(r, TiredSquirrel(x))
#[1] TRUE

x <- sample(x, 1e3, TRUE)
r <- na2zero(x)
all.equal(r, TiredSquirrel(x))
#[1] TRUE

microbenchmark(
  Rui = na2zero(x),
  Uwe_Reduce = Uwe_Reduce(x),
  TiredSquirrel = TiredSquirrel(x)
)
#Unit: microseconds
#          expr      min        lq       mean    median        uq      max neval cld
#           Rui 3134.293 3198.8180 3365.70736 3263.7980 3391.7900 5593.111   100   b
#    Uwe_Reduce   99.895  104.3510  125.81417  113.9995  146.7335  244.280   100  a 
# TiredSquirrel   65.205   67.4365   72.41129   70.6430   75.8315  122.061   100  a 

En aras de la integridad, aquí hay otros tres enfoques de data.table:

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() y Reduce()

Estaba tan concentrado en encontrar la manera correcta de crear grupos que comencé a pensar en el enfoque directo más bien tarde. La regla es bastante simple:

Reemplace todas las NA por cero, las cuales son precedidas y seguidas por otra NA.

Esto se puede lograr con zoo::rollapply() como en la respuesta de G. Grothendieck o usando lag() y lead() como en la última edición de Shree .

Sin embargo, mi propio punto de referencia (no publicado aquí para evitar la duplicación con el punto de referencia de Shree ) muestra que data.table::shift() y Reduce() es el método más rápido hasta el momento.

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

También es un poco más rápido que usar lag() y lead() (tenga en cuenta que esto difiere de la versión de Shree, ya que is.na() solo se llama una vez):

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

Tal vez hay soluciones más simples pero esta funciona.

na2zero <- 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
  })
}

na2zero(x)
#[1]  3  4 NA  0 NA  3  3

X <- list(x, c(x, x), c(3, 4, NA, NA, NA, NA, 3, 3))
lapply(X, na2zero)




na