17

目标

我的目标是定义一些在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))

问题

有没有办法在正在运行的 data.frame 中lag2正确找到?geardplyr

  • 一个人应该能够打电话lag2而无需提供gear
  • 应该能够lag2在未调用的数据集上使用mtcars(但确实具有gear它的变量)。
  • 最好gear是函数的默认参数,因此如果需要,它仍然可以更改,但这并不重要。
4

5 回答 5

10

这是 中的两种方法data.table,但是我不相信它们中的任何一种dplyr目前都可以使用。

data.table中,j-expression(也就是 的第二个参数)中的任何内容都会首先[.data.table包解析,而不是由常规的 R 解析器解析。在某种程度上,您可以将其视为位于 R 的常规语言解析器中的单独语言解析器。此解析器的作用是查找您使用的变量实际上是您正在操作的列,以及无论它找到什么,它都会将其置于.data.tabledata.tablej-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)- 你把这个东西放在一个函数或一个包中,我不知道会发生什么。您可能可以解决它并找出正确的框架,但这有点痛苦。其次 - 您要么必须在表达式中的任何位置提及您感兴趣的特定变量,要么在任何.SD地方再次使用 , 将它们全部转储到环境中。

我更喜欢的第二个选项是利用data.table解析器在变量查找之前eval对表达式进行评估的事实,因此,如果您在某个表达式中使用变量 you ,那将起作用:eval

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

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

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

于 2016-04-01T15:56:19.593 回答
4

这个解决方案即将结束:

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

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

我们仍然使用lag和它的order_by参数,但不要用它做任何进一步的计算。我们没有坚持使用 SE mutate,而是切换到 NSEmutate_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)))

缺点:

  1. 我们必须使用 SE mutate_
  2. 对于原始示例中的扩展用法,我们还需要使用paste.
  3. 这不是特别安全,即不清楚gear应该从哪里来。gear在全局环境中或在全局环境中分配值carb似乎没问题,但我的猜测是在某些情况下可能会出现意外错误。使用公式而不是字符向量会更安全,但这需要为其分配正确的环境才能工作,这对我来说仍然是一个很大的问号。
于 2016-04-01T08:23:40.027 回答
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
  1. 一个人应该能够调用 lag2 而无需提供装备。

是的,但您需要通过..

  1. 人们应该能够在不称为 mtcars 的数据集上使用 lag2(但确实有齿轮作为它的变量之一)。

这行得通。

  1. 最好 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

附录

似乎很难避免mutate_像 OP 提出的答案那样使用 SE,像我在这里的答案中那样做一些简单的骇客,或者做一些涉及逆向工程的更高级的事情lazyeval::lazy_dots

证据:

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

2)mutate简单地调用mutate_(.data, .dots = lazyeval::lazy_dots(...))

于 2016-04-04T22:09:54.757 回答
1

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

完整的功能(带注释)在这个答案的末尾。

限制:

  • 您至少需要一些额外的技巧才能很好地完成这项工作(见下文)。
  • 它忽略了原始函数,但我认为这些函数没有默认函数参数。
  • 对于 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))
  1. mutate_直接使用dots

    dots <- lazyeval::all_dots(cyl_change = ~cyl != lag2(cyl), all_named = TRUE)
    dots <- add_defaults_to_dots(dots)
    mtcars %>% mutate_(.dots = dots)
    
  2. 重新定义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))
    
  3. 使用 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)
}
于 2016-12-27T18:06:17.937 回答
1

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

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预期的环境会更清晰。管道特性也得到了很好的保留,并且自动定义了新变量的名称。

评论:我很确定当您第一次发布此问题时此解决方案不可用,但是将其保留在这里以供将来参考可能会很好。

于 2018-05-12T09:54:16.607 回答