Question

目标

我的目标是定义一些在dplyr动词中使用的函数，这些函数使用预定义的变量。这是因为我有一些这些函数带有一堆参数，其中很多都是相同的变量名。

我的理解：这很困难（也许是不可能的）因为dplyr稍后将懒惰地评估用户指定的变量，但是任何默认参数都不在函数调用中，因此dplyr不可见。

玩具示例

考虑以下示例，我使用dplyr来计算变量是否已更改（在这种情况下无意义）：

library(dplyr)
mtcars  %>%
  mutate(cyl_change = cyl != lag(cyl))

现在，lag也支持备用排序，如下所示：

mtcars  %>%
  mutate(cyl_change = cyl != lag(cyl, order_by = gear))

但是，如果我想创建自己的lag版本，并始终按gear排序，该怎么办？

尝试失败

天真的做法是：

lag2 <- function(x, n = 1L, order_by = gear) lag(x, n = n, order_by = order_by)

mtcars %>%
  mutate(cyl_change = cyl != lag2(cyl))

但这显然引发了错误：

没有找到名为'gear'的对象

更实际的选择是这些，但它们也不起作用：

lag2 <- function(x, n = 1L) lag(x, n = n, order_by = ~gear)
lag2 <- function(x, n = 1L) lag(x, n = n, order_by = get(gear))
lag2 <- function(x, n = 1L) lag(x, n = n, order_by = getAnywhere(gear))
lag2 <- function(x, n = 1L) lag(x, n = n, order_by = lazyeval::lazy(gear))

问题

有没有办法让lag2在gear正在运作的data.frame中正确找到dplyr？

一个人应该可以致电lag2而无需提供gear。
应该可以对未调用lag2的数据集使用mtcars（但确实有gear作为变量）。
最好gear是函数的默认参数，因此如果需要，它仍然可以更改，但这并不重要。

Answer 1

data.table中有两种方法，但我不相信它们中的任何一种都可以在dplyr中使用。

