R元编程：返回填充了参数值的函数体

Question

我正在寻找一个函数，它将返回填充了参数的函数体。目标是有一个函数，capture_code，这样

my_scatterplot <- function(my_title, xlab = "mpg", ylab = "hp") {
  g <- ggplot(mtcars, aes(x = mpg, y = hp)) +
    geom_point()
  g + labs(x = xlab, y = ylab, title = my_title)
}

capture_code(my_scatterplot("My title", xlab = "MPG"))

会回来

  g <- ggplot(mtcars, aes(x = mpg, y = hp)) +
    geom_point()
  g + labs(x = "MPG", y = ylab, title = "My title")

我正在使用来自advanced R Walking AST with recursive functions 的代码。

expr_type <- function(x) {
  if (rlang::is_syntactic_literal(x)) {
    "constant"
  } else if (is.symbol(x)) {
    "symbol"
  } else if (is.call(x)) {
    "call"
  } else if (is.pairlist(x)) {
    "pairlist"
  } else {
    typeof(x)
  }
}

switch_expr <- function(x, ...) {
  switch(expr_type(x),
         ...,
         stop("Don't know how to handle type ", typeof(x), call. = FALSE)
  )
}

replace_vars <- function(x, envi) {
  switch_expr(x,
              # Base cases
              constant = x,
              symbol = {
                # Get the variable from the environment
                rlang::env_get(nm = as.character(x), default = x, env = envi)
              },

              # Recursive cases
              pairlist = purrr::map(x, replace_vars, envi),
              call = {
                res <- purrr::map(x, replace_vars, envi)
                class(res) <- class(x)
                res
              }
  )
}

capture_code <- function(e) {
  e <- rlang::enexpr(e)
  cf <- get(toString(e[[1]]))
  if(typeof(cf) != "closure") stop(e[[1]], "is not a function")

  # Evalation the named functions first
  # Then fill in the unnamed
  cf_args <- formals(cf)
  called_args <- as.list(e[-1])
  if(!is.null(names(called_args))) {
    not_named <- names(called_args) == ""
    named_args <- called_args[!not_named]
    unnamed_args <-  called_args[not_named]

    new_args <- modifyList(cf_args, named_args)
    missing_args <- unlist(lapply(new_args, rlang::is_missing))
    missing_indices <- seq_along(new_args)[missing_args]
  } else {
    new_args <- cf_args
    unnamed_args <- called_args
    missing_indices <- seq_along(new_args)
  }

  # Add the unnamed arguments
  for(i in seq_along(unnamed_args)) {
    new_args[[missing_indices[[i]]]] <- unnamed_args[[i]]
  }

  # Get the function body from
  cf_func_body <- functionBody(cf)[-1]

  # Pass the arguments as an environment for lookup
  replace_vars(cf_func_body, rlang::new_environment( as.list(new_args)))
}

res <- capture_code(my_scatterplot("My title", xlab = "MPG"))
res

我已经包含了来自函数体表达式的 View 调用以及我的结果。它看起来几乎是正确的，除了我无法将call 和<- 类设为language 类型。我希望能够从我的 AST 中取回代码。

Answer 1

将调用抓取到mc 并提取函数fun。然后将其主体包裹在substitute(...) 中，将调用中的函数名替换为fun 并运行它。没有使用任何包。

capture_code <- function(call) {
  mc <- match.call()[[2]]
  fun <- match.fun(mc[[1]])
  body(fun) <- substitute(substitute(b), list(b = body(fun)))
  mc[[1]] <- as.name("fun")
  eval(mc)
}

# test
capture_code(my_scatterplot("My title", xlab = "MPG"))

给予：

{
    g <- ggplot(mtcars, aes(x = mpg, y = hp)) + geom_point()
    g + labs(x = "MPG", y = "hp", title = "My title")
}

Answer 2

这是一个稍微有点老套的方法：

library(rlang)

my_scatterplot <- function(my_title, xlab = "mpg", ylab = "hp") {
    g <- ggplot(mtcars, aes(x = mpg, y = hp)) +
        geom_point()
    g + labs(x = xlab, y = ylab, title = my_title)
}

capture_code <- function(call){
    call <- call_standardise(enquo(call))    # capture call and fill in params and default args
    args <- call_args(call)    # extract cleaned args
    body <- fn_body(call_fn(call))    # extract function body

    eval(substitute(substitute(body, args)))    # substitute args in body
}

capture_code(my_scatterplot("My title", xlab = "MPG"))
#> {
#>     g <- ggplot(mtcars, aes(x = mpg, y = hp)) + geom_point()
#>     g + labs(x = "MPG", y = ylab, title = "My title")
#> }

hacky 位是最后一行，它使用substitute 将参数替换为函数体内的任何参数。据我所知，使用 rlang 没有简单的方法可以做到这一点，因为 quosure 成语要求您准确指定要替换的内容； base::substitute 更像是一种霰弹枪方法。

你也可以使用pryr::modify_lang，它像你上面开始写的那样遍历AST：

capture_code <- function(call){
    call <- call_standardise(enquo(call))
    args <- call_args(call)
    body <- fn_body(call_fn(call))

    pryr::modify_lang(body, function(leaf){
        expr_string <- expr_name(leaf)
        if (expr_string %in% names(args)) {
            args[[expr_string]]
        } else {
            leaf
        }
    })
}

capture_code(my_scatterplot("My title", xlab = "MPG"))
#> {
#>     g <- ggplot(mtcars, aes(x = mpg, y = hp)) + geom_point()
#>     g + labs(x = "MPG", y = ylab, title = "My title")
#> }

如果要了解如何构造递归，请查看其源代码，但请注意，要正确执行此操作，您必须考虑到语言的一些奇怪部分。

如果您想滚动自己的递归，忽略对这个调用无关紧要的奇怪位（如公式、配对列表等），

capture_code <- function(call){
    call <- call_standardise(enquo(call))
    args <- call_args(call)
    body <- fn_body(call_fn(call))

    modify_expr <- function(node){
        node_string <- expr_name(node)
        if (length(node) > 1) {
            node <- lapply(node, modify_expr)    # recurse
            as.call(node)
        } else if (node_string %in% names(args)) {
            args[[node_string]]    # substitute
        } else {
            node    # ignore
        }
    }
    modify_expr(body)
}

capture_code(my_scatterplot("My title", xlab = "MPG"))
#> {
#>     g <- ggplot(mtcars, aes(x = mpg, y = hp)) + geom_point()
#>     g + labs(x = "MPG", y = ylab, title = "My title")
#> }