R/utils--DoCall.R

In GegznaV/ht: Hypothesis Tests Based on DescTools Package

#' Fast Alternative To The Internal `do.call`
#'
#' The [base::do.call()] can be somewhat slow, especially when
#' working with large objects. This function is based upon the suggestions from
#' Hadley Wickham on the R mailing list
#' ([link](http://r.789695.n4.nabble.com/call-do-call-expression-too-big-td3574335.htmlhere)).
#' Also thanks to *Tommy* at StackOverflow
#' ([link](https://stackoverflow.com/a/10022480/4783029))
#' for how to handle double and triple colon operators, `::`, further
#' enhancing the function.
#'
#' @param what either a function or a non-empty character string naming the
#'        function to be called.
#' @param args a *list* of arguments to the function call. The `names` attribute
#'        of `args` gives the argument names.
#' @param quote a logical value indicating whether to quote the arguments.
#' @param envir an environment within which to evaluate the call.  This will be
#'        most useful if `what` is a character string and the arguments are
#'        symbols or quoted expressions.
#'
#' @note This function is a verbatim copy from [Gmisc::fastDoCall()]
#'
#' @section Note:
#'  While the function attempts to do most of what [base::do.call()]
#'  can it has limitations. It can currently not parse the example code from
#'  the original function:  \cr
#'  `do.call(paste, list(as.name("A"), as.name("B")), quote = TRUE)`
#'  and the funcitonality of `quote` has not been thoroughly tested.
#'
#' @author
#' Max Gordon <max@@gforge.se>
#'
#' @export
#'
#' @examples
#'
#' DoCall("complex", list(imaginary = 1:3))
#'
#' ## if we already have a list (e.g. a data frame)
#' ## we need c() to add further arguments
#' tmp <- expand.grid(letters[1:2], 1:3, c("+", "-"))
#' DoCall("paste", c(tmp, sep = ""))
#'
#' ## examples of where objects will be found.
#' A <- 2
#' f <- function(x) print(x^2)
#' env <- new.env()
#' assign("A", 10, envir = env)
#' assign("f", f, envir = env)
#' f <- function(x) print(x)
#'
#' f(A)                                         # 2
#' DoCall("f", list(A))                         # 2
#' DoCall("f", list(A), envir = env)            # 4
#' DoCall(f, list(A), envir = env)              # 2
#' DoCall("f", list(quote(A)), envir = env)     # 100
#' DoCall(f, list(quote(A)), envir = env)       # 10
#' DoCall("f", list(as.name("A")), envir = env) # 100
#'
#' eval(call("f", A))                           # 2
#' eval(call("f", quote(A)))                    # 2
#' eval(call("f", A), envir = env)              # 4
#' eval(call("f", quote(A)), envir = env)       # 100
#'
DoCall <- function(what, args, quote = FALSE, envir = parent.frame()) {

  # source: Gmisc
  # author: Max Gordon <max@gforge.se>

  if (quote) {
    args <- lapply(args, enquote)
  }

  if (is.null(names(args)) ||
    is.data.frame(args)) {
    argn <- args
    args <- list()
  } else {
    # Add all the named arguments
    argn <- lapply(names(args)[names(args) != ""], as.name)
    names(argn) <- names(args)[names(args) != ""]
    # Add the unnamed arguments
    argn <- c(argn, args[names(args) == ""])
    args <- args[names(args) != ""]
  }

  if (class(what) == "character") {
    if (is.character(what)) {
      fn <- strsplit(what, "[:]{2,3}")[[1]]
      what <- if (length(fn) == 1) {
        get(fn[[1]], envir = envir, mode = "function")
      } else {
        get(fn[[2]], envir = asNamespace(fn[[1]]), mode = "function")
      }
    }
    call <- as.call(c(list(what), argn))

  } else if (class(what) == "function") {
    f_name <- deparse(substitute(what))
    call <- as.call(c(list(as.name(f_name)), argn))
    args[[f_name]] <- what

  } else if (class(what) == "name") {
    call <- as.call(c(list(what, argn)))
  }

  eval(call, envir = args, enclos = envir)
}