使用多个变量输入的R自定义data.table函数

3
我正在使用data.table(版本1.9.6)编写自定义聚合函数,并且难以将函数参数传递给它。之前也有类似的问题,但没有一个处理多个(可变)输入并且没有一个确定的答案,而是“小技巧”。
我想对数据表进行求和和排序,并在顶部创建新变量(2步)。关键是一切都应该是参数化的,即要求和的变量,按哪些变量分组,按哪些变量排序。它们都可以是一个或多个变量。下面是一个小例子。
链接: 1.将变量和名称传递给data.table函数 2.data.table中的eval和quote 3.如何在R的data.table中完全通用地使用变量中的列名
dt <- data.table(a=rep(letters[1:4], 5), 
                 b=rep(letters[5:8], 5),
                 c=rep(letters[3:6], 5),
                 x=sample(1:100, 20),
                 y=sample(1:100, 20),
                 z=sample(1:100, 20))

temp <- 
  dt[, .(x_sum = sum(x, na.rm = T),
         y_sum = sum(y, na.rm = T)),
     by = .(a, b)][order(a, b)]

temp2 <- 
  temp[, `:=` (x_sum_del = (x_sum - shift(x = x_sum, n = 1, type = "lag")),
               y_sum_del = (y_sum - shift(x = y_sum, n = 1, type = "lag")),
               x_sum_del_rel = ((x_sum - shift(x = x_sum, n = 1, type = "lag")) /
                                  (shift(x = x_sum, n = 1, type = "lag"))),
               y_sum_del_rel = ((y_sum - shift(x = y_sum, n = 1, type = "lag")) /
                                  (shift(x = y_sum, n = 1, type = "lag")))
               )
       ]

如何以编程方式传递以下函数参数(即不是单个输入而是向量/输入列表):
  • x和y --> var_list
  • x和y的新名称(例如x_sum,y_sum)--> var_name_list
  • 按参数a,b分组 --> by_var_list
  • 按参数a,b排序 --> order_var_list
  • temp 2应该适用于所有预定义参数,我也考虑使用apply函数,但再次无法传递变量列表。

我已经尝试了get(),as.name(),eval(),quote()的变化,但一旦我传递多个变量,它们就不再起作用。 我希望问题很清楚,否则我很乐意在您认为必要的地方进行调整。 函数调用如下:

fn_agg(dt, var_list, var_name_list, by_var_list, order_var_list)

mget如何帮助处理可变输入长度?例如,假设我想对(x, y, z)求和而不仅仅是(x, y),那么当前只接受两个变量的temp表将无法使用。 - Triamus
2个回答

3

看起来这是一个问题 :)
对于我来说,我更喜欢使用语言进行计算,而不是使用get/mget

fn_agg = function(dt, var_list, var_name_list, by_var_list, order_var_list) {
    j_call = as.call(c(
        as.name("."),
        sapply(setNames(var_list, var_name_list), function(var) as.call(list(as.name("sum"), as.name(var), na.rm=TRUE)), simplify=FALSE)
    ))
    order_call = as.call(c(
        as.name("order"),
        lapply(order_var_list, as.name)
    ))
    j2_call = as.call(c(
        as.name(":="),
        c(
            sapply(setNames(var_name_list, paste0(var_name_list,"_del")), function(var) {
                substitute(.var - shift(x = .var, n = 1, type = "lag"), list(.var=as.name(var)))
            }, simplify=FALSE),
            sapply(setNames(var_name_list, paste0(var_name_list,"_del_rel")), function(var) {
                substitute((.var - shift(x = .var, n = 1, type = "lag")) / (shift(x = .var, n = 1, type = "lag")), list(.var=as.name(var)))
            }, simplify=FALSE)
        )
    ))
    dt[eval(order_call), eval(j_call), by=by_var_list
       ][, eval(j2_call)
         ][]
}

ans = fn_agg(dt, var_list=c("x","y"), var_name_list=c("x_sum","y_sum"), by_var_list=c("a","b"), order_var_list=c("a","b"))
all.equal(temp2, ans)
#[1] TRUE

一些额外的注意事项:

  1. 严格执行输入验证,因为针对元编程的调试问题更加困难。
  2. 可以优化第二步骤,因为移位计算多次,简单的方法是在第二步骤中计算_del,在第三步骤中计算_del_rel
  3. 如果order变量总是与by变量相同,则可以将它们放入keyby参数中。

我需要一些时间来消化这个并应用到我的更大的问题上。实际上,我正在尝试在https://github.com/jangorecki/dwtools/上寻找实现的提示,但失败了。 - Triamus
我已经接受了@docendo discimus的答案,因为它更符合我的思维方式,但是你的答案似乎更通用,并且具有优化潜力。我会努力理解并将其应用于我的问题。非常感谢您详尽的回答! - Triamus

1
以下是使用mget选项的示例,如注释所述:
fn_agg <- function(DT, var_list, var_name_list, by_var_list, order_var_list) {

  temp <- DT[, setNames(lapply(.SD, sum, na.rm = TRUE), var_name_list), 
             by = by_var_list, .SDcols = var_list]

  setorderv(temp, order_var_list)

  cols1 <- paste0(var_name_list, "_del")
  cols2 <- paste0(cols1, "_rel")

  temp[, (cols1) := lapply(mget(var_name_list), function(x) {
    x - shift(x, n = 1, type = "lag")
  })]

  temp[, (cols2) := lapply(mget(var_name_list), function(x) {
    xshift <- shift(x, n = 1, type = "lag")
    (x - xshift) / xshift
  })]

  temp[]
}

fn_agg(dt, 
       var_list = c("x", "y"), 
       var_name_list = c("x_sum", "y_sum"), 
       by_var_list = c("a", "b"), 
       order_var_list = c("a", "b"))

#   a b x_sum y_sum x_sum_del y_sum_del x_sum_del_rel y_sum_del_rel
#1: a e   254   358        NA        NA            NA            NA
#2: b f   246   116        -8      -242  -0.031496063    -0.6759777
#3: c g   272   242        26       126   0.105691057     1.0862069
#4: d h   273   194         1       -48   0.003676471    -0.1983471

不必使用mget,你也可以使用data.table.SDcols参数,例如:

temp[, (cols1) := lapply(.SD, function(x) {
    x - shift(x, n = 1, type = "lag")
  }), .SDcols = var_name_list]

此外,可能有一些方法可以通过避免重复计算shift(x, n = 1, type = "lag")来改善函数,但我只是想展示如何在函数中使用data.table。

我需要一些时间来消化这个并与 @jangorecki 的答案进行比较。但是你的实现已经接近我尝试过的东西了,只是缺少了一些部分。关于 lag 函数的效率问题,我同意你的观点,但这不是我的最小关注点 :-) - Triamus

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文,
原文链接