R/bind_to_function.R

In reconhub/outbreaker2: Bayesian Reconstruction of Disease Outbreaks by Combining Epidemiologic and Genomic Data

#' Encloses argument in a function's environment
#'
#' This function takes a function \code{f} and a series of named arguments, and
#' returns a closure of \code{f} which will only rely on one single argument
#' 'param'. This is used to reduce the number of arguments passed around to
#' likelihood or movement functions. This functionality is used internally when
#' creating closures of custom moves in \code{bind_moves}.
#' 
#' @param f The function to which arguments are bound.
#' 
#' @param ... Named arguments to bind to the function's environment.
#' 
#' @author Initial code by Rich FitzJohn (see 'references') with some
#' adaptations by Thibaut Jombart.
#'
#' @references Initial code comes from the \code{partially_apply} function in
#' the 'rodeint' package \code{richfitz/rodeint}.
#'
#' 
#' @export
#' 
bind_to_function <- function(f, ...) {

    ## We isolate the arguments of 'f' and identify those without defaults,
    ## which need to be provided through '...'. Arguments of 'f' which have a
    ## default value will be replaced with content of '...' if provided. The
    ## function returned is a closure with a single argument 'param', and with
    ## all non-default arguments in its environment.
    
    dots <- list(...)
    dots_names <- names(dots)
    f_args <- setdiff(names(formals(f)), "param")
    have_no_default <- vapply(formals(f)[f_args], is.symbol, logical(1))
    f_args_no_default <- names(have_no_default)[have_no_default]


    ## CHECKS ##
    if (is.primitive(f)) {
        stop("Cannot use with primitive functions")
    }

    ## Nothing to do if nothing provided
    if (length(dots) == 0) {
        if (length(f_args) > 1) {
            stop("'...' is empty but 'f' has more than one argument.")
        }
        return(f)
    }

    ## All objects passed in '...' need to be named
    if (is.null(dots_names) || !all(nzchar(dots_names))) {
        stop("All arguments provided through '...' need to be named.")
    }

    ## Name duplication is not allowed
    if (any(duplicated(dots_names))) {
        duplicated_args <- paste(unique(dots_names[duplicated(dots_names)]),
                                 collapse = ", ")
        msg <- sprintf("Duplicated formal arguments: ",
                       duplicated_args)
             
        stop(msg)
    }

    ## ... cannot contain 'param'
    if ("param" %in% dots_names) {
        stop("'...' cannot contain an argument 'param'")
    }

    
    ## make sure all arguments of 'f' which don't have default values but
    ## 'param' are in '...'
    
    are_missing <- !f_args_no_default %in% dots_names
    if (any(are_missing)) {
        missing_args <- f_args_no_default[are_missing] 
        missing_args <- paste(missing_args, collapse = ", ")
        msg <- sprintf("Arguments of %s missing from '...' with no default: %s",
             deparse(substitute(f)),
             missing_args)
        stop(msg)
    }

    ## remove arguments that are not part of 'f'
    to_keep <- dots_names %in% f_args
    dots <- dots[to_keep]
    dots_names <- names(dots)
    

    ## Attach arguments to 'f'
    add_to_function_environment(f, dots)
}






## This function adds a list of objects to a function's environment

add_to_function_environment <- function(f, defaults) {
    e <- as.environment(defaults)
    parent.env(e) <- environment(f)
    ff <- formals(f)
    replace_formals(f, ff[c(setdiff(names(ff), names(defaults)))], e)
}






## This replaces forms, but preserves attributes except for srcref,
## which will be invalid for any nontrivial change (and will
## confusingly be printed with the wrong structure).

replace_formals <- function(fun, value, envir = environment(fun)) {
    old_attributes <- attributes(fun)
    formals(fun, envir = envir) <- value
    attributes(fun) <- old_attributes[names(old_attributes) != "srcref"]
    fun
}