基于命名列表对 data.table 进行子集化答案

【问题标题】：subsetting a data.table based on a named list基于命名列表对 data.table 进行子集化
【发布时间】：2019-09-07 17:43:48
【问题描述】：

我正在尝试对给定的 data.table 进行子集化

DT <- data.table(
  a = c(1:20),
  b = (3:4),
  c = (5:14),
  d = c(1:4)
)

在一个函数中，通过一个参数是一个命名列表

param <- list(a = 1:10,
              b = 2:3,
              c = c(5, 7, 10))

我可能有点卡在这里，但我当然不想实现像这样丑陋的东西。特别是因为它不是很有活力。

DT[(if (!is.null(param$a))
  a %in% param$a
  else
    TRUE)
  &
    (if (!is.null(param$b))
      b %in% param$b
     else
       TRUE)
  &
    (if (!is.null(param$c))
      c %in%  param$c
     else
       TRUE)
  &
    (if (!is.null(param$d))
      d %in% param$d
     else
       TRUE)]

   a b c d
1: 1 3 5 1
2: 3 3 7 3

任何想法如何在 data.table 或 base R 中使用命名列表的名称以将 data.table 中的相应列与关联值作为子集来以优雅的方式实现这一点？谢谢！

编辑

我对一些答案进行了微基准测试：

func_4 <- function(myp, DT) {
  myp    = Filter(Negate(is.null), param)

  exs = Map(function(var, val)
    call("%in%", var, val),
    var = sapply(names(myp), as.name),
    val = myp)
  exi = Reduce(function(x, y)
    call("&", x, y), exs)
  ex = call("[", x = as.name("DT"), i = exi)
  # eval(as.call(c(as.list(ex))))
  eval(ex)
}

microbenchmark(
  (DT[do.call(pmin, Map(`%in%`, DT[, names(param), with = FALSE], param)) == 1L]),
  (DT[rowSums(mapply(`%in%`, DT[, names(param), with = FALSE], param)) == length(param)]),
  (DT[do.call(CJ, param), on = names(param), nomatch = NULL]),
  (DT[expand.grid(param), on = names(param), nomatch = NULL]),
  (DT[DT[, all(mapply(`%in%`, .SD, param)), by = 1:nrow(DT), .SDcols = names(param)]$V1]),
  (func_4(myp = param, DT = DT)),
  times = 200)

   min        lq      mean   median        uq       max neval
  446.656  488.5365  565.5597  511.403  533.7785  7167.847   200
  454.120  516.3000  566.8617  538.146  561.8965  1840.982   200
 2433.450 2538.6075 2732.4749 2606.986 2704.5285 10302.085   200
 2478.595 2588.7240 2939.8625 2642.311 2743.9375 10722.578   200
 2648.707 2761.2475 3040.4926 2814.177 2903.8845 10334.822   200
 3243.040 3384.6220 3764.5087 3484.423 3596.9140 14873.898   200

【问题讨论】：

标签： r list data.table subset

【解决方案1】：

您可以使用data.table 中的CJ (Cross Join) 函数从列表中制作过滤表。

lookup <- do.call(CJ, param)
head(lookup)
#    a b  c
# 1: 1 2  5
# 2: 1 2  7
# 3: 1 2 10
# 4: 1 3  5
# 5: 1 3  7
# 6: 1 3 10

DT[
    lookup,
    on = names(lookup),
    nomatch = NULL
]
#    a b c d
# 1: 1 3 5 1
# 2: 3 3 7 3

注意nomatch = 0 表示lookup 中不存在于DT 中的任何组合都不会返回一行。

【讨论】：

非常好。但是我可以不改用DT[expand.grid(param), on = names(param), nomatch = NULL] 吗？
@jaydee：是的，CJ 几乎是data.table 的expand.grid 版本。 CJ 的两个好处：它不会将字符串转换为因子，并且可以一致地处理列表输入。查看expand.grid(b = list(1, 2, 3))、expand.grid(a = 1, b = list(1, 2, 3)) 之间的区别以及CJ 如何处理这些输入。

【解决方案2】：

使用Map 我们可以做到

DT[DT[, all(Map(`%in%`, .SD, param)), by = 1:nrow(DT)]$V1]
#   a b c d
#1: 1 3 5 1
#2: 3 3 7 3

对于每一行，我们检查DT 中的所有元素是否存在于param 中。

感谢@Frank，这可以改进为

DT[DT[, all(mapply(`%in%`, .SD, param)), by = 1:nrow(DT), .SDcols=names(param)]$V1]

【讨论】：

谢谢，这可行，但会返回很多警告：... 34: In all(Map(``%in%``, .SD, param)) : coercing argument of type 'list' to logical 35: In mapply(FUN = f, ..., SIMPLIFY = FALSE) : longer argument not a multiple of length of shorter ...

【解决方案3】：

您可以使用call(fun, ...) 和as.name 构建表达式：

myp    = Filter(Negate(is.null), param)

exs = Map(function(var, val) call("%in%", var, val), var = sapply(names(myp), as.name), val = myp)
exi = Reduce(function(x,y) call("&", x, y), exs)
ex = call("[", x = as.name("DT"), i = exi)
# DT[i = a %in% 1:10 & b %in% 2:3 & c %in% c(5, 7, 10)]

eval(ex)
#    a b c d
# 1: 1 3 5 1
# 2: 3 3 7 3

通过正确组合调用，您可以利用 data.table 中“索引”的高效算法（请参阅包 vignettes）。当DT$c 为整数时，您还可以打开详细以获取有关将param$c 指定为数字的低效率的注释：

