变量作为函数的默认参数，使用 dplyr答案

【问题标题】：Variables as default arguments of a function, using dplyr变量作为函数的默认参数，使用 dplyr
【发布时间】：2016-07-17 04:40:03
【问题描述】：

目标

我的目标是定义一些在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 在dplyr 正在运行的data.frame 中正确找到gear？

应该可以拨打lag2，而无需提供gear。
应该能够在不称为 mtcars 的数据集上使用 lag2（但确实有 gear 作为它的变量之一）。
最好gear 是函数的默认参数，因此如果需要，它仍然可以更改，但这并不重要。

【问题讨论】：

gear 是另一个向量，对吗？您没有将其传递给lag2 的本地环境。试试lag2 <- function(x, gear) {...}（注意，不需要参数n）。
gear 是mtcars 中的一个变量。是的，我搞砸了n 论点。
@Axeman 如果你愿意，我可以建议几种方法，几乎可以让你到达你想要的data.table，但它们都不适用于dplyr
@eddi 总是乐于学习，但我已经非常致力于 (multi)dplyr 这个特定项目。
我从来不明白人们是如何致力于（被困？）在 R 中只使用一个特定的库，该库是专门为使用大量库而设计的。

标签： r dplyr scoping lazyeval

【解决方案1】：

这是data.table 中的两种方法，但我认为目前它们中的任何一种都不适用于dplyr。

在data.table 中，j-expression（又名[.data.table 的第二个参数）中的任何内容都将首先由data.table 包进行解析，而不是由常规R 解析器解析。在某种程度上，您可以将其视为位于常规语言解析器 R 中的单独语言解析器。此解析器的作用是查找您使用的变量实际上是您正在操作的 data.table 的列on，无论找到什么，它都会将其放入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)}]

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

我更喜欢的第二个选项是利用data.table 解析器在变量查找之前之前评估eval 表达式这一事实，因此如果您在内部使用变量你eval 的一些表达方式，会起作用：

lag3 = quote(function(x) lag(x, order_by = gear))

dt[, newvar := eval(lag3)(cyl)]

这没有其他解决方案的问题，明显的缺点是必须输入额外的eval。

【讨论】：

这让我想到也许函数也应该“就地评估”，类似于eval（基本上整个函数表达式复制粘贴到您的表达式中），但这可能会添加一个疯狂的开销（基本上做 R 解析器所做的所有事情，使用 R 函数）并且不值得。

【解决方案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 赋值似乎没问题，但我的猜测是在某些情况下可能会出现意外错误。使用公式而不是字符向量会更安全，但这需要为其分配正确的环境才能工作，这对我来说仍然是一个很大的问号。

【讨论】：

【解决方案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（但确实有齿轮作为它的变量之一）。

这行得通。

gear 最好是函数的默认参数，因此仍可以根据需要进行更改，但这并不重要。

这也有效：

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_，像我在这里的回答中那样做一些简单的骇客操作，或者做一些涉及逆向工程 lazyeval::lazy_dots 的更高级的事情。

证据：

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

2) mutate 只需调用mutate_(.data, .dots = lazyeval::lazy_dots(...))

【讨论】：

这也是一个很好的解决方案，让我再考虑一下。字符向量的传递没有问题，因为这是可以修复的。
谢谢！我正在尝试自己了解 NSE，但在注意到我的附录后的事实后，我感到很绝望。这是一个真正的挑战。如果很容易更改，请随时编辑（或评论，我会编辑），所以只需 gear 可以通过。我不确定该怎么做
看看我的答案以找到解决方案：)
哈！我应该更仔细地阅读。那么，lag3 <- function(x, df, n = 1L, order_by=gear, ...) { order_by <- deparse(substitute(order_by)) lag(x, n = n, order_by = df[[order_by]], ...) }?但是，尽管这适用于第一种情况，但在第三种情况下却失败了：mutate(cyl_change = cyl != lag3(cyl, ., order_by = cyl)) evals cyl 到 c(6, 6, 4, 6, 8, 6, 8, 4, 4, 6, 6, 8, 8, 8, 8, 8, 8, 4, 4, 4, 4, 8, 8, 8, 8, 4, 4, 4, 8, 6, 8, 4))。 :\
好的，我现在已经解决了这个小问题（并进行了编辑）。我认为这是我将得到的最佳答案，而且非常接近完美！

【解决方案4】：

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

完整的功能（带有 cmets）在这个答案的末尾。

限制：

您至少需要一些额外的技巧才能很好地完成这项工作（见下文）。
它会忽略原始函数，但我认为这些函数没有默认函数参数。
对于 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)
}

【讨论】：

【解决方案5】：

您也可以通过以下方式解决您的问题：

library(dplyr)

lag2 <- function(df, x, n = 1L, order_by = gear) {
  order_var <- enquo(order_by)
  x <- enquo(x)
  var_name <- paste0(quo_name(x), "_change")

  df %>% 
    mutate(!!var_name := lag(!!x, n = n, order_by = !!order_var))
}

mtcars %>%
  lag2(cyl)

# A tibble: 32 x 12
#      mpg   cyl  disp    hp  drat    wt  qsec    vs    am  gear  carb cyl_change
#    <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>      <dbl>
#  1  21       6  160    110  3.9   2.62  16.5     0     1     4     4          8
#  2  21       6  160    110  3.9   2.88  17.0     0     1     4     4          6
#  3  22.8     4  108     93  3.85  2.32  18.6     1     1     4     1          6
#  4  21.4     6  258    110  3.08  3.22  19.4     1     0     3     1         NA
#  5  18.7     8  360    175  3.15  3.44  17.0     0     0     3     2          6
#  6  18.1     6  225    105  2.76  3.46  20.2     1     0     3     1          8
#  7  14.3     8  360    245  3.21  3.57  15.8     0     0     3     4          6
#  8  24.4     4  147.    62  3.69  3.19  20       1     0     4     2          4
#  9  22.8     4  141.    95  3.92  3.15  22.9     1     0     4     2          4
# 10  19.2     6  168.   123  3.92  3.44  18.3     1     0     4     4          4
# ... with 22 more rows

我知道，必须再次在函数中传递数据帧，但这样一来，gear 的预期环境就更清晰了。管道性质也得到了很好的保留，并且自动定义了新变量的名称。

评论：当您第一次发布此问题时，我很确定此解决方案不可用，但最好将其保留在此处以供将来参考。

【讨论】：