在data.table中，j-expression内的任何内容（又称[.data.table的第二个参数）首先通过 data.table包解析，而不是常规的R解析器。在某种程度上，您可以将其视为一个独立的语言解析器，它位于常规语言解析器R中。这个解析器的作用是，它查找您使用的哪些变量实际上是data.table你的列的列重新开始操作，无论它发现什么，它都将它置于j-expression的环境中。

这意味着，您必须让这个解析器以某种方式知道gear将被使用，或者它根本不会成为环境的一部分。以下是实现这一目标的两个想法。

执行此操作的“简单”方法是实际使用j-expression中您调用lag2的列名称（除了lag2内的一些编辑）：

dt = as.data.table(mtcars) lag2 = function(x) lag(x, order_by = get('gear', sys.frame(4))) dt[, newvar := {gear; lag2(cyl)}] # or dt[, newvar := {.SD; lag2(cyl)}]

这个解决方案有两个不受欢迎的属性 - 首先，我不确定sys.frame(4)是多么脆弱 - 你把这个东西放在一个函数或一个包中，我不知道会发生什么。你可以解决它并弄清楚正确的框架，但这是一种痛苦。其次 - 您要么必须在表达式中提及您感兴趣的特定变量，任何地方，要么再次使用.SD将其全部转储到环境中。

我更喜欢的第二个选项是利用data.table解析器评估eval表达式之前变量查找的事实，所以如果你在eval的某个表达式中使用一个变量，它可以起作用：

lag3 = quote(function(x) lag(x, order_by = gear)) dt[, newvar := eval(lag3)(cyl)]

这不会受到其他解决方案的影响，明显的缺点是必须输入额外的eval。

Answer 2

这个解决方案即将结束：

考虑一个稍微简单的玩具示例：

mtcars %>%
  mutate(carb2 = lag(carb, order_by = gear))

我们仍然使用lag及其order_by参数，但不进行任何进一步的计算。我们不是坚持使用SE mutate，而是切换到NSE mutate_并使lag2将函数调用构建为字符向量。

lag2 <- function(x, n = 1, order_by = gear) {
  x <- deparse(substitute(x))
  order_by <- deparse(substitute(order_by))
  paste0('dplyr::lag(x = ', x, ', n = ', n, ', order_by = ', order_by, ')')
}

mtcars %>%
  mutate_(carb2 = lag2(carb))

这给我们提供了与上述相同的结果。

可以通过以下方式实现原始玩具示例：

mtcars %>%
  mutate_(cyl_change = paste('cyl !=', lag2(cyl)))

缺点：

我们必须使用SE mutate_。
对于原始示例中的扩展使用，我们还需要使用paste。
这不是特别安全，即不能立即清楚gear应该来自哪里。在全局环境中将值分配给gear或carb似乎没问题，但我猜测在某些情况下会出现意外错误。使用公式而不是字符向量会更安全，但这需要为其分配正确的环境才能工作，这对我来说仍然是个大问号。

Answer 3

这不是很优雅，因为它需要额外的参数。但是，通过传递整个数据框架，我们几乎可以获得所需的行为

lag2 <- function(x, df, n = 1L, order_by = df[['gear']], ...) {
  lag(x, n = n, order_by = order_by, ...)
}

hack <- mtcars  %>%  mutate(cyl_change = cyl != lag2(cyl, .))
ans <- mtcars  %>%  mutate(cyl_change = cyl != lag(cyl, order_by = gear))
all.equal(hack, ans)
# [1] TRUE

一个人应该能够在不提供装备的情况下调用lag2。

是的，但您需要通过.。

应该能够在未被称为mtcars的数据集上使用lag2（但确实将齿轮作为其变量之一）。

这很有效。

齿轮最好是该功能的默认参数，因此如果需要，它仍然可以更改，但这并不重要。

这也有效：

hack_nondefault <- mtcars %>%  mutate(cyl_change = cyl != lag2(cyl, order_by = cyl))
ans_nondefault <- mtcars %>%  mutate(cyl_change = cyl != lag(cyl, order_by = cyl))
all.equal(hack_nondefault, ans_nondefault)
# [1] TRUE

请注意，如果您手动提供order_by，则不再需要使用df指定.，并且使用情况与原始lag相同（这非常好）

<强>附录

似乎很难避免在OP提出的答案中使用SE mutate_，在我的答案中做一些简单的hackery，或者做一些涉及逆向工程的更高级lazyeval::lazy_dots

证据：

1）dplyr::lag本身不使用任何NSE魔法

2）mutate只需拨打mutate_(.data, .dots = lazyeval::lazy_dots(...))

Answer 4

这是我最终使用的最终答案。它从根本上依赖于一个函数，该函数将任何默认函数值显式地注入到惰性点对象的表达式中。

完整的功能（带注释）在本答案的最后。

限制：

你需要至少一些额外的技巧来使这项工作很好（见下文）。
它忽略了原始函数，但我认为它们没有默认的函数参数。
对于S3泛型，应该使用实际方法。例如seq.default而不是seq。如果目标是在您自己的函数中注入默认值，那么这通常不会有太大问题。

例如，可以像这样使用此函数：

dots <- lazyeval::all_dots(a = ~x, b = ~lm(y ~ x, data = d))
add_defaults_to_dots(dots)

$a
<lazy>
  expr: x
  env:  <environment: R_GlobalEnv>

$b
<lazy>
  expr: lm(formula = y ~ x, data = d, subset = , weights = , na.action = ,  ...
  env:  <environment: R_GlobalEnv>

我们可以通过多种方式解决问题中的玩具问题。记住新功能和理想用例：

lag2 <- function(x, n = 1L, order_by = gear) lag(x, n = n, order_by = order_by)

mtcars %>%
  mutate(cyl_change = cyl != lag2(cyl))

直接与mutate_一起使用dots：

dots <- lazyeval::all_dots(cyl_change = ~cyl != lag2(cyl), all_named = TRUE)
dots <- add_defaults_to_dots(dots)
mtcars %>% mutate_(.dots = dots)

重新定义mutate以添加默认值。

mutate2 <- function(.data, ...) {
  dots <- lazyeval::lazy_dots(...)
  dots <- add_defaults_to_dots(dots)
  dplyr::mutate_(.data, .dots = dots)
}

mtcars %>% mutate2(cyl_change = cyl != lag2(cyl))

使用S3 dispatch将其作为任何自定义类的默认值：

mtcars2 <- mtcars
class(mtcars2) <- c('test', 'data.frame')

mutate_.test <- function(.data, ..., .dots) {
  dots <- lazyeval::all_dots(.dots, ..., all_named = TRUE)
  dots <- add_defaults_to_dots(dots)
  dplyr::mutate_(tibble::as_tibble(.data), .dots = dots)
}
mtcars2 %>% mutate(cyl_change = cyl != lag2(cyl))

根据用例，选项2和3是实现这一目标的最佳方法。选项3实际上具有完整的建议用例，但确实依赖于额外的S3类。

功能：

add_defaults_to_dots <- function(dots) {
  # A recursive function that continues to add defaults to lower and lower levels.
  add_defaults_to_expr <- function(expr) {
    # First, if a call is a symbol or vector, there is nothing left to do but
    # return the value (since it is not a function call).
    if (is.symbol(expr) | is.vector(expr) | class(expr) == "formula") {
      return(expr)
    }
    # If it is a function however, we need to extract it.
    fun <- expr[[1]]
    # If it is a primitive function (like `+`) there are no defaults, and we
    # should not manipulate that call, but we do need to use recursion for cases
    # like a + f(b).
    if (is.primitive(match.fun(fun))) {
      new_expr <- expr
    } else {
      # If we have an actual non-primitive function call, we formally match the
      # call, so abbreviated arguments and order reliance work.
      matched_expr <- match.call(match.fun(fun), expr, expand.dots = TRUE)
      expr_list <- as.list(matched_expr)
      # Then we find the default arguments:
      arguments <- formals(eval(fun))
      # And overwrite the defaults for which other values were supplied:
      given <- expr_list[-1]
      arguments[names(given)] <- given
      # And finally build the new call:
      new_expr <- as.call(c(fun, arguments))
    }
    # Then, for all function arguments we run the function recursively.
    new_arguments <- as.list(new_expr)[-1]
    null <- sapply(new_arguments, is.null)
    new_arguments[!null] <- lapply(new_arguments[!null], add_defaults_to_expr)
    new_expr <- as.call(c(fun, new_arguments))
    return(new_expr)
  }
  # For lazy dots supplied, separate the expression and environments.
  exprs <- lapply(dots, `[[`, 'expr')
  envrs <- lapply(dots, `[[`, 'env')
  # Add the defaults to the expressions.
  new_exprs <- lapply(exprs, add_defaults_to_expr)
  # Add back the correct environments.
  new_calls <- Map(function(x, y) {
    lazyeval::as.lazy(x, y)
  }, new_exprs, envrs)
  return(new_calls)
}

使用dplyr

目标

玩具示例

尝试失败

问题

4 个答案:

缺点：