使用过去的迭代矢量化移动窗口

Question

给定一个非常大的数据集（> 100 万次观察），我正在尝试对我的逻辑进行矢量化，但还没有找到解决它的 R 化方法。

问题是每次我在变量中有“坏”观察时，我都需要检查前 5 次观察中的“好”指标。只要前面有 5 个“好”观察，就会保留“坏”观察。如果在 5 个观察移动窗口内有“坏”的观察，那么该观察最终将从分析中删除。

到目前为止，我已经尝试使用带有 ifelse() 逻辑的 for 循环。逻辑检查出来了，但是使用 R 的处理需要几个小时才能完成。我已经查看了用于滚动窗口的 zoo 包，但没有应用像 mean() 或 sum() 这样的聚合函数。我还研究了apply()、lapply() 等，但无法让它们工作。

这是我的 for 循环代码。让df$Observation 成为Good vs Bad 的初始名称，让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。除了第一个 bad 实例（之前只有 3 个 obs）之外，这一切似乎都匹配。您可以使用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

你可以这样做：

首先我设置了种子，创建了一些示例数据并打开了必要的包。

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

Answer 3

如果你用一些 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