R Как проверить, вызывается ли пользовательская функция внутри определенной функции из определенного пакета

05.07.2020Рубрика: ВопросыАвтор: admin

Я хочу создать функцию myfun, которую можно использовать только внутри другой функции, в моем случае dplyrs mutate или summarise. Я больше не хочу полагаться на dplyrс внутренностями (например mask$...).

Я придумал быстрый и грязный обходной путь: функция search_calling_fn, которая проверяет все имена функций в стеке вызовов и ищет определенный шаблон в вызывающих функциях.

search_calling_fn <- function(pattern) {
  
  call_st <- lapply(sys.calls(), `[[`, 1)
  
  res <- any(unlist(lapply(call_st, function(x) grepl(pattern, x, perl = TRUE))))
  
  if (!res) {
    stop("`myfun()` must only be used inside dplyr::mutate or dplyr::summarise")
  } else {
    return()
  }
}

Это работает, как и ожидалось, как показано в двух приведенных ниже примерах (dplyr = 1.0.0).

library(dplyr)

myfun <- function() {
  search_calling_fn("^mutate|^summarise")
  NULL
}

# throws as expected no error
mtcars %>% 
  mutate(myfun())


myfun2 <- function() {
  search_calling_fn("^select")
  NULL
}

# throws as expected an error
mtcars %>% 
  mutate(myfun2())

В этом подходе есть одна лазейка: myfun можно вызывать из функции с похожим именем, которая не является функцией dplyr. Интересно, как я могу проверить, из какого пространства имен приходит функция в моем стеке вызовов. rlang имеет функцию call_ns, но она будет работать только в том случае, если функция явно вызывается с package::.... Кроме того, при использовании mutate в стеке вызовов есть mutate_cols внутренняя функция и mutate.data.frame метод S3 — кажется, что оба делают получение пространства имен еще более сложным.

С другой стороны, мне интересно, есть ли лучший, более официальный подход для достижения того же результата: разрешить вызов myfun только в пределах dplyrs mutate или summarise.

Подход должен работать независимо от того, как вызывается функция:

mutate
dplyr::mutate

Дополнительное примечание

После обсуждения ответа @r2evans я понимаю, что решение должно пройти следующий тест:

library(dplyr)

myfun <- function() {
  search_calling_fn("^mutate|^summarise")
  NULL
}

# an example for a function masking dplyr's mutate
mutate <- function(df, x) {
  NULL
}

# should throw an error but doesn't
mtcars %>% 
  mutate(myfun())

Таким образом, функция проверки должна не только смотреть на стек вызовов, но и пытаться увидеть, из какого пакета исходит функция в стеке вызовов. Интересно, что отладчик RStudios показывает пространство имен для каждой функции в стеке вызовов, даже для внутренних функций. Интересно, как он это делает, ведь environment(fun)) работает только с экспортированными функциями.

См. также: как запросить запрос на вытягивание с определенного пульта в git?

Придирка: вам не хватает закрытия } в конце функции search_calling_fn. — person TimTeaFan schedule 06.07.2020

Спасибо, что заметили это! Я исправил это. — person TimTeaFan schedule 06.07.2020

Связано: 1 и 2. — person TimTeaFan schedule 06.07.2020

Ваш пример кода mutate никогда не даст сбоев, потому что x ленив; поскольку он никогда не используется, он никогда не реализуется, поэтому myfun никогда не вызывается. … но я понимаю вашу точку зрения, getAnywhere в моем ответе слишком нетерпелив. — person TimTeaFan schedule 08.07.2020

Post Views: 105

2 callstack dplyr function r rlang

Комментарии: 2

TimTeaFan 05.07.2020 в 00:00
Обновление: я позаимствую у rlang::trace_back, так как у него есть элегантный (и работающий) метод определения полного package::function для большей части дерева вызовов (некоторые, например, %>%, не всегда полностью- решено).

