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

Я хочу создать функцию 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.

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

  1. mutate
  2. 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)) работает только с экспортированными функциями.

См. также:  вычислить средние и совпадения из нескольких матриц

Придирка: вам не хватает закрытия } в конце функции 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

Понравилась статья? Поделиться с друзьями:
IT Шеф
Комментарии: 2
  1. TimTeaFan

    Обновление: я позаимствую у 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

  2. TimTeaFan

    Выше @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)

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

;-) :| :x :twisted: :smile: :shock: :sad: :roll: :razz: :oops: :o :mrgreen: :lol: :idea: :grin: :evil: :cry: :cool: :arrow: :???: :?: :!: