R根据条件替换值（对于相同的ID）而不使用for循环

Question

我有一个类似于这个的 df，但更大（100.000 行 x 100 列）

df <-data.frame(id=c("1","2","2","3","4","4", "4", "4", "4", "4", "5"), date = c("2015-01-15", "2004-03-01", "2017-03-15", "2000-01-15", "2006-05-08", "2008-05-09", "2014-05-11", "2014-06-11", "2014-07-11", "2014-08-11", "2015-12-19"), A =c (0,1,1,0,1,1,0,0,1,1,1), B=c(1,0,1,0,1,0,0,0,1,1,1), C = c(0,1,0,0,0,1,1,1,1,1,0), D = c(0,0,0,1,1,1,1,0,1,0,1), E = c(1,1,1,0,0,0,0,0,1,1,1), A.1 = c(0,0,0,0,0,0,0,0,0,0,0), B.1 = c(0,0,0,0,0,0,0,0,0,0,0), C.1 = c(0,0,0,0,0,0,0,0,0,0,0), D.1 = c(0,0,0,0,0,0,0,0,0,0,0), E.1 = c(0,0,0,0,0,0,0,0,0,0,0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0))

我必须完成的是：

structure(list(id = structure(c(1L, 2L, 2L, 3L, 4L, 4L, 4L, 4L, 4L, 4L,5L), .Label = c("1", "2", "3", "4", "5"), class = "factor"), date = structure(c(9L, 2L, 11L, 1L, 3L, 4L, 5L, 6L, 7L, 8L,10L), .Label = c("2000-01-15", "2004-03-01", "2006-05-08","2008-05-09", "2014-05-11", "2014-06-11", "2014-07-11", "2014-08-11","2015-01-15", "2015-12-19", "2017-03-15"), class = "factor"), A = c(0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 1), B = c(1, 0, 1, 0,1, 0, 0, 0, 1, 1, 1), C = c(0, 1, 0, 0, 0, 1, 1, 1, 1, 1, 0), D = c(0, 0, 0, 1, 1, 1, 1, 0, 1, 0, 1), E = c(1, 1, 1,0, 0, 0, 0, 0, 1, 1, 1), A.1 = c(0, 0, 4762, 0, 0, 732, 2925,0, 0, 3017, 0), B.1 = c(0, 0, 0, 0, 0, 732, 0, 0, 0, 3017,0), C.1 = c(0, 0, 4762, 0, 0, 0, 2925, 2956, 2986, 3017,
0), D.1 = c(0, 0, 0, 0, 0, 732, 2925, 2956, 0, 3017, 0),E.1 = c(0, 0, 4762, 0, 0, 0, 0, 0, 0, 3017, 0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0)), .Names = c("id","date", "A", "B", "C", "D", "E", "A.1", "B.1", "C.1", "D.1", "E.1", "acumulativediff"), row.names = c(NA,-11L), class = "data.frame") 

这个想法是基于两个条件，将 A.1、B.1、C.1 列中的 0 替换为“acumulativediff”列的值：

df[i,1]  == df[i-1,1] & df[i,names] == "1" & df[i-1,names] == "1", df[i,diff]
df[i,1]  == df[i-1,1] & df[i,names] == "0" & df[i-1,names] == "1", df[i,diff]

我能够做到这一点，使用一个非高效的循环-for 似乎适用于小 df 但不适用于较大的 df（大约需要两个小时）

names <- colnames(df[3:7])
names2 <- colnames(df[8:12])
diff <- which(colnames(df)=="acumulativediff")
for (i in 2:nrow(df)){
df[i,names2] <- ifelse (df[i,1]  == df[i-1,1] & df[i,names] == "1" & 
df[i-1,names] == "1", df[i,diff],
      ifelse (df[i,1]  == df[i-1,1] & df[i,names] == "0" & df[i-1,names] == "1", df[i,diff], 0))}

有什么想法或建议可以省略循环以实现更高效的代码？

Answer 1

这对你有用吗？

