`match.call()` 和 `sys.call()` 从封闭环境的函数中调用

Question

match.call() 和 sys.call() 可以直接调用当前执行的函数，但是我似乎无法可靠地调用上一级函数。

我想建立以下函数工厂

factory <- function(){

  CALL <- function(){
    # does operations on what would be the output of match.call() and sys.call() 
    # if they were executed in the manufactured function
  }

  CALL2 <- function() {
    # calls CALL() and does other operations
  }

  function(x, y){
    # calls CALL() and CALL2(), not necessarily at the top level
  }
}

这是一个简化的示例，具有预期的输出，我只是尝试打印正确的 match.call() 和 sys.call() ：

代码

我希望您的回答能够通过在找到 # INSERT SOME CODE 条评论的地方添加代码来编辑以下内容。

我最后的代码以不同的方式调用 CALL 和 CALL2 函数，以测试解决方案的稳健性。

这些方法中的每一种都应该打印相同的输出，这就是 {print(match.call()); print(sys.call())} 会打印的内容。

factory <- function(){
  CALL <- function(){
    # INSERT SOME CODE HERE
  }
  CALL2 <- function() {
    # INSERT SOME CODE HERE IF NECESSARY
    CALL()
  }

  function(x, y){
    # INSERT SOME CODE HERE IF NECESSARY

    # Don't edit following code
    message("call from top level")
    CALL()
    message("call from lst")
    dplyr::lst(CALL())
    message("call from lapply")
    lapply(CALL(), identity)
    message("call from sub function")
    f <- function() CALL()
    f()
    message("call from another function from enclosing env")
    CALL2()
    message("call from lst")
    dplyr::lst(CALL2())
    message("call from lapply")
    lapply(CALL2(), identity)
    message("call from sub function")
    g <- function() CALL2()
    g()
    invisible(NULL)
  }
}

输入

要测试函数，应执行以下代码：

fun <- factory()
fun("foo", y = "bar")

或

fun2 <- function(){
  fun("foo", y = "bar")
}
fun2()

通过这种方式，解决方案使用 2 个不同的调用堆栈进行了测试，同样是为了稳健性。

期望输出

任何时候在上面的例子中调用 CALL，应该打印以下内容，但是它被称为：

fun(x = "foo", y = "bar")
fun("foo", y = "bar")

这意味着运行 fun("foo", y = "bar") 或 fun2() 时的完整输出应该是：

call from top level
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from lst
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from lapply
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from sub function
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from another function from enclosing env
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from lst
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from lapply
fun(x = "foo", y = "bar")
fun("foo", y = "bar")
call from sub function
fun(x = "foo", y = "bar")
fun("foo", y = "bar")

也许 rlang / tidyeval 可以拯救？

我尝试了什么

我相信我找到了 match.call() 成功的方法。

为了确保 match.call() 在正确的环境中执行，我使用 ENV <- environment() 创建了一个绑定 ENV 到我的制造函数的环境。然后我可以通过在 CALL() 和 CALL2() 中调用 ENV <- eval.parent(quote(ENV)) 来检索这个环境，然后可以通过调用 eval(quote(match.call()), ENV).

获得正确的输出

但是，同样的策略不适用于 sys.call()。

factory <- function(){

  CALL <- function(){
    ENV <- eval.parent(quote(ENV))
    print(eval(quote(match.call()), ENV))
    print(eval(quote(sys.call()), ENV))
  }

  CALL2 <- function() {
    ENV <- eval.parent(quote(ENV))
    CALL()
  }

  function(x, y){
    ENV <- environment()
    message("call from top level")
    CALL()
    message("call from lst")
    dplyr::lst(CALL())
    message("call from lapply")
    lapply(CALL(), identity)
    message("call from sub function")
    f <- function() CALL()
    f()
    message("call from another function from enclosing env")
    CALL2()
    message("call from lst")
    dplyr::lst(CALL2())
    message("call from lapply")
    lapply(CALL2(), identity)
    message("call from sub function")
    g <- function() CALL2()
    g()
    invisible(NULL)
  }
}

输出：

fun <- factory()
fun("foo", y = "bar")
#> call from top level
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lst
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lapply
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from sub function
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from another function from enclosing env
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lst
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lapply
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from sub function
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)

fun2 <- function(){
  fun("foo", y = "bar")
}
fun2()
#> call from top level
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lst
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lapply
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from sub function
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from another function from enclosing env
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lst
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from lapply
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)
#> call from sub function
#> fun(x = "foo", y = "bar")
#> eval(quote(sys.call()), ENV)

^{由 reprex package (v0.2.1)}

于 2019-06-05 创建

如您所见，输出显示 eval(quote(sys.call()), ENV) 我想查看 fun("foo", y = "bar").

而不是 print(eval(quote(sys.call()), ENV)) 我也尝试了 print(sys.call(1)) 和 print(sys.call(sys.parent())) 并且两者有时打印正确的东西，但不稳健。

Answer 1

我不知道它是稳健的还是惯用的，但我可以通过在 rlang::frame_position() 上使用 sys.call() 来解决它。

问题是 frame_position() 是 soft-deprecated 没有适当的替换，所以我定义了一个函数 frame_pos()，它在我的用例中似乎工作相同：

frame_pos <- function(frame) {
  pos <- which(sapply(sys.frames(), identical, frame))
  if(!length(pos)) pos <- 0
  pos
}

factory <- function(){
  CALL <- function(){
    ENV <- eval.parent(quote(ENV))
    print(eval(quote(match.call()), ENV))
    print(sys.call(rlang::frame_position(ENV)))
    print(sys.call(frame_pos(ENV)))
  }
  CALL2 <- function() {
    ENV <- eval.parent(quote(ENV))
    CALL()
  }
  function(x, y){
    ENV <- environment()
    message("call from top level")
    CALL()
    message("call from lst")
    dplyr::lst(CALL())
    message("call from lapply")
    lapply(CALL(), identity)
    message("call from sub function")
    f <- function() CALL()
    f()
    message("call from another function from enclosing env")
    CALL2()
    message("call from lst")
    dplyr::lst(CALL2())
    message("call from lapply")
    lapply(CALL2(), identity)
    message("call from sub function")
    g <- function() CALL2()
    g()
    invisible(NULL)
  }
}

fun <- factory()
fun("foo", y = "bar")
#> call from top level
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lst
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lapply
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from sub function
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from another function from enclosing env
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lst
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lapply
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from sub function
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")

fun2 <- function() fun("foo", y = "bar")
fun2()
#> call from top level
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lst
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lapply
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from sub function
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from another function from enclosing env
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lst
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from lapply
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")
#> call from sub function
#> fun(x = "foo", y = "bar")
#> fun("foo", y = "bar")
#> fun("foo", y = "bar")

Answer 2

只是为了让你换个角度看问题本身，您可以将呼叫保存在封闭环境中，始终在 "main" 函数中匹配它：

factory <- function(){
  matched_call <- NULL

  CALL <- function(){
    print(matched_call)
  }
  CALL2 <- function() {
    CALL()
  }

  function(x, y){
    matched_call <<- match.call()
    on.exit(matched_call <<- NULL)

    ...
  }
}

`match.call()` 和 `sys.call()` 从封闭环境的函数中调用

`match.call()` and `sys.call()` called from a function of the enclosing environment

environment

r

function

tidyeval

rlang