Заполните NA в R нулем, если следующая действительная точка данных находится на расстоянии более 2 интервалов

Может быть, есть более простые решения, но это работает.

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 по обе стороны от любого NA. Следовательно, используя lead и lag из пакета dplyr -

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

Предыдущий ответ (тоже быстрый) -

Вот один из способов использования rle и replace из базы R. Этот метод превращает каждую NA, которая не является конечной точкой в ​​рабочей длине, в 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

Обновленные тесты —

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_dplyr(x), Rui(x)) # [1] TRUE
all.equal(Shree_dplyr(x), Shree_rle(x)) # [1] TRUE
all.equal(Shree_dplyr(x), markus(x)) # [1] TRUE
all.equal(Shree_dplyr(x), Uwe1(x)) # [1] TRUE
all.equal(Shree_dplyr(x), Uwe2(x)) # [1] TRUE
all.equal(Shree_dplyr(x), Uwe_Reduce(x)) # [1] TRUE
all.equal(Shree_dplyr(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_rle(x)  51.556489  62.038875   85.348031  65.012384   81.882141  327.57514    50
 Shree_dplyr(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

PS: Обязательно ознакомьтесь с ответом TiredSquirell, который выглядит как базовая версия ответа Уве об опережении-отставании, но несколько быстрее (не тестировался выше).

Вот вариант 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)
}

Для полноты картины вот три других подхода к 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() и Reduce()

Я был настолько сосредоточен на поиске правильного способа создания групп, что довольно поздно начал думать о прямолинейном подходе. Правило довольно простое:

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

Это можно сделать с помощью zoo::rollapply(), как в Ответ Г. Гротендика, или с помощью lag() и lead(), как в Последняя редакция Шри.

Однако мой собственный тест (не опубликованный здесь, чтобы избежать дублирования с эталон Шри) показывает, что data.table::shift() и Reduce() пока являются самым быстрым методом.

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

Это также немного быстрее, чем использование lag() и lead() (обратите внимание, что это отличается от Версия Шри, поскольку is.na() вызывается только один раз):

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

Основываясь на примере, я предполагаю, что вы имеете в виду, что если значение равно NA, а соседние значения в обоих направлениях являются NA (или в одном направлении, если значение первое или последнее), то замените значение на 0. Использование центрированного скользящего окна длины 3 вернуть TRUE, если это все NA, а затем заменить позиции TRUE на 0. Это дает следующую однострочную строку

library(zoo)

replace(x, rollapply(c(TRUE, is.na(x), TRUE), 3, all), 0)
## [1]  3  4 NA  0 NA  3  3

Вот "глупо простое" решение:

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

Создание na_before и na_after основано на сдвиге на единицу вправо или влево. Чтобы проиллюстрировать, как это работает, рассмотрите буквы ниже (я пишу T и F как 1 и 0, чтобы их было легче различить):

              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

Когда вы делаете vowel_before, вы берете последовательность «10001» is_vowel и сдвигаете ее на единицу вправо (поскольку каждая буква теперь относится к букве слева от нее). Вы отбрасываете последнюю 1 (вас не волнует, что перед F стоит гласная, потому что F не входит) и добавляете 0 в начале (перед первой буквой нет буквы, и, следовательно, не может быть гласная перед ней). vowel_after создается по той же логике.

Редактировать. (Добавлено Руи Баррадасом)

Это решение, согласно моему тесту, самое быстрое.
Как функция:

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
}

И эталон.

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