df <-data.frame(id=c("1","2","2","3","4","4", "4", "4", "4", "4", "5"), 
                date = c("2015-01-15", "2004-03-01", "2017-03-15", "2000-01-15", "2006-05-08", 
                         "2008-05-09", "2014-05-11", "2014-06-11", "2014-07-11", "2014-08-11", "2015-12-19"), 
                A =c (0,1,1,0,1,1,0,0,1,1,1), B=c(1,0,1,0,1,0,0,0,1,1,1), C = c(0,1,0,0,0,1,1,1,1,1,0), 
                D = c(0,0,0,1,1,1,1,0,1,0,1), E = c(1,1,1,0,0,0,0,0,1,1,1), A.1 = c(0,0,0,0,0,0,0,0,0,0,0), 
                B.1 = c(0,0,0,0,0,0,0,0,0,0,0), C.1 = c(0,0,0,0,0,0,0,0,0,0,0), D.1 = c(0,0,0,0,0,0,0,0,0,0,0), 
                E.1 = c(0,0,0,0,0,0,0,0,0,0,0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0),
                stringsAsFactors = FALSE)
df2 <- df
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                0), D.1 = c(0, 0, 0, 0, 0, 732, 2925, 2956, 0, 3017, 0),E.1 = c(0, 0, 4762, 0, 0, 0, 0, 0, 0, 3017, 0), acumulativediff = c(0, 0, 4762, 0, 0, 732, 2925, 2956, 2986, 3017, 0)), .Names = c("id","date", "A", "B", "C", "D", "E", "A.1", "B.1", "C.1", "D.1", "E.1", "acumulativediff"), row.names = c(NA,-11L), class = "data.frame") 
names <- colnames(df[3:7])
names2 <- colnames(df[8:12])
diff <- which(colnames(df)=="acumulativediff")

df2[,names2] <- ifelse(df[,1] == dplyr::lag(df[,1]) & df[,names] == "1" & 
                         dplyr::lag(df[,names]) == "1",
                       df[,diff],
                       ifelse (df[,1]  == dplyr::lag(df[,1]) & df[,names] == "0" & 
                                 dplyr::lag(df[,names]) == "1", df[,diff], 0))

Answer 2

我建议忽略A.1, B.1 etc 列。只需使用dplyr::mutate_at 和OP 指定的规则重新创建这些列。 dplyr::lag 和 default = 0 将有助于避免 NA 结果。

library(dplyr)

df %>% select(-ends_with(".1")) %>%
  mutate_at(vars(A:E), 
       funs(l = ifelse(lag(id)==id & lag(., default=0) == "1",acumulativediff,0)))


#    id       date A B C D E acumulativediff  A_l  B_l  C_l  D_l  E_l
# 1   1 2015-01-15 0 1 0 0 1               0    0    0    0    0    0
# 2   2 2004-03-01 1 0 1 0 1               0    0    0    0    0    0
# 3   2 2017-03-15 1 1 0 0 1            4762 4762    0 4762    0 4762
# 4   3 2000-01-15 0 0 0 1 0               0    0    0    0    0    0
# 5   4 2006-05-08 1 1 0 1 0               0    0    0    0    0    0
# 6   4 2008-05-09 1 0 1 1 0             732  732  732    0  732    0
# 7   4 2014-05-11 0 0 1 1 0            2925 2925    0 2925 2925    0
# 8   4 2014-06-11 0 0 1 0 0            2956    0    0 2956 2956    0
# 9   4 2014-07-11 1 1 1 1 1            2986    0    0 2986    0    0
# 10  4 2014-08-11 1 1 1 0 1            3017 3017 3017 3017 3017 3017
# 11  5 2015-12-19 1 1 0 1 1               0    0    0    0    0    0

Answer 3

你也可以试试这个。 group_by 替换了另一个答案中使用的 ifelse 方法的一部分。这里使用case_when 来检查lag() == 1 是否足够IMO。

df %>% 
 select(-ends_with(".1")) %>% 
 group_by(id) %>% 
 mutate_at(.vars = vars(A:E), funs("1"=case_when(lag(.) == 1 ~ acumulativediff, TRUE ~ 0))) %>% 
 ungroup()
