У меня есть несколько векторов с NA и мое намерение заполнить NA, которые находятся более чем в 2 интервалах от действительной точки данных, с 0. Например:
x <- c(3, 4, NA, NA, NA, 3, 3)
Ожидаемый результат есть,
3, 4, NA, 0, NA, 3, 3
Может быть, есть более простые решения, но этот работает.
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, который выглядит как базовая версия ответа Uwe Lag Lag, но несколько быстрее (не тестировался выше).
Здесь опция 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()Я был так сосредоточен на поиске правильного способа создания групп, что начал думать о прямолинейном подходе довольно поздно. Правило довольно простое:
Замените все NA на ноль, которым предшествует и следует другой NA.
Это можно сделать с помощью zoo::rollapply() как в ответе Г. Гротендика, или с помощью lag() и lead() как в последнем редактировании Shree.
Тем не менее, мой собственный тест (не опубликованный здесь, чтобы избежать дублирования с data.table::shift() Шри) показывает, что data.table::shift() и Reduce() пока самый быстрый метод.
isnax <- is.na(x)
x[Reduce('&', data.table::shift(isnax, -1:1))] <- 0
x
Это также немного быстрее, чем использование lag() и lead() (обратите внимание, что это отличается от версии Shree, так как 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
Еще один базовый подход
x <- c(3, 4, NA, NA, NA, 3, 3, NA, 3, NA, NA, NA, NA, 1)
Создать группирующую переменную
grp <- with(rle(is.na(x)), rep(seq_along(lengths), lengths)) # same as rleid(is.na(x))
Для каждой группы вычислите параллельный минимум cumsum(is.na(x)) и его обратный (который будет больше единицы для значений, "которые находятся более чем в 2 интервалах от действительной точки данных" на расстоянии)
tmp <- ave(x, grp, FUN = function(x) pmin(cumsum(is.na(x)), rev(cumsum(is.na(x)))))
Наконец, используйте это как идентификатор для замены желаемых значений в x
replace(x, tmp > 1, 0)
# [1] 3 4 NA 0 NA 3 3 NA 3 NA 0 0 NA 1
Написано как функция
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)
Как насчет этого:
library(tidyverse)
x <- as.data.frame(x)
x %>% group_by(x) %>%
mutate(y = cumsum(is.na(x)), z = ifelse(y > 1 & y < max(y),0,x)) %>%
pull(z)
[1] 3 4 NA 0 NA 3 3