r - 大表破坏性过滤的解决方案

Question

我有一个问题，我需要根据一列选择并保存表的一部分，然后从源表中删除与已保存表的一列中的值匹配的行。

我发现 dplyr 和 data.table 比基本 R 慢，我想知道我是否在这里做错了什么(我不知道的反模式？)或者是否有人知道更快的解决方案。

我需要在搜索 df 和 y_unique 搜索的 ~10k 迭代中将其扩展到 ~1000 万行。

这是一个合理的可重复示例...

(编辑:我意识到我正在做的事情可以通过组过滤器来实现。留下一个更新的可重现示例，并从下面的评论和我更新的解决方案中进行一些调整。 - 请注意，原始不包括 bind_cols(y_list) 细节. 回想起来，我应该在这个例子中包含它。)

library(dplyr)
library(data.table)
library(microbenchmark)

microbenchmark(base = {
  for(y_check in y_unique) {
    y_list[[as.character(y_check)]] <- df[df$y == y_check, ]
    df <- df[!df$x %in% y_list[[as.character(y_check)]]$x, ]
  }
  out <- bind_rows(y_list)
}, dplyr = {
  for(y_check in y_unique) {
    y_list[[as.character(y_check)]] <- filter(df, y == y_check)
    df <- df[!df$x %in% y_list[[as.character(y_check)]]$x, ]
  }
  out <- bind_rows(y_list)
}, data.table = {
  for(y_check in y_unique) {
    y_list[[as.character(y_check)]] <- dt[y == y_check]
    dt <- dt[!x %in% y_list[[as.character(y_check)]]$x]
  }
  out <- do.call(rbind, y_list)
}, alternate = {
  df <- group_by(df, x)
  out <- filter(df, y == min(y))
}, times = 10, setup = {
  set.seed(1)
  df <- data.frame(x = sample(1:1000, size = 1000, replace = TRUE),
                   y = sample(1:100, size = 1000, replace = TRUE))
  dt <- data.table(df)
  y_unique <- sort(unique(df$y))
  y_list <- setNames(rep(list(list()), length(y_unique)), y_unique)
})

我得到:

Unit: milliseconds
       expr        min        lq       mean     median        uq        max neval
       base  12.939135  13.22883  13.623098  13.500897  13.95468  14.517167    10
      dplyr  41.517351  42.22595  50.041123  45.199978  61.33194  65.927611    10
 data.table 228.014360 233.98309 248.281965 240.172383 263.39943 287.706941    10
  alternate   3.310031   3.42016   3.745013   3.454537   4.17488   4.497455    10

在我的真实数据上，我或多或少是一样的。基础比 dplyr 快 2 倍以上，而 data.table 是......慢。有任何想法吗？

Answer 1

使用 join 的几个选项(使用实际尺寸的任何连接方法大约 13 秒):

DT <- copy(dt)
setorder(DT, y, x)
DT[DT[.(unique(x)), on=.(x), .(y=first(y)), by=.EACHI], on=.(x,y)]

或者如果原始订购很重要:

DT2 <- copy(dt)
setorder(DT2[, rn := .I], y, x)
dt[sort(DT2[.(unique(x)), on=.(x), rn[y==first(y)], by=.EACHI]$V1)]

并且还使用 min OP中提到:

DT0[, rn := .I]
dt[DT0[.(unique(x)), on=.(x), rn[y==min(y)], by=.EACHI][order(V1), V1]]   

计时码:

base <- function() {
    for(y_check in y_unique) {
        y_list[[as.character(y_check)]] <- df[df$y == y_check, ]
        df <- df[!df$x %in% y_list[[as.character(y_check)]]$x, ]
    }
    do.call(rbind, y_list)
} #base

mtd0 <- function() {
    for(y_check in y_unique) {
        y_list[[as.character(y_check)]] <- dt[y == y_check]
        dt <- dt[!x %in% y_list[[as.character(y_check)]]$x]
    }
    out <- rbindlist(y_list)
} #mtd0

join_mtd <- function() {
    setorder(DT, y, x)
    dt[DT[.(unique(x)), on=.(x), .(y=first(y)), by=.EACHI], on=.(x,y)]
} #join_mtd

join_mtd2 <- function() {
    setorder(DT2[, rn := .I], y, x)
    dt[sort(DT2[.(unique(x)), on=.(x), rn[y==first(y)], by=.EACHI]$V1)]
} #join_mtd2

join_mtd3 <- function() {
    DT0[, rn := .I]
    dt[DT0[.(unique(x)), on=.(x), rn[y==min(y)], by=.EACHI][order(V1), V1]]
} #join_mtd3

bench::mark(base(), data.table_0=mtd0(), 
    jm=join_mtd(), jm2=join_mtd2(), jm3=join_mtd2(), check=FALSE)

检查:

baseans <- setDT(base())
data.table_0 <- mtd0()
ordbase <- setorder(copy(baseans), y, x)
jm <- join_mtd()
jm2 <- join_mtd2()
jm3 <- join_mtd3()

identical(baseans, data.table_0)
#[1] TRUE
identical(ordbase, setorder(jm, y, x))
#[1] TRUE
identical(ordbase, setorder(jm2, y, x))
#[1] TRUE
identical(ordbase, setorder(jm3, y, x))
#[1] TRUE

时间:

# A tibble: 5 x 14
  expression        min     mean   median      max `itr/sec` mem_alloc  n_gc n_itr total_time result                   memory                time    gc            
  <chr>        <bch:tm> <bch:tm> <bch:tm> <bch:tm>     <dbl> <bch:byt> <dbl> <int>   <bch:tm> <list>                   <list>                <list>  <list>        
1 base()         38.59s   38.59s   38.59s   38.59s    0.0259    27.3GB   308     1     38.59s <data.frame [632,329 x ~ <Rprofmem [43,206 x ~ <bch:t~ <tibble [1 x ~
2 data.table_0   24.65s   24.65s   24.65s   24.65s    0.0406      14GB   159     1     24.65s <data.table [632,329 x ~ <Rprofmem [72,459 x ~ <bch:t~ <tibble [1 x ~
3 jm              1.28s    1.28s    1.28s    1.28s    0.779       75MB     7     1      1.28s <data.table [632,329 x ~ <Rprofmem [2,418 x 3~ <bch:t~ <tibble [1 x ~
4 jm2             1.44s    1.44s    1.44s    1.44s    0.696     62.5MB     9     1      1.44s <data.table [632,329 x ~ <Rprofmem [1,783 x 3~ <bch:t~ <tibble [1 x ~
5 jm3             1.57s    1.57s    1.57s    1.57s    0.636     62.5MB     9     1      1.57s <data.table [632,329 x ~ <Rprofmem [178 x 3]>  <bch:t~ <tibble [1 x ~

数据:

library(data.table)
library(bench)

set.seed(1L)
nr <- 10e6/10
ni <- 10e3/10
df <- data.frame(x = sample(nr, size = nr, replace = TRUE),
    y = sample(ni, size = nr, replace = TRUE))
dt <- data.table(df)
DT0 <- copy(dt)
DT <- copy(dt)
DT2 <- copy(dt)

y_unique <- sort(unique(df$y))
y_list <- setNames(rep(list(list()), length(y_unique)), y_unique)