# A tibble: 11 x 13
   id    date           A     B     C     D     E acumulativediff  A_1  B_1  C_1  D_1  E_1
   <fct> <fct>      <dbl> <dbl> <dbl> <dbl> <dbl>           <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
 1 1     2015-01-15     0     1     0     0     1               0     0     0     0     0     0
 2 2     2004-03-01     1     0     1     0     1               0     0     0     0     0     0
 3 2     2017-03-15     1     1     0     0     1            4762  4762     0  4762     0  4762
 4 3     2000-01-15     0     0     0     1     0               0     0     0     0     0     0
 5 4     2006-05-08     1     1     0     1     0               0     0     0     0     0     0
 6 4     2008-05-09     1     0     1     1     0             732   732   732     0   732     0
 7 4     2014-05-11     0     0     1     1     0            2925  2925     0  2925  2925     0
 8 4     2014-06-11     0     0     1     0     0            2956     0     0  2956  2956     0
 9 4     2014-07-11     1     1     1     1     1            2986     0     0  2986     0     0
10 4     2014-08-11     1     1     1     0     1            3017  3017  3017  3017  3017  3017
11 5     2015-12-19     1     1     0     1     1               0     0     0     0     0     0

Answer 4

此df[i,1] == df[i-1,1] 条件可以替换为按id 列分组。还有一点是，如果A、B 等列中只有“0”或“1”，那么条件 (df[i,names] == "1" & df[i-1,names] == "1" 或 df[i,names] == "0" & df[i-1,names] == "1") 可以简化为只有 (df[i-1,names] == "1") 相当于df[,names] 的lag。

我提出了一个data.table 解决方案，其中延迟由shift 函数定义。坦率地说，由于使用了 eval(parse()) 结构，这不是一个好的编码示例，但我希望使用它们更容易理解解决方案。

library(data.table)

setDT(df)

bin_names <- LETTERS[1:5]
# [1] "A" "B" "C" "D" "E"
bin_names.1 <- paste0(bin_names, ".1")
# [1] "A.1" "B.1" "C.1" "D.1" "E.1"

# slicing table in parts with "by" parameter and compute columns "A.1", "B.1" etc. in for loop
for (i in seq_along(bin_names)) df[, eval(bin_names.1[i]) := shift(as.numeric(eval(parse(text = bin_names[i]))))*acumulativediff, by = .(id)]
df[]
#     id       date A B C D E  A.1  B.1  C.1  D.1  E.1 acumulativediff
#  1:  1 2015-01-15 0 1 0 0 1   NA   NA   NA   NA   NA               0
#  2:  2 2004-03-01 1 0 1 0 1   NA   NA   NA   NA   NA               0
#  3:  2 2017-03-15 1 1 0 0 1 4762    0 4762    0 4762            4762
#  4:  3 2000-01-15 0 0 0 1 0   NA   NA   NA   NA   NA               0
#  5:  4 2006-05-08 1 1 0 1 0   NA   NA   NA   NA   NA               0
#  6:  4 2008-05-09 1 0 1 1 0  732  732    0  732    0             732
#  7:  4 2014-05-11 0 0 1 1 0 2925    0 2925 2925    0            2925
#  8:  4 2014-06-11 0 0 1 0 0    0    0 2956 2956    0            2956
#  9:  4 2014-07-11 1 1 1 1 1    0    0 2986    0    0            2986
# 10:  4 2014-08-11 1 1 1 0 1 3017 3017 3017 3017 3017            3017
# 11:  5 2015-12-19 1 1 0 1 1   NA   NA   NA   NA   NA               0

如果您不喜欢表中的NAs，您可以多做一些工作来解决它。

fillna <- function(x, fill = 0) {x[is.na(x)] <- fill; return(x)}
for (nm in bin_names.1) df[, eval(nm) := fillna(eval(parse(text = nm)))]
df[]
#     id       date A B C D E  A.1  B.1  C.1  D.1  E.1 acumulativediff
#  1:  1 2015-01-15 0 1 0 0 1    0    0    0    0    0               0
#  2:  2 2004-03-01 1 0 1 0 1    0    0    0    0    0               0
#  3:  2 2017-03-15 1 1 0 0 1 4762    0 4762    0 4762            4762
#  4:  3 2000-01-15 0 0 0 1 0    0    0    0    0    0               0
#  5:  4 2006-05-08 1 1 0 1 0    0    0    0    0    0               0
#  6:  4 2008-05-09 1 0 1 1 0  732  732    0  732    0             732
#  7:  4 2014-05-11 0 0 1 1 0 2925    0 2925 2925    0            2925
#  8:  4 2014-06-11 0 0 1 0 0    0    0 2956 2956    0            2956
#  9:  4 2014-07-11 1 1 1 1 1    0    0 2986    0    0            2986
# 10:  4 2014-08-11 1 1 1 0 1 3017 3017 3017 3017 3017            3017
# 11:  5 2015-12-19 1 1 0 1 1    0    0    0    0    0               0

