Переменные в качестве аргументов по умолчанию для функции с использованием dplyr

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 (иначе 2-й аргумент [.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)}]

Это решение имеет 2 нежелательных свойства imo - во-первых, я не уверен, насколько хрупким это 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)))

Недостатки:

1. Мы должны использовать SE mutate_,
2. Для расширенного использования, как в оригинальном примере, мы должны также использовать paste,
3. Это не особенно безопасно, то есть не сразу понятно, где 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

1. Нужно уметь звонить на lag2 без предоставления снаряжения.

Да но нужно пройти .,

2. Нужно уметь использовать lag2 для наборов данных, которые не называются mtcars (но у них есть gear в качестве переменных).

Это работает.

3. Предпочтительно шестерёнка была бы аргументом по умолчанию для функции, поэтому она может быть изменена при необходимости, но это не критично.

Это также работает:

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 (что очень приятно).

добавление

Кажется, трудно избежать использования SE mutate_ как в ответе, заданном OP, чтобы сделать простую хакерскую попытку, как в моем ответе здесь, или сделать что-то более продвинутое, включающее реверс-инжиниринг lazyeval::lazy_dots,

Доказательства:

1) dplyr::lag сам не использует никакой NSE Wizardry

2) mutate просто звонит mutate_(.data, .dots = lazyeval::lazy_dots(...))

Answer 4

Вот мой окончательный ответ, который я фактически использовал. Он в основном опирается на функцию, которая явно вводит любые значения функции по умолчанию в выражения объекта lazy dots.

Полная функция (с комментариями) находится в конце этого ответа.

Ограничения:

• Вам нужно как минимум несколько дополнительных уловок, чтобы сделать это хорошо (см. Ниже).
• Он игнорирует примитивные функции, но я не думаю, что они имеют аргументы функции по умолчанию.
• Для обобщений 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, чтобы сделать это по умолчанию для любого пользовательского класса:

   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)
}

Answer 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 ожидается яснее. Также хорошо сохраняется характер трубопровода, а также автоматическое определение имени новой переменной.

Комментарий: Я почти уверен, что это решение не было доступно, когда вы впервые опубликовали этот вопрос, но, тем не менее, было бы неплохо оставить его здесь для дальнейшего использования.