重复子集具有不同条件的数据帧的最快方法？

Question

我有一个如下图所示的数据框（玩具示例）

> dt
 A B C D
1 0 0 0 1
2 0 0 0 1
3 0 1 0 1
4 1 1 0 0
5 1 0 0 1

以及单行数据框列表，如下所示

[[1]]
  A C
1 1 0

[[2]]
  A D
1 0 1

.
.

然后，我需要根据较小的数据帧重复对较大的数据帧 dt 进行子集化，这样对于每个较小的数据帧，我都会得到所有且只有那些与较小数据帧列匹配的列具有的 dt 行与较小数据框中的值匹配的值。所以上面显示的两个小 dfs 的结果应该是一个类似下面的列表，通过子集 dt 或适当地连接 dt 和小数据框来创建：

[[1]]
  A B C D
2 1 0 0 1
5 1 1 0 0

[[2]]
  A B C D
1 0 0 0 1
3 0 0 0 1
4 0 1 0 1

.
.

在研究了关于 SO 和其他地方的类似问题的答案后，我仍然不确定实现这一目标的最快方法是什么。特别是，我已经尝试为此使用 data.table，但我相信我做错了什么，因为我无法让它特别快（对 data.table 来说仍然是新的......）。设置密钥似乎没有那么有用，因为密钥必须反复重置。我也尝试过 dplyr semi_join()，但这对我来说并不比 base 快。下面是一个完整的玩具示例，其中包含一些 cmets 中的基准测试结果。详细的结果并不那么重要——关键是只使用碱基的变体是最快的，我严重怀疑我的尝试是否有例如data.table 是最优的 data.table 解决方案。任何更有效地执行此操作的建议将不胜感激，实际用例涉及多次重复这种子集/连接，目前是主要瓶颈。

library(data.table)
library(dplyr)
library(microbenchmark)
set.seed(1L)

# create toy data frame
dt <- data.frame(A = sample(c(0,1), 5, replace = T), 
                 B = sample(c(0,1), 5, replace = T),
                 C = sample(c(0,1), 5, replace = T),
                 D = sample(c(0,1), 5, replace = T))

#> dt
#   A B C D
# 1 0 0 1 0
# 2 0 1 1 1
# 3 0 0 0 0
# 4 0 0 1 1
# 5 0 1 0 1


# create a list of small toy data frames comprising 1 row 
# and a subset of dt columns (but in same order as in dt)
cvals <- replicate(10, dt[sample(1:nrow(dt), 1), sort(sample(1:length(dt), 2)) ], simplify = FALSE)

# > head(cvals,2)
# [[1]]
#   B D
# 4 0 1
# 
# [[2]]
#   B D
# 4 0 1

### loop over cvals and subset dt to find rows where 
### matching columns have matching values

## base 

# identify which dt columns are found in the cvals df, paste values of those columns
# over all rows, paste cvals df column values, find a match, subset dt with match index
dtsubs_base <- lapply(cvals, function(x)
  dt[which(do.call(paste0, dt[, which(names(dt) %in% names(x))]) %in% do.call(paste0, x)),])

## dplyr
dtsubs_dplyr <- lapply(cvals, function(x) semi_join(dt, x))

## data.table
cvals <- lapply(cvals, as.data.table) #convert to data.tables
dt <- as.data.table(dt) #convert to data table


# attempt 1
# resetting the key at every iteration, which undermines the point of setting a key...
# doing something wrong here
dtsubs_DT1 <- lapply(cvals, function(x){setkeyv(dt, names(x)); return(dt[J(x)])})


# attempt 2
# with 'on ='
dtsubs_DT2 <- lapply(cvals, function(x) dt[x, on = names(x)])

#verify that the results are equal
all(mapply(dplyr::setequal, dtsubs_base, dtsubs_dplyr, dtsubs_DT1, dtsubs_DT2))
#[1] TRUE


###TIMING

##data.table

DT1_bench <- microbenchmark(lapply(cvals, function(x){setkeyv(dt, names(x)); return(dt[J(x)])}))

# Unit: milliseconds
#                                                                 expr     min       lq    mean  median       uq     max neval
# lapply(cvals, function(x) { setkeyv(dt, names(x)) return(dt[J(x)]) }) 22.0109 23.98225 25.7736 25.0835 26.51385 44.8583  100


DT2_bench <- microbenchmark(lapply(cvals, function(x) dt[x, on = names(x)])) # slower than DT attempt 1

# Unit: milliseconds
#                                             expr     min     lq     mean   median     uq     max neval
#  lapply(cvals, function(x) dt[x, on = names(x)]) 25.7943 28.955 30.65348 30.24595 31.862 40.3184   100


##base -- fastest

cvals <- lapply(cvals, as.data.frame) # convert back to data.frames
dt <- as.data.frame(dt)

base_bench <- microbenchmark(lapply(cvals, function(x)
  dt[which(do.call(paste0, dt[, which(names(dt) %in% names(x))]) %in% do.call(paste0, x)),]))
# Unit: microseconds
#                                                                                  expr
#  lapply(cvals, function(x) dt[which(do.call(paste0, dt[, which(names(dt) %in% names(x))]) %in% do.call(paste0, x)), ])
#    min     lq    mean median    uq     max neval
#  706.1 741.65 1067.88 774.95 898.5 10741.9   100

##dplyr

dplyr_bench <- microbenchmark(lapply(cvals, function(x) semi_join(dt, x)))
# Unit: milliseconds
#                                         expr    min      lq     mean median    uq     max neval
#  lapply(cvals, function(x) semi_join(dt, x)) 5.0085 5.60725 6.841974 6.5469 7.683 12.1848   100

Answer 1

我没有得到和你一样的 cval，但是有这个示例数据

set.seed(1L)

dt <- data.frame(A = sample(c(0,1), 5, replace = T), 
                 B = sample(c(0,1), 5, replace = T),
                 C = sample(c(0,1), 5, replace = T),
                 D = sample(c(0,1), 5, replace = T))

cvals <- replicate(10, dt[sample(1:nrow(dt), 1), sort(sample(1:length(dt), 2)) ], simplify = FALSE)

我们可以在 Base-R 中完成任务

lapply(cvals, function(x) dt[apply(dt[,colnames(x)],1, function(y) all(unlist(y) == unlist(x))),])

[[1]]
  A B C D
2 1 0 0 1
5 1 1 0 0

[[2]]
  A B C D
1 0 0 0 1
3 0 0 0 1
4 0 1 0 1

[[3]]
  A B C D
5 1 1 0 0

[[4]]
  A B C D
1 0 0 0 1
2 1 0 0 1
3 0 0 0 1

[[5]]
  A B C D
1 0 0 0 1
2 1 0 0 1
3 0 0 0 1
4 0 1 0 1

[[6]]
  A B C D
1 0 0 0 1
2 1 0 0 1
3 0 0 0 1
4 0 1 0 1

[[7]]
  A B C D
4 0 1 0 1

[[8]]
  A B C D
4 0 1 0 1

[[9]]
  A B C D
1 0 0 0 1
3 0 0 0 1
4 0 1 0 1

[[10]]
  A B C D
2 1 0 0 1