【问题标题】：Efficiently filter out where all columns are zeros consecutively有效过滤掉所有列连续为零的位置
【发布时间】：2021-12-15 22:02:40
【问题描述】：

我有一个像下面这样的数据集（实际数据集有 5M+ 行，没有间隙），我试图过滤掉行本身及其前一个的所有数字列的 sum 的行并且下一行等于零。

注意

Time 是实际数据中的dttm 列。
连续零的数量可以超过 3 行，在这种情况下，多行将被过滤掉。

# A tibble: 13 x 4
   group  Time  Val1  Val2
   <chr> <int> <dbl> <dbl>
 1 A         1   0     0  
 2 B         1   0.1   0  
 3 A         3   0     0  
 4 B         3   0     0  
 5 A         2   0     0  
 6 B         2   0.2   0.2
 7 B         4   0     0  
 8 A         4   0     0.1
 9 A         5   0     0  
10 A         6   0     0  
11 B         6   0.1   0.5
12 B         5   0.1   0.2
13 A         7   0     0

请参阅下面的示例了解所需内容：

# A tibble: 13 x 8
   group  Time  Val1  Val2 rowsum leadsum lagsum   sum
   <chr> <int> <dbl> <dbl>  <dbl>   <dbl>  <dbl> <dbl>
 1 A         1   0     0      0       0     NA    NA  
 2 A         2   0     0      0       0      0     0     This will get filtered out! 
 3 A         3   0     0      0       0.1    0     0.1
 4 A         4   0     0.1    0.1     0      0     0.1
 5 A         5   0     0      0       0      0.1   0.1
 6 A         6   0     0      0       0      0     0     This will get filtered out!
 7 A         7   0     0      0      NA      0    NA  
 8 B         1   0.1   0      0.1     0.4   NA    NA  
 9 B         2   0.2   0.2    0.4     0      0.1   0.5
10 B         3   0     0      0       0      0.4   0.4
11 B         4   0     0      0       0.3    0     0.3
12 B         5   0.1   0.2    0.3     0.6    0     0.9
13 B         6   0.1   0.5    0.6    NA      0.3  NA

到目前为止，我已经尝试通过使用dplyr::lag() 和dplyr::lead() 来做到这一点；但这效率极低，并且会为实际数据集引发内存分配错误：

>     Error in Sys.getenv("TESTTHAT") : 
>       could not allocate memory (0 Mb) in C function 'R_AllocStringBuffer'

这是我目前所拥有的；我可以先得到Val1 和Val2 的总和，然后执行lead 和lag，但这不会解决问题。

df0 %>% 
  ##arrange by group is not necessary since we're grouping by that var
  arrange(group, Time) %>% 
  group_by(group) %>% 
  mutate(sum = Val1 + Val2 + lag(Val1) + lag(Val2) + lead(Val1) + lead(Val2)) # %>% 
  # filter(is.na(sum) | sum != 0)
  ## commenting out filter to show the full results

# >  # A tibble: 13 x 5
# >  # Groups:   group [2]
# >  group  Time  Val1  Val2   sum
# >  <chr> <int> <dbl> <dbl> <dbl>
# >  1  A   1     0     0      NA  
# !  -  A   2     0     0      0  
# >  2  A   3     0     0      0.1
# >  3  A   4     0     0.1    0.1
# >  4  A   5     0     0      0.1
# !  -  A   6     0     0      0  
# >  5  A   7     0     0      NA  
# >  6  B   1     0.1   0      NA  
# >  7  B   2     0.2   0.2    0.5
# >  8  B   3     0     0      0.4
# >  9  B   4     0     0      0.3
# >  10 B   5     0.1   0.2    0.9
# >  11 B   6     0.1   0.5    NA

玩具数据集：

df0 <- structure(list(group = c("A", "B", "A", "B", "A", "B", 
                                "B", "A", "A", "A", "B", "B", "A"),
                      Time = c(1L, 1L, 3L, 3L, 2L, 2L, 4L, 4L, 5L, 6L, 6L, 5L, 7L), 
                      Val1 = c(0, 0.1, 0, 0, 0, 0.2, 0, 0, 0, 0, 0.1, 0.1, 0), 
                      Val2 = c(0, 0, 0, 0, 0, 0.2, 0, 0.1, 0, 0, 0.5, 0.2, 0)), 
                 row.names = c(NA, -13L), 
                 class = c("tbl_df", "tbl", "data.frame"))

