检测具有缺失值的先前行的变化 - 加速循环 - R

Question

我有一个包含缺失值的数据集。目的是创建一个向量 change，指示与上一个有效值的变化。

这是一些数据：

test <- data.frame(resp = c(9, NA, NA, 11, NA, NA, 6, 16, NA, 12, 0, 0, 0, 0, 0, NA, 0, 11, NA, NA, NA, NA, NA, NA, 14, NA, 23, NA, NA, 16, 16))

思路如下：

值没有变化 0
value > 前一个有效值每次增加都会增加 1（例如 1、2、3）
value < last previous valid value results in -1 and -1 if the previous already negative.

以上数据的结果如下所示：

    resp change
1      9      0
2     NA     NA
3     NA     NA
4     11      1
5     NA     NA
6     NA     NA
7      6     -1
8     16      1
9     NA     NA
10    12     -1
11     0     -2
12     0      0
13     0      0
14     0      0
15     0      0
16    NA     NA
17     0      0
18    11      1
19    NA     NA
20    NA     NA
21    NA     NA
22    NA     NA
23    NA     NA
24    NA     NA
25    14      2

我尝试了一个 for 循环并且它以某种方式工作但我觉得这是混乱的代码而且它非常慢。关于更好地解决此任务的想法（例如 purrr）？

    for (i in 2:nrow(test)) {
  test$change[i] <- 0
  test$change[i] <- case_when(
    test$resp[i] > last(test$resp[which(!is.na(test$resp[1:i-1]))]) & last(test$change[which(!is.na(test$resp[2:i-1]))]) >= 0  ~ test$change[i] + last(test$change[which(!is.na(test$resp[1:i-1]))]) + 1,
    test$resp[i] > last(test$resp[which(!is.na(test$resp[1:i-1]))]) & last(test$change[which(!is.na(test$resp[2:i-1]))]) <= 0  ~ test$change[i] + 1,
    test$resp[i] < last(test$resp[which(!is.na(test$resp[1:i-1]))]) & last(test$change[which(!is.na(test$resp[2:i-1]))]) <= 0  ~ test$change[i] + last(test$change[which(!is.na(test$resp[1:i-1]))]) - 1,
    test$resp[i] < last(test$resp[which(!is.na(test$resp[1:i-1]))]) & last(test$change[which(!is.na(test$resp[2:i-1]))]) >= 0  ~ test$change[i]- 1,
    TRUE ~ test$change[i])
  test$change[i] <- if_else(is.na(test$resp[i]), NA_real_, test$change[i])
}

最终，这应该应用于具有 > 30 个变量和 > 100000 行的数据集。

Answer 1

这会重复您的结果，除了它始终使用 0 表示没有变化（如您的描述），而不是 NA。它基本上使用 fill 和 lag 来创建包含您使用 last 和 which 创建的值的列，然后使用 case_when 填充 change列。

如果您想要 NA 而不是 change 列中的 0，请将 case_when 的第一个子句中的 ~ 0 更改为 ~ NA_real_。如果您真的想要像示例中那样混合使用 0 和 NA，请说明何时使用它们。

library(tidyverse)
test <- data.frame(resp = c(9, NA, NA, 11, NA, NA, 6, 16, NA, 12, 0, 0, 0, 0, 0, NA, 0, 11, NA, NA, NA, NA, NA, NA, 14, NA, 23, NA, NA, 16, 16))

test %>% mutate(filled=resp) %>% 
  fill(filled) %>% 
  mutate(change_sign=sign(filled-lag(filled, default=filled[1])),
         lag_filled_change = lag(if_else(change_sign==0, NA_real_, change_sign), default=0)) %>% 
  fill(lag_filled_change) %>% 
  mutate(change = case_when(
    change_sign==0 ~ 0,
    change_sign==1 & lag_filled_change<=0 ~ 1,
    change_sign==1 & lag_filled_change >0 ~ lag_filled_change+1,
    change_sign==-1& lag_filled_change>=0 ~ -1,
    change_sign==-1& lag_filled_change <0 ~ lag_filled_change-1
  )) %>% 
  select(resp, change)
#>    resp change
#> 1     9      0
#> 2    NA      0
#> 3    NA      0
#> 4    11      1
#> 5    NA      0
#> 6    NA      0
#> 7     6     -1
#> 8    16      1
#> 9    NA      0
#> 10   12     -1
#> 11    0     -2
#> 12    0      0
#> 13    0      0
#> 14    0      0
#> 15    0      0
#> 16   NA      0
#> 17    0      0
#> 18   11      1
#> 19   NA      0
#> 20   NA      0
#> 21   NA      0
#> 22   NA      0
#> 23   NA      0
#> 24   NA      0
#> 25   14      2
#> 26   NA      0
#> 27   23      2
#> 28   NA      0
#> 29   NA      0
#> 30   16     -1
#> 31   16      0

^{由 reprex package (v0.3.0)}

于 2020-01-15 创建

Answer 2

这是另一种方法，它删除任何带有 NA 的行，执行一些计算并在正确的位置连接回 NA 行。

library(tidyverse)
library(zoo)

# example data
test <- data.frame(resp = c(9, NA, NA, 11, NA, NA, 6, 16, NA, 12, 0, 0, 0, 0, 0, NA, 0, 11, NA, NA, NA, NA, NA, NA, 14))

# add an id for each row
test = test %>% mutate(id = row_number())

test %>%
  na.omit() %>%                                                               # exclude rows with NAs
  mutate(flag = case_when(resp == lag(resp, default = first(resp)) ~ 0,
                          resp > lag(resp, default = first(resp)) ~ 1,
                          resp < lag(resp, default = first(resp)) ~ -1)) %>%  # check relationship between current and previous value
  mutate(g = cumsum(flag != lag(flag, default = first(flag)))) %>%            # create a grouping based on change in flag column
  group_by(g) %>%                                                             # for each group
  mutate(change = ifelse(flag != 0, flag * row_number(), flag)) %>%           # calculate the change column
  ungroup() %>%                                                               # forget the grouping
  select(id, change) %>%                                                      # keep useful columns
  right_join(test, by="id") %>%                                               # join back to get NA rows in the right place
  select(resp, change)                                                        # keep useful columns

结果你会得到：

#    resp change
# 1     9      0
# 2    NA     NA
# 3    NA     NA
# 4    11      1
# 5    NA     NA
# 6    NA     NA
# 7     6     -1
# 8    16      1
# 9    NA     NA
# 10   12     -1
# 11    0     -2
# 12    0      0
# 13    0      0
# 14    0      0
# 15    0      0
# 16   NA     NA
# 17    0      0
# 18   11      1
# 19   NA     NA
# 20   NA     NA
# 21   NA     NA
# 22   NA     NA
# 23   NA     NA
# 24   NA     NA
# 25   14      2

检测具有缺失值的先前行的变化 - 加速循环 - R

Detect change from previous rows with missing values - speed up for loop - R

r

loops

time-series

purrr

tidy