R如何检查自定义函数是否在某个包的特定函数中被调用
R How to check that a custom function is called within a specific function from a certain package
我想创建一个只能在另一个函数内部使用的函数 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 在 dplyr 秒内调用 mutate 或 summarise.
无论函数如何调用，该方法都应该有效：
mutatedplyr::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())
所以检查函数不仅要看callstack，还要看callstack上的函数是从哪个包来的。有趣的是，RStudios 调试器显示调用堆栈上每个函数的命名空间，甚至是内部函数。我想知道它是怎么做到的，因为 environment(fun)) 仅适用于导出函数。
Update：我要从 rlang::trace_back“借用”，因为它似乎有一个优雅的（有效的）方法来确定完整的 package::function 对于大多数调用树（有些像 %>% 并不总是完全解析）。
（如果你想减少包膨胀......虽然你不太可能有 dplyr 而不是 purrr available，如果你更愿意在 base 中做尽可能多的事情，我已经提供了 #==# 等效的 base-R 调用。尝试删除一些 rlang 调用当然是可行的，但是再次......如果你假设 dplyr，那么你肯定有 rlang，在这种情况下这应该不是问题。）
EDIT (2022-02-25): the function below uses ::: functions in rlang, which (not surprisingly) no longer exist as of today, as a clear example of why using :::-funcs is inherently risky. This function no longer works. I'm not going to attempt to fix now (no immediate need/motivation). Cheers.
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()
}
目的是您可以查找特定的包 and/or 特定的功能。 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
（这部分保留是为了繁荣，但请注意，即使定义并调用了上述非 dplyr mutate，getAnywhere 也会找到 dplyr::mutate。）
根据 Rui 的链接，我建议寻找特定函数很可能会错过新函数 and/or 否则有效但名称不同的函数。 （我没有一个明确的例子。）从这里开始，考虑寻找特定的包而不是特定的函数。
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
如果您认为它不会被频繁调用并且您的函数需要“一点时间”，那么半秒的延迟可能不会那么明显，但是对于这个玩具示例，差异是显而易见的。
以上@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() 的调用来测试 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
由 reprex package (v0.3.0)
于 2020-07-06 创建
我想创建一个只能在另一个函数内部使用的函数 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 在 dplyr 秒内调用 mutate 或 summarise.
无论函数如何调用，该方法都应该有效：
mutatedplyr::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())
所以检查函数不仅要看callstack，还要看callstack上的函数是从哪个包来的。有趣的是，RStudios 调试器显示调用堆栈上每个函数的命名空间，甚至是内部函数。我想知道它是怎么做到的，因为 environment(fun)) 仅适用于导出函数。
Update：我要从 rlang::trace_back“借用”，因为它似乎有一个优雅的（有效的）方法来确定完整的 package::function 对于大多数调用树（有些像 %>% 并不总是完全解析）。
（如果你想减少包膨胀......虽然你不太可能有 dplyr 而不是 purrr available，如果你更愿意在 base 中做尽可能多的事情，我已经提供了 #==# 等效的 base-R 调用。尝试删除一些 rlang 调用当然是可行的，但是再次......如果你假设 dplyr，那么你肯定有 rlang，在这种情况下这应该不是问题。）
EDIT (2022-02-25): the function below uses
:::functions inrlang, which (not surprisingly) no longer exist as of today, as a clear example of why using:::-funcs is inherently risky. This function no longer works. I'm not going to attempt to fix now (no immediate need/motivation). Cheers.
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()
}
目的是您可以查找特定的包 and/or 特定的功能。 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
（这部分保留是为了繁荣，但请注意，即使定义并调用了上述非 dplyr mutate，getAnywhere 也会找到 dplyr::mutate。）
根据 Rui 的链接，我建议寻找特定函数很可能会错过新函数 and/or 否则有效但名称不同的函数。 （我没有一个明确的例子。）从这里开始，考虑寻找特定的包而不是特定的函数。
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
如果您认为它不会被频繁调用并且您的函数需要“一点时间”，那么半秒的延迟可能不会那么明显，但是对于这个玩具示例，差异是显而易见的。
以上@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() 的调用来测试 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
由 reprex package (v0.3.0)
于 2020-07-06 创建