在函数内获取函数调用的函数组件

Question

是否可以检索函数调用的函数组件？也就是说，是否可以在另一个函数调用上使用as.list(match.call())。

背景是，我想要一个函数，它接受一个函数调用并返回所述函数调用的组件。

get_formals <- function(x) {
  # something here, which would behave as if x would be a function that returns
  # as.list(match.call())
}

get_formals(mean(1:10))
# expected to get:
# [[1]]
# mean
#
# $x
# 1:10

期望的结果是使get_formals返回与在提供的函数调用中调用match.call()相同的结果。

mean2 <- function(...) {
  as.list(match.call())
}
mean2(x = 1:10)
# [[1]]
# mean2
# 
# $x
# 1:10

另一个例子

这个问题的动机是检查一个memoize函数是否已经包含了缓存值。 memoize有一个函数has_cache()，但它需要以特定的方式调用has_cache(foo)(vals)，例如：

library(memoise)

foo <- function(x) mean(x)
foo_cached <- memoise(foo)

foo_cached(1:10) # not yet cached
foo_cached(1:10) # cached

has_cache(foo_cached)(1:10) # TRUE
has_cache(foo_cached)(1:3) # FALSE

我的目标是在函数调用被缓存或不被缓存时记录一些内容。

cache_wrapper <- function(f_call) {
  is_cached <- has_cache()() # INSERT SOLUTION HERE
  # I need to deconstruct the function call to pass it to has_cache
  # basically
  # has_cache(substitute(expr)[[1L]])(substitute(expr)[[2L]]) 
  # but names etc do not get passed correctly

  if (is_cached) print("Using Cache") else print("New Evaluation of f_call")
  f_call
}

cache_wrapper(foo_cached(1:10))
#> [1] "Using Cache"     # From the log-functionality
#> 5.5                   # The result from the function-call

- David

---

我假设 get_formals = function (expr) substitute(expr)[[2L]] 对你的目的不够充分？ - Konrad Rudolph

你正在处理多少层环境？我不确定你是想要Konrad的方法还是需要更灵活的东西。你的“函数调用”来自哪里，例如一些deparse操作？如果你能发布一个演示，展示你将如何使用这个检索工具，那会很有帮助。 - Carl Witthoft

@KonradRudolph的解决方案已经接近成功，但我丢失了参数的名称。 - David

我只处理一个层。我将在上面的代码中添加另一个示例。 - David

Answer 1

你可以使用match.call()函数进行参数匹配。

get_formals <- function(expr) {
  call <- substitute(expr)
  call_matched <- match.call(eval(call[[1L]]), call)
  as.list(call_matched)
}

get_formals(mean(1:10))

# [[1]]
# mean
# 
# $x
# 1:10

library(ggplot2)
get_formals(ggplot(mtcars, aes(x = mpg, y = hp)))

# [[1]]
# ggplot
# 
# $data
# mtcars
# 
# $mapping
# aes(x = mpg, y = hp)

library(dplyr)
get_formals(iris %>% select(Species))

# [[1]]
# `%>%`
# 
# $lhs
# iris
# 
# $rhs
# select(Species)

---

编辑：感谢@KonradRudolph的建议！

上述函数查找正确的函数。它将在get_formals()的父级作用域中搜索，而不是调用者的作用域。更加安全的方法是：

get_formals <- function(expr) {
  call <- substitute(expr)
  call_matched <- match.call(eval.parent(bquote(match.fun(.(call[[1L]])))), call)
  as.list(call_matched)
}

match.fun() 函数是解决同名非函数对象遮蔽函数对象的重要方法。例如，如果 mean 被覆盖为一个向量，则需要使用该函数。

mean <- 1:5

get_formals()的第一个示例会出现错误，而更新后的版本运行良好。

- Darren Tsai

---

注意要找到正确的函数：它将在get_formals的父级作用域中搜索，而不是调用者的作用域。您可以通过将eval替换为eval.parent(bquote(match.fun(.(call[[1L]]))))来修复此问题（这很麻烦，但match.fun非常重要，以正确解析被同名非函数对象遮盖的函数）。 - Konrad Rudolph

@KonradRudolph 谢谢您详细的建议。已更新。 - Darren Tsai