另一种选择是使用shift 和fill = 0 参数来立即获得零。

shift(as.numeric(eval(parse(text = bin_names[i]))), fill = 0)*acumulativediff

Answer 5

刚刚注意到您实际上想要按 ID 分组的操作，在这种情况下，我的回答没有提供正确的结果。

For 循环并不总是天生就慢——按行迭代代价高昂，但按列迭代会导致过多开销，完全矢量化它的唯一方法是使用矩阵方法。

这应该与大多数单行代码一样好或相似，但未来你可能会喜欢它的可读性。

setDT(df)

Suffix <- ".1"
SuffixedNames <- intersect(names(df),paste0(names(df),Suffix))
RawNames <- intersect(names(df),gsub(Suffix,"",SuffixedNames))

for (x in seq_along(RawNames)){

  thisRawName <- RawNames[[x]]
  thisSuffixedName <- SuffixedNames[[x]]

  Raw <- df[[thisRawName]]
  ## Using the shift() function from the data.table package
  Lagged <- shift(Raw, n = 1L, type = "lag", fill = -1L)

  ## Using set() from the data.table package
  set(df, j = thisSuffixedName, value = ifelse((Raw == Lagged & Raw == 1L & Lagged == 1L) | (Raw == 0L & Lagged == 1L),
                                    df[["acumulativediff"]],
                                    0L))
}

Answer 6

在基地R：

df2 <- df
# first we ignore id
df2[-1,8:12] <- df[-nrow(df),3:7] * df[-1,13]
# then we make sure rows of 1st id are 0
df2[which(diff(as.numeric(df$id))==1)+1,8:12] <- 0

#    id       date A B C D E  A.1  B.1  C.1  D.1  E.1 acumulativediff
# 1   1 2015-01-15 0 1 0 0 1    0    0    0    0    0               0
# 2   2 2004-03-01 1 0 1 0 1    0    0    0    0    0               0
# 3   2 2017-03-15 1 1 0 0 1 4762    0 4762    0 4762            4762
# 4   3 2000-01-15 0 0 0 1 0    0    0    0    0    0               0
# 5   4 2006-05-08 1 1 0 1 0    0    0    0    0    0               0
# 6   4 2008-05-09 1 0 1 1 0  732  732    0  732    0             732
# 7   4 2014-05-11 0 0 1 1 0 2925    0 2925 2925    0            2925
# 8   4 2014-06-11 0 0 1 0 0    0    0 2956 2956    0            2956
# 9   4 2014-07-11 1 1 1 1 1    0    0 2986    0    0            2986
# 10  4 2014-08-11 1 1 1 0 1 3017 3017 3017 3017 3017            3017
# 11  5 2015-12-19 1 1 0 1 1    0    0    0    0    0               0

这是与 @MKR 当前解决方案在给定数据集和约 10 万行的模拟数据集上进行比较的基准。无论如何，我的机器在我的机器上快 5 倍左右。

mm <- function(df){
df[-1,8:12] <- df[-nrow(df),3:7] * df[-1,13]
df[which(diff(as.numeric(df$id))==1)+1,8:12] <- 0
df}

mkr <- function(df){df %>% select(-ends_with(".1")) %>%
  mutate_at(vars(A:E), 
funs(l = ifelse(lag(id)==id & lag(., default=0) == "1",acumulativediff,0)))}

microbenchmark::microbenchmark(mm(df),mkr(df),unit="relative")
# Unit: relative
#     expr      min       lq     mean   median       uq      max neval
#   mm(df) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000   100
#  mkr(df) 7.788748 7.666287 5.265091 6.755467 6.655934 1.291942   100


big <- do.call(rbind,replicate(10000,df,F))
big$id <- data.table::rleid(big$id)

microbenchmark::microbenchmark(mm(big),mkr(big),unit="relative")
# Unit: relative
#     expr      min       lq     mean   median       uq      max neval
#  mm(big) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000   100
# mkr(big) 7.065627 4.945323 4.429752 4.910065 4.566391 1.765609   100