> z <- as.call(c(as.list(ex), verbose=TRUE))
> eval(z)
Optimized subsetting with index 'c__b__a'
on= matches existing index, using index
Coercing double column i.'c' to integer to match type of x.'c'. Please avoid coercion for efficiency.
Starting bmerge ...done in 0.020sec 
   a b c d
1: 1 3 5 1
2: 3 3 7 3

也就是说，你应该使用c(5L, 7L, 10L)。

在 Nathan 的回答中，连接也使用索引，但如果 prod(lengths(param)) 很大，则在 param 的笛卡尔表上构建和连接成本会很高。

@markus 方法可能会因为逐行操作而变慢，所以这里有一个变体：

DT[do.call(pmin, Map(`%in%`, DT[, names(param), with=FALSE], param)) == 1L]

#    a b c d
# 1: 1 3 5 1
# 2: 3 3 7 3

诀窍在于all 的元素版本是pmin(...) == 1L。同样，any 对应于pmax(...) == 1L。（这就是为什么pany/pall 不包含在 r-devel 上的此对话中：http://r.789695.n4.nabble.com/There-is-pmin-and-pmax-each-taking-na-rm-how-about-psum-td4647841.html）

【讨论】：

【解决方案4】：

我们可以使用names in param 选择DT 中的列，将%in% 应用于每个具有列的列表元素，并仅选择所有值为TRUE 的行。

DT[which(rowSums(mapply(`%in%`, DT[, names(param), with = FALSE],
      param)) == length(param)), ]

#   a b c d
#1: 1 3 5 1
#2: 3 3 7 3

【讨论】：

【解决方案5】：

我正在添加另一个答案，因为 OP 提出的解决方案缺少一个关键细节：每个解决方案如何使用大型数据集进行扩展。我经常使用超过 100 万条记录的数据集，因此为了我自己的利益，我执行了微基准测试实验，OP 使用不同大小的数据集为 pmin + %in% + Map 解决方案和 CJ 解决方案提供，我独立实现的一个版本。尽管前者对于小型数据集的速度明显更快，但后者的扩展性要好得多：

在我看来，相对速度切换的点约为 200k 记录，无论子集的字段数量是多少，因此我将这两个函数打包为一个以供将来使用：

subsel <- function(x, sub, sel = NULL,
                   nomatch = getOption('datatable.nomatch')){
  #' function to subset data.table (x) using a named list (sub). sel
  #' can be used to return only the specified columns. algorithms
  #' copied from https://stackoverflow.com/questions/55728200/subsetting-a-data-table-based-on-a-named-list
  #' and cutoff decided on some ad hoc testing.
  if(is.null(sel)) sel <- names(x)
  if(x[, .N] < 200000L){
    return(
      x[
        do.call(
          pmin,
          Map(`%in%`, x[, .SD, .SDcols = names(sub)], sub)
        ) == 1L,
        .SD,
        .SDcols = sel,
        nomatch = nomatch
      ]
    )
  } else {
    return(
      x[
        do.call(CJ, sub),
        .SD,
        .SDcols = sel,
        on = names(sub),
        nomatch = nomatch
      ]
    )
  }
}

如果有人好奇，这里是用于生成图表的代码：

require(data.table)
require(ggplot)
require(microbenchmark)
require(scales)

subsel <- function(x, sub, nomatch = NULL, sel = list()){
  if(length(sel) == 0) sel <- names(x)
  return(
    x[
      do.call(CJ, sub),
      .SD,
      .SDcols = sel,
      on = names(sub),
      nomatch = nomatch
    ]
  )
}

subsel2 <- function(x, sub, nomatch = NULL, sel = list()){
  if(length(sel) == 0) sel <- names(x)
  return(
    x[
      do.call(
        pmin,
        Map(`%in%`, x[, .SD, .SDcols = names(sub)], sub)
      ) == 1L,
      .SD,
      .SDcols = sel,
      nomatch = nomatch
    ]
  )
}

ll <- list(
  a = letters[1:10],
  b = 1:10,
  c = letters[1:10],
  d = 1:10
)

times <- rbindlist(
  lapply(
    seq(from = 100000, to = 1000000, by = 25000),
    function(y){
      dat <- data.table(
        a = sample(letters, y, replace = T),
        b = sample.int(100, y, replace = T),
        c = sample(letters, y, replace = T),
        d = sample.int(100, y, replace = T)
      )
      return(
        rbindlist(
          lapply(
            2:4,
            function(x){
              return(
                setDT(
                  microbenchmark(
                    subsel(dat, sub = head(ll, x), sel = letters[2:4]),
                    subsel2(dat, sub = head(ll, x), sel = letters[2:4])
                  )
                )[, fields := x]
              )
            }
          )
        )[, size := y]
      )
    }
  )
)

times[
  ,
  expr2 := unlist(
    lapply(
      as.character(expr),
      function(x) unlist(strsplit(x, '(', fixed = T))[1]
    )
  )
]
times[
  ,
  expr2 := factor(
    expr2,
    levels = c('subsel', 'subsel2'),
    labels = c('CJ', 'pmin + Map + %in%')
  )
]

ggplot(times, aes(size, time, group = expr2, color = expr2)) +
  geom_smooth() +
  facet_grid(factor(fields) ~ .) +
  scale_y_continuous(labels = number_format(scale = 1e-6)) +
  labs(
    title = 'Execution Time by Fields to Subset on',
    x = 'Dataset Size',
    y = 'Time (Milliseconds)',
    color = 'Function'
  )

【讨论】：