(Если вы пытаетесь уменьшить раздувание пакета… хотя маловероятно, что у вас будет dplyr, а не purrr доступен, если вы предпочитаете делать как можно больше в базе, я предоставил #==# эквивалентные вызовы base-R. Безусловно, можно попытаться удалить некоторые из вызовов rlang, но опять же… если вы предполагаете dplyr, то у вас определенно есть rlang, и в этом случае это не должно быть проблемой.)
```
search_calling_pkg <- function(pkgs, funcs) {
  # <borrowed from="rlang::trace_back">
  frames <- sys.frames()
  idx <- rlang:::trace_find_bottom(NULL, frames)
  frames <- frames[idx]
  parents <- sys.parents()[idx]
  calls <- as.list(sys.calls()[idx])
  calls <- purrr::map(calls, rlang:::call_fix_car)
  #==# calls <- lapply(calls, rlang:::call_fix_car)
  calls <- rlang:::add_pipe_pointer(calls, frames)
  calls <- purrr::map2(calls, seq_along(calls), rlang:::maybe_add_namespace)
  #==# calls <- Map(rlang:::maybe_add_namespace, calls, seq_along(calls))
  # </borrowed>
  calls_chr <- vapply(calls, function(cl) as.character(cl)[1], character(1))
  ptn <- paste0("^(", paste(pkgs, collapse = "|"), ")::")
  pkgres <- any(grepl(ptn, calls_chr))
  funcres <- !missing(funcs) && any(mapply(grepl, paste0("^", funcs, "$"), list(calls_chr)))
  if (!pkgres || !funcres) {
    stop("not correct")
  } else return()
}
```
Цель состоит в том, чтобы вы могли искать определенные пакеты и/или определенные функции. Аргумент funcs= может быть фиксированной строкой (принимаемой дословно), но, поскольку я подумал, что вы, возможно, захотите сопоставить любую из функций mutate* (и т. д.), вы также можете сделать его регулярным выражением. Все функции должны быть полными package::funcname, а не только funcname (хотя вы, конечно, можете сделать это регулярным выражением :-).
```
myfun1 <- function() {
  search_calling_pkg(pkgs = "dplyr")
  NULL
}
myfun2 <- function() {
  search_calling_pkg(funcs = c("dplyr::mutate.*", "dplyr::summarize.*"))
  NULL
}
mutate <- function(df, x) { force(x); NULL; }
```
```
mtcars[1:2,] %>% mutate(myfun1())
# Error: not correct

mtcars[1:2,] %>% dplyr::mutate(myfun1())
#   mpg cyl disp  hp drat    wt  qsec vs am gear carb
# 1  21   6  160 110  3.9 2.620 16.46  0  1    4    4
# 2  21   6  160 110  3.9 2.875 17.02  0  1    4    4

mtcars[1:2,] %>% mutate(myfun2())
# Error: not correct

mtcars[1:2,] %>% dplyr::mutate(myfun2())
#   mpg cyl disp  hp drat    wt  qsec vs am gear carb
# 1  21   6  160 110  3.9 2.620 16.46  0  1    4    4
# 2  21   6  160 110  3.9 2.875 17.02  0  1    4    4
```
И производительность, кажется, значительно лучше, чем в первом ответе, хотя все же не нулевой удар по производительности:
```
microbenchmark::microbenchmark(
  a = mtcars %>%
  dplyr::mutate(),
  b = mtcars %>%
  dplyr::mutate(myfun1())
)
# Unit: milliseconds
#  expr    min     lq     mean  median      uq     max neval
#     a 1.5965 1.7444 1.883837 1.82955 1.91655  3.0574   100
#     b 3.4748 3.7335 4.187005 3.92580 4.18140 19.4343   100
```
(Эта часть сохранена для процветания, хотя обратите внимание, что getAnywhere найдет dplyr::mutate, даже если указанный выше не-dplyr mutate определен и вызван.)

Посеянный ссылками Руи, я предполагаю, что поиск определенных функций может очень хорошо пропустить новые функции и/или допустимые, но другие функции с другими именами. (У меня нет четкого примера.) Отсюда рассмотрите возможность поиска конкретных пакетов вместо конкретных функций.
```
search_calling_pkg <- function(pkgs) {
  call_st <- lapply(sys.calls(), `[[`, 1)
  res <- any(vapply(call_st, function(ca) any(pkgs %in% tryCatch(getAnywhere(as.character(ca)[1])$where, error=function(e) "")), logical(1)))
  if (!res) {
    stop("not called from packages")
  } else return()
}
myfun <- function() {
  search_calling_pkg("package:dplyr")
  NULL
}
```
Поймите, что это не дешевая операция. Я считаю, что большая часть времени, потраченного на это, связана с деревом вызовов, возможно, это не то, что мы можем легко исправить.
```
microbenchmark::microbenchmark(
  a = mtcars %>% mutate(),
  b = mtcars %>% mutate(myfun())
)
# Unit: milliseconds
#  expr        min         lq       mean     median        uq        max neval
#     a   1.872101   2.165801   2.531046   2.312051   2.72835   4.861202   100
#     b 546.916301 571.909551 603.528225 589.995251 612.20240 798.707300   100
```
Если вы считаете, что она будет вызываться нечасто и ваша функция занимает немного времени, то, возможно, задержка в полсекунды будет не так заметна, но с этим игрушечным примером разница ощутима.

Спасибо! Вы правы, в общем случае мы не должны проверять имена функций и полагаться только на проверку происхождения функции. Для моего случая dplyr я придумал две альтернативы (см. ниже). — person TimTeaFan; 06.07.2020

Хотя мне нравится этот подход, я только что понял, что на самом деле это не проверка пакета функции в стеке вызовов. Он просто ищет имя функции во всех загруженных пространствах имен. Таким образом, если dplyr загружен, но функция mutate замаскирована другой функцией, вызов myfun() внутри не-dplyr mutate не приведет к ошибке. — person TimTeaFan; 07.07.2020

Я не согласен с вашим утверждением, что он ищет во всех загруженных пространствах имен. В частности, если я делаю library(dplyr), я могу выполнить mutate(mtcars, myfun()) без ошибок, а transform(mtcars, myfun()) выдает ошибку, несмотря на то, что dplyr явно находится в пути поиска. Точно так же transform(mutate(mtcars), myfun()) терпит неудачу, так как не находит dplyr в прямой цепочке вызовов. С чего вы взяли, что это просто поиск загруженных пространств имен? — person TimTeaFan; 08.07.2020

Я хотел сказать, что search_calling_pkg просматривает стек вызовов и для каждого имени функции, которое он находит, он ищет, где (getAnywhere) он может его найти, и это включает все загруженные пространства имен, потому что если вы mutate <- function(df, x) {NULL}, а затем вызовете mutate(myfun()) в то время как dplyr привязан к пути поиска myfun() не выдаст ошибку, хотя вы не звоните dplyr’у mutate. — person TimTeaFan; 08.07.2020

Интересно, что отладчик в RStudio покажет пространство имен для каждой функции в стеке вызовов даже для внутренних функций. Интересно, как он получает эту информацию. environment(fun)) например работает только с экспортированными функциями. — person TimTeaFan; 08.07.2020

Ваш пример transform(mutate(mtcars), myfun()) выдает ошибку, потому что при вызове myfun() mutate() нет в стеке вызовов. Но в моем примере myfun() находит mutate в стеке вызовов, но не видит, что это неправильный mutate, потому что перечислены все загруженные пакеты и пространства имен, в которых есть функция с именем mutate. — person TimTeaFan; 08.07.2020

Это лишний повод предположить, что моя функция работает, не так ли? Возможно, я не понимаю ваших намерений со всем этим (на самом деле, я не понимаю предпосылку, стоящую за требованием вызова функции внутри одной из функций dplyr). Было бы полезно привести четкие примеры, где должна возникать ошибка, а где не должна (поскольку я думаю, что запутался). — person TimTeaFan; 08.07.2020

Я обновил свой вопрос дополнительным примечанием, надеюсь, это прояснит мою точку зрения. — person TimTeaFan; 08.07.2020

Спасибо за обновленный ответ, это отлично работает. Если невозможно использовать внутренние компоненты rlang (например, в пакете), то лучшим вариантом, вероятно, будет проверка пространства имен только с помощью rlang::env_name(environment(fun = ...)) (см. мой обновленный ответ ниже). — person TimTeaFan; 13.07.2020
Ответить

TimTeaFan 05.07.2020 в 00:00

Выше @r2evans показывает, как можно решить общий вопрос о том, как проверить, вызывается ли функция из другого package::function().

Если кто-то не хочет полагаться на внутренние функции rlang, возможным обходным путем является использование rlang::env_name(environment(fun = ...)), однако в этом случае можно проверить только пространство имен/пакет вызывающей функции, а не имя функции:

library(dplyr)
library(rlang)

check_pkg <- function(pkg) {
  
  call_st <- sys.calls()
  
  res <- lapply(call_st, function(x) {
    
    .x <- x[[1]]
    
    tryCatch({
          rlang::env_name(environment(fun = eval(.x)))
        }, error = function(e) {
        NA
        })
    
  })
    
   if (!any(grepl(pkg, res, perl = TRUE))) {
      stop("`myfun()` must only be used inside dplyr verbs")
   }  
  
}


myfun1 <- function() {
  check_pkg("namespace:dplyr")
  NULL
}

custom_fc <- mutate

mutate <- function(df, x) { force(x); NULL; }

mtcars[1:2,] %>% mutate(myfun1())
#> Error in check_pkg("namespace:dplyr"): `myfun()` must only be used inside dplyr verbs

mtcars[1:2,] %>% dplyr::mutate(myfun1())
#>   mpg cyl disp  hp drat    wt  qsec vs am gear carb
#> 1  21   6  160 110  3.9 2.620 16.46  0  1    4    4
#> 2  21   6  160 110  3.9 2.875 17.02  0  1    4    4

mtcars[1:2,] %>% custom_fc(myfun1())
#>   mpg cyl disp  hp drat    wt  qsec vs am gear carb
#> 1  21   6  160 110  3.9 2.620 16.46  0  1    4    4
#> 2  21   6  160 110  3.9 2.875 17.02  0  1    4    4

^{Создано 13 июля 2020 г. в пакете reprex (v0.3.0)}

Для моей конкретной проблемы, чтобы проверить, вызывается ли функция из dplyr, я придумал эффективную альтернативу, используя вызов across() в качестве теста, вызывается ли myfun() из dplyr. В отличие от mask$... и т. д. across() является экспортируемой функцией dplyr.

library(dplyr)
library(rlang)

check_calling_fn <- function() {
  tryCatch({
    dplyr::across()
  }, error = function(e) {
    rlang::abort("`myfun()` must only be used inside dplyr verbs")
  })
}
  

myfun <- function() {
  check_calling_fn()
  NULL
}

microbenchmark::microbenchmark(
a = mtcars %>% dplyr::mutate(myfun()),
b = mtcars %>% dplyr::mutate()
)
#> Unit: milliseconds
#>  expr      min       lq     mean   median       uq       max neval
#>     a 2.580255 2.800734 3.783082 3.105146 3.754433 21.043388   100
#>     b 1.317511 1.393168 1.713831 1.494754 1.763758  5.645019   100

myfun()
#> Error: `myfun()` must only be used inside dplyr verbs

^{Создано 06 июля 2020 г. с помощью пакета reprex (v0.3.0)}

Ответить

Добавить комментарий