【问题讨论】：

在您的玩具数据中df0 - 应该只过滤掉第 4 行，对吗？
@DonaldSeinen 我已经显示了玩具数据集的所需输出；第 5 行 (A-2) 和第 10 行 (A-6) 将被过滤。
嗨@M--感谢您提供的最小示例！因为您的问题是关于更大数据的效率，您可以考虑添加足够大小/复杂性的玩具数据集。干杯

标签： r dataframe filter data.table tidyverse

【解决方案1】：

我们可以使用基础rle，或其更快的实现，rlenc 在purler 包中实现。

library(tidyverse)
library(purler)
subsetter <- function(df){
  df %>%
    select(where(is.double)) %>%
    rowSums() %>%
    purler::rlenc() %>%
    filter(lengths >= 3L & values == 0L) %>%
    transmute(ids = map2(start, start + lengths, ~ (.x + 1) : (.y - 2))) %>%
    unlist(use.names = F)
}
# to get data as shown in example
df0 <- df0 %>%
  mutate(Time = as.character(Time)) %>%
  arrange(group, Time)

edge_cases <- tribble(
  ~group, ~Time, ~Val1, ~Val2,
  "C", "1", 0, 0,
  "C", "2", 0, 0,
  "C", "3", 0, 0,
  "C", "4", 0, 0,
)

df1 <- rbind(df0, edge_cases)
df1 %>%
  `[`(-subsetter(.),)

# A tibble: 13 x 4
   group Time   Val1  Val2
   <chr> <chr> <dbl> <dbl>
 1 A     1       0     0  
 2 A     3       0     0  
 3 A     4       0     0.1
 4 A     5       0     0  
 5 A     7       0     0  
 6 B     1       0.1   0  
 7 B     2       0.2   0.2
 8 B     3       0     0  
 9 B     4       0     0  
10 B     5       0.1   0.2
11 B     6       0.1   0.5
12 C     1       0     0  
13 C     4       0     0

bench::mark(df1 %>% `[`(-subsetter(.),))[,c(3,5,7)]
# A tibble: 1 x 3
    median mem_alloc n_itr
  <bch:tm> <bch:byt> <int>
1   3.91ms    9.38KB    93

【讨论】：

谢谢。可以超过3行以上，只要满足lead、lag、自身等于0即可。
@M-- 我已经调整了功能。但是我确信这可以通过切入使用的函数和删除类型检查等来进一步优化内存使用和速度。这可能涉及数据的一些重组，即使其成为矩阵，这可以接受吗？

【解决方案2】：

既然你标记了data.table，这里有一个data.table-native 解决方案：

library(data.table)
dt0 <- as.data.table(df0)
setorder(dt0, Time) # add 'group' if you want

isnum <- names(which(sapply(dt0, function(z) is.numeric(z) & !is.integer(z))))
isnum
# [1] "Val1" "Val2"

dt0[, sum0 := abs(rowSums(.SD)) < 1e-9, .SDcols = isnum
  ][, .SD[(c(0,sum0[-.N]) + sum0 + c(sum0[-1],0)) < 3,], by = .(group)
  ][, sum0 := NULL ][]
#      group  Time  Val1  Val2
#     <char> <int> <num> <num>
#  1:      A     1   0.0   0.0
#  2:      A     3   0.0   0.0
#  3:      A     4   0.0   0.1
#  4:      A     5   0.0   0.0
#  5:      A     7   0.0   0.0
#  6:      B     1   0.1   0.0
#  7:      B     2   0.2   0.2
#  8:      B     3   0.0   0.0
#  9:      B     4   0.0   0.0
# 10:      B     5   0.1   0.2
# 11:      B     6   0.1   0.5

根据您的评论，A-2 和 A-6 均已被删除。

效率：