Answer 2

这是一种方法，它可以从函数中获取默认值，即使您没有提供所有参数：

get_formals <- function(call)
{
  f_list <- as.list(match.call()$call)
  func_name <- f_list[[1]]
  p_list <- formals(eval(func_name))
  f_list <- f_list[-1]
  ss <- na.omit(match(names(p_list), names(f_list)))
  if(length(ss) > 0) {
    p_list[na.omit(match(names(f_list), names(p_list)))] <- f_list[ss]
    f_list <- f_list[-ss]
  }
  unnamed <- which(!nzchar(sapply(p_list, as.character)))
  if(length(unnamed) > 0)
  {
    i <- 1
    while(length(f_list) > 0)
    {
      p_list[[unnamed[i]]] <- f_list[[1]]
      f_list <- f_list[-1]
      i <- i + 1
    }
  }
  c(func_name, p_list)
}

这将会给出：

get_formals(rnorm(1))
[[1]]
rnorm

$n
[1] 1

$mean
[1] 0

$sd
[1] 1

get_formals(ggplot2::ggplot())
[[1]]
ggplot2::ggplot

$data
NULL

$mapping
aes()

$...


$environment
parent.frame()

为了使其正常工作，您可以在其中一级执行以下操作：

```html

为了让这个起作用，你可以这样做：

```

foo <- function(f_call) {
  eval(as.call(list(get_formals, call = match.call()$f_call)))
}

foo(mean(1:10))
[[1]]
mean

$x
1:10

$...

- Allan Cameron

---

这让我接近目标了。你知道如何使用这个函数的一级吗？即 foo <- function(f_call) return(get_formals(f_call))？ - David

太棒了！搞定了！我已经将Konrad的eval.parent调用实现到你的函数中。我会发布一个更新，展示对我起作用的完整解决方案！ - David

Answer 3

这个答案主要基于 Allen的回答，但实现了Konrad关于eval和eval.parent函数的评论。 此外，一些do.call被添加到上面示例中的cache_wrapper中以完成最终操作：

library(memoise)

foo <- function(x) mean(x)
foo_cached <- memoise(foo)

foo_cached(1:10) # not yet cached
#> [1] 5.5
foo_cached(1:10) # cached
#> [1] 5.5

has_cache(foo_cached)(1:10)
#> [1] TRUE
has_cache(foo_cached)(1:3)
#> [1] FALSE

# As answered by Allen with Konrads comment
get_formals <- function(call) {
  f_list <- as.list(match.call()$call)
  func_name <- f_list[[1]]
  # changed eval to eval.parent as suggested by Konrad...
  p_list <- formals(eval.parent(eval.parent(bquote(match.fun(.(func_name))))))
  f_list <- f_list[-1]
  ss <- na.omit(match(names(p_list), names(f_list)))
  if(length(ss) > 0) {
    p_list[na.omit(match(names(f_list), names(p_list)))] <- f_list[ss]
    f_list <- f_list[-ss]
  }
  unnamed <- which(!nzchar(sapply(p_list, as.character)))
  if(length(unnamed) > 0) {
    i <- 1
    while(length(f_list) > 0) {
      p_list[[unnamed[i]]] <- f_list[[1]]
      f_list <- f_list[-1]
      i <- i + 1
    }
  }
  c(func_name, p_list)
}

# check if the function works with has_cache
fmls <- get_formals(foo_cached(x = 1:10))
do.call(has_cache(eval(parse(text = fmls[1]))),
        fmls[2])
#> [1] TRUE


# implement a small wrapper around has_cache that reports if its using cache
cache_wrapper <- function(f_call) {
  fmls <- eval(as.call(list(get_formals, call = match.call()$f_call)))
  is_cached <- do.call(has_cache(eval(parse(text = fmls[1]))),
                       fmls[2])
  if (is_cached) print("Using Cache") else print("New Evaluation of f_call")
  f_call
}

cache_wrapper(foo_cached(x = 1:10))
#> [1] "Using Cache"
#> [1] 5.5

cache_wrapper(foo_cached(x = 1:30))
#> [1] "New Evaluation of f_call"
#> [1] 5.5

- David