R Metaprogramming: return function body with arguments values filled in

Question

I am looking for a function that will return the body of function with the arguments filled in. The goal is to have a function, capture_code such that

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"))

Will return

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

I am using the code from 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

I have included the View call from the function body expression as well as my results. It looks almost correct, except I am unable to get the call and <- classes to be of type language. I would like to be able to get back the code from my AST.

Answer 1

Grab the call into mc and extract the function fun. Then wrap its body in substitute(...), replace the function name in the call with fun and run it. No packages are used.

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"))

giving:

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

Answer 2

Here's a mildly-hacky approach:

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")
#> }

The hacky bit is the last line, which uses substitute to replace parameters with arguments wherever they are within the function body. As far as I can tell, there's no simple way to do this with rlang, because the quosure idiom requires you to specify exactly what you'd like to substitute; base::substitute is more of a shotgun approach.

You can also use pryr::modify_lang, which traverses the AST like you've started writing above:

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")
#> }

Look at its source code if to see how to structure the recursion, but note that there are some weird bits of the language you have to account for to do this right.

If you want to roll your own recursion, ignoring the weirder bits (like formulas, pairlists, etc.) that won't matter for this call anyway,

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")
#> }