R如何检查是否在某个包的特定函数中调用了自定义函数

Question

我想创建一个函数myfun，它只能在另一个函数中使用，在我的例子中是dplyrs mutate 或summarise。我更不想依赖dplyrs 内部结构（例如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 一个内部函数和一个 S3 方法 mutate.data.frame - 两者似乎都使获取命名空间变得更加复杂。

再想一想，我想知道是否有更好、更正式的方法来实现相同的结果：只允许在 dplyrs mutate 或 summarise 内调用 myfun。

无论函数如何调用，该方法都应该有效：

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)) 只对导出的函数起作用。

Answer 1

更新：我打算从rlang::trace_back“借用”，因为它似乎有一种优雅（且有效）的方法来确定大部分调用树的完整package::function （有些像%>% 并不总是完全解决）。

（如果你想减少包膨胀......虽然你不太可能有 dplyr 而不是 purrr available，如果你希望在 base 中做同样多的事情尽可能，我提供了#==# 等效的base-R 调用。尝试删除一些rlang 调用当然是可行的，但是再次......如果你假设dplyr，那么你肯定有@ 987654329@ 左右，在这种情况下这应该不是问题。）

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 被定义和调用。）

根据 Rui 的链接，我建议寻找特定函数很可能会错过新函数和/或其他有效但名称不同的函数。 （我没有明确的例子。）从这里开始，考虑寻找特定的包而不是特定的功能。

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

如果您认为它会被不频繁地调用并且您的函数需要“一点时间”，那么半秒的延迟可能不会那么明显，但是对于这个玩具示例，差异是显而易见的。

Answer 2

以上@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

^{由reprex package (v0.3.0) 于 2020-07-13 创建}

对于检查是否从dplyr 中调用函数的特定问题，我想出了一个有效的替代方法，使用对across() 的调用来测试是否从dplyr 中调用myfun()。与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

^{由reprex package (v0.3.0) 于 2020 年 7 月 6 日创建}