rowSums 快速高效；
我们使用默认为0 的直接索引进行移位；在data.table 中，这是非常有效地处理的，并且不会产生lead/lag/shift 调用的（诚然很小的）开销；
对一行求和后，我们只对这一个值进行行移位，而不是每行进行四次行移位。

编辑，性能略有提升（15-20%）：

dt0[
  dt0[, sum0 := abs(rowSums(.SD)) < 1e-9, .SDcols = isnum
    ][, .I[(c(0,sum0[-.N]) + sum0 + c(sum0[-1],0)) < 3], by=group ]$V1
][, sum0 := NULL][]

诚然，这可能有点难以理解，但它在大约 82% 的时间内产生相同的结果（使用 this 数据集）。感谢@Henrik 帮助我了解.I 及其好处。

【讨论】：

嗨@r2evans！这在问题的上下文中并不重要，但请注意 .SDcols 也有一个函数，例如.SDcols=is.numeric。干杯
谢谢@Henrik！是的，虽然我还没有把它变成我的习惯，但在这种情况下，我们需要更多的东西，因为Time 将是一个问题：is.numeric here 将是真的（应该不是），is.double 工作 here 但is.double(Sys.time()) 是真的，所以总体上不好。（我确实喜欢保持代码紧凑，但在这种情况下，我不认为将 isnum 中断对于演练来说是一件坏事，尤其是如果不精通 data.table。）再次感谢！
也值得考虑索引.I 而不是.SD，这会产生很大的开销（如果有很多组，成本会很高）。
@r2evans 一个非常简单的示例，（希望）使用.I（原始（完整）数据集中的行号）的索引让您更好地了解组内的子集);例如按组选择与最大值对应的行。 d = data.table(g = c(1, 1, 1, 2, 2, 2), val = c(2, 5, 3, 3, 1, 3));一步一步：d[ , val == max(val), by = g]； d[ , .I[val == max(val)], by = g]; d[ , .I[val == max(val)], by = g]$V1; d[d[ , .I[val == max(val)], by = g]$V1]; d[ , .SD[val == max(val)], by = g]
@r2evans 欢迎您。在a benchmark on larger data 中，.I[ 比.SD[ 快大约 10 倍，因此速度提升可能非常显着。祝你好运！

【解决方案3】：

您可以尝试以下data.table 选项

setorder(setDT(df0), group, Time)[
  ,
  rs := rowSums(Filter(is.double, .SD))
][, .SD[!(rs == 0 & .N > 2 & (!rowid(rs) %in% c(1, .N)))], rleid(rs)][
  ,
  rleid := NULL
][]

给了

    group Time Val1 Val2
 1:     A    1  0.0  0.0
 2:     A    3  0.0  0.0
 3:     A    4  0.0  0.1
 4:     A    5  0.0  0.0
 5:     A    7  0.0  0.0
 6:     B    1  0.1  0.0
 7:     B    2  0.2  0.2
 8:     B    3  0.0  0.0
 9:     B    4  0.0  0.0
10:     B    5  0.1  0.2
11:     B    6  0.1  0.5

【讨论】：

【解决方案4】：

这个解决方案主要受@r2evans 的启发。它使用Reduce、+ 和shift，而不是@r2evans 基于rowSums 和c 函数的解决方案。我认为这个解决方案的改进来自于在 data.frame/data.table 上使用 Reduce(+, .SD) 而不是 rowSums(.SD) （以及在使用 data.table 合成器时避免使用 [, .SD[...], ...]）；它更快（至少在我的 PC 上）和内存效率更高（不转换为矩阵）。警告：rowSums(.SD, na.rm=TRUE) 没有直接等效项。

n = 1e7
dt0 = setDT(df0[sample(nrow(df0), n, replace=TRUE), ])
setorder(dt0, group, Time)
isnum = sapply(dt0, function(x) is.numeric(x) && !is.integer(x))
eps = sqrt(.Machine$double.eps)

# New solution
f1 = function() {
  ans = dt0[, is0 := {sum0 = abs(Reduce(`+`, .SD)) < eps; Reduce(`+`, shift(sum0, -1:1, fill=0)) < 3}, 
            by=group, .SDcols=isnum][(is0), !"is0"]
  
  dt0[, is0 := NULL] # remove is0 from the initial dataset
  ans
}

# similar to f1: easily adaptable to rowSums(.SD, na.rm=TRUE).
f2 = function() {
  # here I replace Reduce(`+`, .SD) with rowSums(.SD) just in case its na.rm argument is needed.
  ans = dt0[, is0 := {sum0 = abs(rowSums(.SD)) < eps; Reduce(`+`, shift(sum0, -1:1, fill=0)) < 3}, 
            by=group, .SDcols=isnum][(is0), !"is0"]
  
  dt0[, is0:=NULL] # remove is0 from the initial dataset
  ans
}

# r2evans first solution
f3 = function() {
  ans = dt0[
    dt0[, sum0 := abs(rowSums(.SD)) < eps, .SDcols = isnum
    ][, .I[(c(0,sum0[-.N]) + sum0 + c(sum0[-1],0)) < 3], by=group ]$V1
  ][, sum0 := NULL][]
  
  dt0[, sum0 := NULL] # remove sum0 from the initial dataset
  ans
}

# r2evans second solution
f4 = function() {
  ans = dt0[, sum0 := abs(rowSums(.SD)) < eps, .SDcols = isnum
  ][, .SD[(c(0,sum0[-.N]) + sum0 + c(sum0[-1],0)) < 3,], by = .(group)
  ][, sum0 := NULL ][]
  
  dt0[, sum0:=NULL] # remove sum0 from the initial dataset
  ans
}

# modified version of r2evans second solution: similar to f4 but avoid [, .SD[...], by=group]
f5 = function() {
  ans = dt0[, sum0 := abs(rowSums(.SD)) < eps, .SDcols = isnum
  ][, sum0 := (c(0,sum0[-.N]) + sum0 + c(sum0[-1],0)) < 3, by = .(group)
  ][(sum0), !"sum0"][]
  
  dt0[, sum0:=NULL] # remove sum0 from the initial dataset
  ans
}

基准测试

bench::mark(
  f1(),
  f2(),
  f3(),
  f4(),
  f5(),
  iterations=5L, check=FALSE
)

# A tibble: 5 x 13
  expression    min median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time
  <bch:expr> <bch:> <bch:>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm>
1 f1()        347ms  406ms      2.49  698.47MB     5.48     5    11      2.01s
2 f2()        529ms  578ms      1.69  851.02MB     4.06     5    12      2.96s
3 f3()        717ms  821ms      1.22    1.25GB     3.40     5    14      4.12s
4 f4()        889ms  956ms      1.04    1.57GB     5.01     5    24      4.79s
5 f5()        642ms  677ms      1.40    1.07GB     3.37     5    12      3.56s

基于这个结果，第一个解决方案比 f3 和 f4 快 2+，并且内存效率也更高。

我用的是开发版的data.table (data.table 1.14.3)

【讨论】：

【解决方案5】：

library(tidyverse)
df0 %>%
  arrange(group, Time) %>%  # EDIT to arrange by time (and group for clarity)
  rowwise() %>%
  mutate(sum = sum(c_across(Val1:Val2))) %>%
  group_by(group) %>%
  filter( !(sum == 0 & lag(sum, default = 1) == 0 & lead(sum, default = 1) == 0)) %>%
  ungroup()

# A tibble: 11 x 5
   group  Time  Val1  Val2   sum
   <chr> <int> <dbl> <dbl> <dbl>
 1 A         1   0     0     0  
 2 A         3   0     0     0  
 3 A         4   0     0.1   0.1
 4 A         5   0     0     0  
 5 A         7   0     0     0  
 6 B         1   0.1   0     0.1
 7 B         2   0.2   0.2   0.4
 8 B         3   0     0     0  
 9 B         4   0     0     0  
10 B         5   0.1   0.2   0.3
11 B         6   0.1   0.5   0.6

【讨论】：

感谢您的回答。这和我提到的一样（我可以先求和，然后执行领先和滞后）。不幸的是，这并不能解决内存问题。
此外，还需要按时间排序。否则，错误的行（时间戳）将被过滤掉。