Векторизация движущегося окна с прошлыми итерациями

Question

Учитывая очень большой набор данных (> 1 миллион наблюдений), и я пытаюсь векторизовать мою логику, но не нашел R-ified способ ее решения.

Проблема в том, что каждый раз, когда у меня есть «Плохое» наблюдение в переменной, мне нужно проверить предыдущие 5 наблюдений на «Хорошие» показатели. «Плохие» наблюдения сохраняются до тех пор, пока этому предшествуют 5 «хороших» наблюдений. Если в окне перемещения 5 наблюдений есть «плохие», то это наблюдение в конечном итоге будет исключено из анализа.

До сих пор я пытался использовать цикл for с ifelse() логикой. Логика проверяется, но с обработкой R это занимает несколько часов. Я изучил пакет zoo для скользящих окон, но я не применяю агрегатные функции, такие как mean() или sum(). Я также изучил apply(), lapply() и т. Д., Но не смог заставить их работать.

Это мой код для цикла for. Пусть df$Observation будет исходным обозначением «Хороший против плохого», и пусть df$Result будет определением, будем ли мы сохранять или отбросить наблюдение.

Редактировать

set.seed(1)
df <- data.frame(Observation = sample(c("Good", "Bad"), 1000, T, c(0.9,0.1)))

for(i in 1:nrow(df)){
  ifelse(
    df$Observation[i] == "Good",
    df$Result[i] <- "Keep",
    ifelse(
      df$Observation[i] == "Bad" &
        df$Observation[i-1] == "Good" &
        df$Observation[i-2] == "Good" &
        df$Observation[i-3] == "Good" &
        df$Observation[i-4] == "Good",
      df$Result[i] <- "Keep",
      df$Result[i] <- "Drop"
    )
  )
}

Пример желаемого результата:

df[385:393,]

    Observation Result
385        Good   Keep
386        Good   Keep
387        Good   Keep
388        Good   Keep
389        Good   Keep
390         Bad   Keep
391        Good   Keep
392        Good   Keep
393         Bad   Drop

Код работает, как и ожидалось, но мне нужен более эффективный способ выполнить его в R. Спасибо за вашу помощь!

Answer 1

Мне нравится zoo за это. Кажется, что все совпадает, за исключением первого случая плохого (только 3 наблюдателя). Вы можете настроить логику так, чтобы она сохранялась, используя fill = 4

library(tidyverse)
library(zoo)

df_decision <-
  df %>% 
  mutate(
    good_ind = as.integer(Observation == "Good"),
    good_count = rollsum(good_ind, 5, align = "right", fill = good_ind),
    result =ifelse(good_ind == 1 | good_count >= 4, "keep", "drop")
  )

Answer 2

Если вы замените цикл некоторыми dplyr функциями, все действительно ускорится.Только будьте осторожны с обработкой первых 5 рядов.Версия dplyr отбросит все «плохие» наблюдения в первых 5 строках, тогда как ваш цикл сохранит их.Вы можете добавить немного логики к case_when, если вам нужно.

library(tictoc)
library(dplyr)

set.seed(1)
df <- data.frame(Observation = sample(c("Good", "Bad"), 10000, TRUE, c(0.9,0.1)))
df2 <- df

tic("loop")
for(i in 1:nrow(df)){
  ifelse(
    df$Observation[i] == "Good",
    df$Result[i] <- "Keep",
    ifelse(
      df$Observation[i] == "Bad" &
        df$Observation[i-1] == "Good" &
        df$Observation[i-2] == "Good" &
        df$Observation[i-3] == "Good" &
        df$Observation[i-4] == "Good",
      df$Result[i] <- "Keep",
      df$Result[i] <- "Drop"
    )
  )
}
toc() # 3.9s

tic("dplyr")
df2 <- df2 %>% 
  dplyr::mutate(
    L1 = dplyr::lag(Observation, 1),
    L2 = dplyr::lag(Observation, 2),
    L3 = dplyr::lag(Observation, 3),
    L4 = dplyr::lag(Observation, 4),
    L5 = dplyr::lag(Observation, 5),
    Result = dplyr::case_when(
      Observation == "Good" ~ "Keep",
      L1 == "Good" & 
        L2 == "Good" & 
        L3 == "Good" & 
        L4 == "Good" & 
        L5 == "Good" ~ "Keep",
      TRUE ~ "Drop"
    )
  ) %>% 
  dplyr::select(Observation, Result)
toc() # 0.08s

Answer 3

Вы можете сделать что-то вроде этого:

Сначала я установил начальное значение, создал несколько образцов данных и открыл необходимые пакеты.

set.seed(1)
df <- data.frame(Observation = sample(c("Good", "Bad"), 1000, T, c(0.9,0.1)))
library(zoo)
library(dplyr)

Сначала я отстала на один ряд. Оттуда я вычисляю rollmax для этой строки с задержкой и предыдущих четырех строк. Тогда я сравниваю это rollmax с 1. Если это оценивается как TRUE И текущая строка равна "Bad", Result будет "Drop", иначе это будет "KEEP".

df2 <- df %>% 
  mutate(Result = if_else(rollmax(lag(Observation) == "Bad", 5, fill = 0, align = "right") == 1 & Observation == "Bad", "Drop", "Keep")) 

Таким образом, он будет соответствовать ожидаемому результату:

 df2[385:393,]
    Observation Result
385        Good   Keep
386        Good   Keep
387        Good   Keep
388        Good   Keep
389        Good   Keep
390         Bad   Keep
391        Good   Keep
392        Good   Keep
393         Bad   Drop