#' Find sources for arguments in arbitrary function(s)
#'
#' Search among local objects (which will often be arguments passed into a function) as well as
#' dot objects to match the formals needed by `fn`.
#' If `localFormalArgs` is named, then it will match the formal
#' (name of `localFormalArgs`) with the local object,
#' e.g., `localFormalArgs = c(x = "obj")` will find the object in the local environment called
#' `"obj"`, and this will be found because it matches the `x` argument in `fn`.
#'
#' @param fn Function name(?)
#' @param localFormalArgs A (named) character vector or arguments to
#' @param envir The environment in which to (???)
#' @param dots TODO: need description
#'
#' @return List of named objects. The names are the formals in `fn`, and
#' the objects are the values for those formals.
#' This can easily be passed to `do.call(fn, args1)`
#'
#' @export
#' @importFrom utils getFromNamespace
#' @rdname getLocalArgsFor
getLocalArgsFor <- function(fn, localFormalArgs, envir, dots) {
fnicd <- getFromNamespace(".formalsNotInCurrentDots", "reproducible")
if (missing(envir))
envir <- parent.frame()
if (missing(localFormalArgs))
localFormalArgs <- ls(envir = envir)
if (is.null(names(localFormalArgs)))
names(localFormalArgs) <- localFormalArgs
if (length(fn) > 1) {
forms <- unlist(lapply(fn, fnicd, dots = dots))
forms <- forms[duplicated(forms)]
} else {
forms <- fnicd(fn, dots = dots)
}
args <- dots[!(names(dots) %in% forms)]
localFormals <- if (length(fn) > 1) {
a <- lapply(fn, function(f)
localFormalArgs[names(localFormalArgs) %in% formalArgs(f)]
)
unlist(a)[!duplicated(unlist(a))] # unique strips names
} else {
localFormalArgs[names(localFormalArgs) %in% formalArgs(fn)]
}
objsFromLocal <- mget(localFormals, envir = envir)
names(objsFromLocal) <- names(localFormals)
args <- append(args, objsFromLocal)
}
#' Identify the source for arguments passed to an arbitrary function
#'
#' When running arbitrary functions inside other functions, there is a common
#' construct in R to use `...`. It does not work, however, in the general case
#' to write `do.call(fn, list(...))` because not all `fn` themselves
#' accept `...`. So this will fail if too many arguments are supplied to
#' the `...`. In the general case, we want to write:
#' `do.call(fn, list(onlyTheArgumentsThatAreNeeded))`. This function helps
#' to find the `onlyTheArgumentsThatAreNeeded` by determining a) what is needed
#' by the `fn` (which can be a list of many `fn`), and b) where to find
#' values, either in an arbitrary environment or passed in via `dots`.
#'
#' @param fn A function or list of functions from which to run `formalArgs`
#' @param localFormalArgs A vector of possible objects, e.g., from `ls()`
#' @param envir The environment to find the objects named in `localFormalArgs`
#' @param dots Generally list(...), which would be an alternative place to find
#' `localFormalArgs`
#'
#' @return A list of length 2, named `argsSingle` and `argsMulti`, which
#' can be passed to e.g.,
#' `MapOrDoCall(fn, multiple = args1$argsMulti, single = args1$argsSingle)`
#'
#' @export
#' @rdname identifyVectorArgs
identifyVectorArgs <- function(fn, localFormalArgs, envir, dots) {
allArgs <- getLocalArgsFor(fn, localFormalArgs, envir = envir, dots = dots)
# These types don't correctly work with "length", so omit them from search
specialTypes <- c("environment", "sf", "Spatial", "Raster")
lengthOne <- unlist(lapply(allArgs, is.null)) | unlist(lapply(allArgs, function(x) {
if (any(unlist(lapply(specialTypes, is, obj = x))) | length(x) == 1) {
TRUE
} else {
FALSE
}}))
if (sum(lengthOne)) {
argsSingle <- allArgs[lengthOne]
argsMulti <- allArgs[!lengthOne]
} else {
argsSingle <- list()
argsMulti <- allArgs
}
list(argsSingle = argsSingle, argsMulti = argsMulti)
}
#' `Map`/`lapply` all in one
#'
#' Usually run after `identifyVectorArgs` which will separate the arguments
#' into vectors of values for a call to `Map`, and arguments that have
#' only one value (passed to `MoreArgs` in `Map`). If all are single
#' length arguments, then it will pass to `lapply`. If a `cl` is provided
#' and is non-`NULL`, then it will pass all arguments to `clusterMap` or
#' `clusterApply`.
#'
#' @param multiple This a list the arguments that Map will cycle over.
#' @param single Passed to `MoreArgs` in the `mapply` function.
#' @param fn The function that will be run via `Map`/`clusterMap`.
#' @param useCache Logical indicating whether to use the cache.
#' @param cl A cluster object or `NULL`.
#'
#' @export
#' @importFrom reproducible Cache
#' @rdname MapOrDoCall
#' @seealso `identifyVectorArgs`
MapOrDoCall <- function(fn, multiple, single, useCache, cl = NULL) { #nolint
if (length(multiple)) {
browser(expr = exists("._MapOrDoCall_1"))
obj <- do.call(Cache, args = append(multiple, alist(Map2, fn,
MoreArgs = single,
cl = cl,
useCache = useCache)))
} else {
browser(expr = exists("._MapOrDoCall_2"))
if (!missing(useCache))
single[["useCache"]] <- useCache
obj <- do.call(Cache, args = append(alist(fn), single))
}
obj
}
#' `Map` and `parallel::clusterMap` together
#'
#' This will send to `Map` or `clusterMap`, depending on whether `cl` is provided.
#' Because they use different argument names for the main function
#' to call, leave that argument unnamed.
#'
#' @param f passed as `f` to `Map` or `fun` to `clusterMap`
#' @param ... passed to `Map` or `clusterMap`
#' @param cl A cluster object, passed to `clusterMap`
#'
#' @export
#' @importFrom parallel clusterMap
#' @importFrom utils getFromNamespace
#' @rdname Map2
#' @examples
#'
#' \dontrun{
#' a <- 1:5
#' Map2(a, f = function(x) x)
#'
#' }
Map2 <- function(f, ..., cl = NULL) { #nolint
#fnicd <- getFromNamespace(".formalsNotInCurrentDots", "reproducible")
#formsMap <- fnicd(mapply, ...)
#formsClusterMap <- fnicd(clusterMap, ...)
argList <- list(...)
if (any(c("fun", "FUN") %in% names(argList)))
stop("Please use f, not fun or FUN, to supply the function.")
#argList <- rlang::quos(...)
if (is.null(cl)) {
#browser()
#argList <- list(...)
# wrongFun1 <- "fun" %in% names(argList)
# if (wrongFun1) {
# fun <- argList$fun
# }
# wrongFun2 <- "FUN" %in% names(argList)
# if (wrongFun2) {
# fun <- argList$FUN
# argList$FUN <- NULL
# }
# argList[setdiff(formsMap, formsClusterMap)] <- NULL
# if (wrongFun1 || wrongFun2) {
# argList$f <- fun
# argList$fun <- NULL
# }
# eval_tidy(eval_tidy(quos(Map(!!!argList)))[[1]])
Map(f = f, ...)
#Map(!!!(argList))
#do.call(Map, args = argList)
} else {
#argList <- list(...)
# wrongFun1 <- "f" %in% names(argList)
# if (wrongFun1) {
# fun <- argList$f
# argList$fun <- NULL
# }
# wrongFun2 <- "FUN" %in% names(argList)
# if (wrongFun2) {
# fun <- argList$FUN
# argList$FUN <- NULL
# }
# argList[setdiff(formsClusterMap, formsMap)] <- NULL
# if (wrongFun1 || wrongFun2) {
# argList$fun <- fun
# }
# argList$cl <- quo(cl)
clusterMap(cl = cl, fun = f, ...)
#eval_tidy(eval_tidy(quos(clusterMap(!!!argList)))[[1]])
#do.call(clusterMap, append(list(cl = cl), argList))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.