以编程方式确定函数调用是指您自己的函数还是包的(或基础 R 的)函数?

Determine programmatically if a function call refers to your own function or a package's (or base R's) function?

以编程方式确定函数调用是指您自己的函数还是包的(或基础 R 的)函数的最佳方法是什么?

基本上,我正在编写自己的错误恢复函数,并且我想让用户只能看到用户 (I) 编写的函数的回溯消息。

foo = function(x){
  # do stuff
  return(x)
}
my_call = call('foo', 10)
R_call = call('round', 10.5)
library(gdata)
pkg_call = call('trim', ' _ ')
attributes(my_call) # NULL
attributes(R_call) # NULL
attributes(pkg_call) # NULL

有什么方法可以通过编程区分 my_callpkg_callR_call

一种可能的实现方法是使用 utils 包中的 getAnywhere 并确定调用函数的定义位置(用户函数将始终在 .GlobalEnv 中定义,并且将掩盖其他定义)。例如,

> foo = function(x){
+     # do stuff
+     return(x)
+ }
> my_call = call('foo', 10)
> R_call = call('round', 10.5)
> library(gdata)
> pkg_call = call('trim', ' _ ')
> is_user_function_call <- function(call) '.GlobalEnv' %in% getAnywhere(as.character(call[[1]]))$where
> is_user_function_call(my_call)
[1] TRUE
> is_user_function_call(R_call)
[1] FALSE
> is_user_function_call(pkg_call)
[1] FALSE

本质上,is_user_function 所做的是检查被调用的函数是否在 .GlobalEnv.

中定义

使用getAnywhere时,基础包中的函数与其他包中的函数本质上没有区别:

> getAnywhere('round')$where
[1] "package:base"   "namespace:base"
> getAnywhere('trim')$where
[1] "package:gdata"   "namespace:gdata" 

因此,如果您想区分函数 base/recommended 包和第三方包,您需要对照包列表进行检查。像这样

> ip <- installed.packages() 
> base.packages <- ip[ ip[,"Priority"] %in% c("base"), "Package"]
> recommended.packages <- ip[ ip[,"Priority"] %in% c("recommended"), "Package"]
> is_base_function_call <- function(call) any(sapply(base.packages, grepl, x=getAnywhere(as.character(call[[1]]))$where))
> is_recommended_function_call <- function(call) any(sapply(recommended.packages, grepl, x=getAnywhere(as.character(call[[1]]))$where))
> is_package_function_call <- function(call) !is_user_function_call(call) && !is_base_function_call(call) && !is_recommended_function_call(call)
> is_base_function_call(R_call)
[1] TRUE
> is_base_function_call(pkg_call)
[1] FALSE
> is_package_function_call(pkg_call)
[1] TRUE

使用 lssearch 函数,您可以像这样将函数的命名空间作为属性附加到由 call.[=14 生成的表达式=]

call_with_ns <- function(name, ...) {
    found_namespace <- NA_character_
    for (namespace in search()) {
        if (name %in% ls(namespace)) {
            found_namespace <- namespace
            break
        }
    }

    result <- do.call(call, c(name, list(...)))
    attr(result, 'namespace') <- found_namespace
    result
}

foo = function(x){
  # do stuff
  return(x)
}
my_call = call_with_ns('foo', 10)
R_call = call_with_ns('round', 10.5)
library(gdata)
pkg_call = call_with_ns('trim', ' _ ')
attributes(my_call)
# $namespace
# [1] ".GlobalEnv"
attributes(R_call) 
# $namespace
# [1] "package:base"
attributes(pkg_call) 
# $namespace
# [1] "package:gdata"