Nothing
#' @keywords internal
#' @title Object Types
#' @description Functions to determine the 'type' of an R object using classes.
#' Intended largely for convenience and internal use.
#' @param x An R object.
#' @return A logical value.
#' @name Object.Type
NULL
#' @describeIn Object.Type Is object a list (class `"list"` only)?
isList <- function(x) {
class(x)[1] == "list"
}
#' @describeIn Object.Type Is object a boot object (class `"boot"`)?
isBoot <- function(x) {
"boot" %in% class(x)
}
#' @describeIn Object.Type Is object a fitted model?
isMod <- function(x) {
any(c("lm", "glm", "lmerMod", "glmerMod", "lmerModLmerTest", "gls", "betareg")
%in% class(x))
}
#' @describeIn Object.Type Is object a generalised linear model (i.e. uses a
#' link function)?
isGlm <- function(x) {
any(c("glm", "glmerMod", "betareg") %in% class(x))
}
#' @describeIn Object.Type Is object a mixed model (class `"merMod"`)?
isMer <- function(x) {
any(c("lmerMod", "glmerMod", "lmerModLmerTest") %in% class(x))
}
#' @describeIn Object.Type Is object a generalised least squares model (class
#' `"gls"`)?
isGls <- function(x) {
"gls" %in% class(x)
}
#' @describeIn Object.Type Is object a beta regression model (class
#' `"betareg"`)?
isBet <- function(x) {
"betareg" %in% class(x)
}
#' @keywords internal
#' @title Parameter Types
#' @description Functions to determine the presence/absence of certain model
#' parameter types using their names. Intended largely for convenience and
#' internal use.
#' @param x A character vector of parameter names (e.g. names of coefficients
#' from [coef()] or [stdEff()]).
#' @return A logical vector of the same length as `x`.
#' @name Param.Type
NULL
#' @describeIn Param.Type Is parameter an intercept?
isInt <- function(x) {
x == "(Intercept)"
}
#' @describeIn Param.Type Is parameter a variable interaction (product term)?
isInx <- function(x) {
grepl("(?<!:):(?!:)", x, perl = TRUE)
}
#' @describeIn Param.Type Is parameter a beta regression precision coefficient?
isPhi <- function(x) {
grepl("^\\(phi\\)", x)
}
#' @describeIn Param.Type Is parameter an R-squared value?
isR2 <- function(x) {
x %in% c("(R.squared)", "(R.squared.adj)", "(R.squared.pred)",
"(R_squared)", "(R_squared_adj)", "(R_squared_pred)")
}
#' @describeIn Param.Type Is parameter a raw (unstandardised) coefficient?
isRaw <- function(x) {
grepl("^\\(raw\\)_", x)
}
#' @title Recursive [mapply()]
#' @description Recursively apply a function to a list or lists.
#' @param FUN Function to apply.
#' @param ... Object(s) to which `FUN` can be applied, or lists of such objects
#' to iterate over (defined narrowly, as of class `"list"`).
#' @param MoreArgs A list of additional arguments to `FUN`.
#' @param SIMPLIFY Logical, whether to simplify the results to a vector or
#' array.
#' @param USE.NAMES Logical, whether to use the names of the first list object
#' in `...` for the output.
#' @details `rMapply()` recursively applies `FUN` to the elements of the lists
#' in `...` via [mapply()]. If only a single list is supplied, the function
#' acts like a recursive version of [sapply()]. The particular condition that
#' determines if the function should stop recursing is if either the first or
#' second objects in `...` are not of class `"list"`. Thus, unlike [mapply()],
#' it will not iterate over non-list elements in these objects, but instead
#' returns the output of `FUN(...)`.
#'
#' This is primarily a convenience function used internally to enable
#' recursive application of functions to lists or nested lists. Its particular
#' stop condition for recursing is also designed to either *a)* act as a
#' wrapper for `FUN` if the first object in `...` is not a list, or *b)* apply
#' a weighted averaging operation if the first object is a list and the second
#' object is a numeric vector of weights.
#' @return The output of `FUN` in a list or nested list, or simplified to a
#' vector or array (or list of arrays).
#' @export
rMapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE,
USE.NAMES = TRUE) {
l <- list(...)
n <- length(l)
i <- if (n > 0) l[[1]] else l
j <- if (n > 1) l[[2]] else i
if (!isList(i) || !isList(j)) {
do.call(FUN, c(l, MoreArgs))
} else {
a <- list(FUN = FUN, MoreArgs = MoreArgs, SIMPLIFY = SIMPLIFY,
USE.NAMES = USE.NAMES)
mapply(rMapply, ..., MoreArgs = a, SIMPLIFY = SIMPLIFY,
USE.NAMES = USE.NAMES)
}
}
#' @title Parallel [sapply()]
#' @description Apply a function to a vector using parallel processing.
#' @param X A vector object (numeric, character, or list).
#' @param FUN Function to apply to the elements of `X`.
#' @param parallel The type of parallel processing to use. Can be one of
#' `"snow"` (default), `"multicore"` (not available on Windows), or `"no"`
#' (for none). See Details.
#' @param ncpus Number of system cores to use for parallel processing. If `NULL`
#' (default), all available cores are used.
#' @param cl Optional cluster to use if `parallel = "snow"`. If `NULL`
#' (default), a local cluster is created using the specified number of cores.
#' @param add.obj A character vector of any additional object names to be
#' exported to the cluster. Use if a required object or function cannot be
#' found.
#' @param ... Additional arguments to [parSapply()],
#' [`mcmapply()`](https://rdrr.io/r/parallel/unix/mclapply.html), or
#' [sapply()] (note: arguments `"simplify"` and `"SIMPLIFY"` are both
#' allowed).
#' @details This is a wrapper for [parallel::parSapply()] (`"snow"`) or
#' [`parallel::mcmapply()`](https://rdrr.io/r/parallel/unix/mclapply.html)
#' (`"multicore"`), enabling (potentially) faster processing of a function
#' over a vector of objects. If `parallel = "no"`, [sapply()] is used instead.
#'
#' Parallel processing via option `"snow"` (default) is carried out using a
#' cluster of workers, which is automatically set up via [makeCluster()] using
#' all available system cores or a user supplied number of cores. The function
#' then exports the required objects and functions to this cluster using
#' [clusterExport()], after performing a (rough) match of all objects and
#' functions in the current global environment to those referenced in the call
#' to `FUN` (and also any calls in `X`). Any additional required object names
#' can be supplied using `add.obj`.
#' @return The output of `FUN` in a list, or simplified to a vector or array.
#' @export
pSapply <- function(X, FUN, parallel = c("snow", "multicore", "no"),
ncpus = NULL, cl = NULL, add.obj = NULL, ...) {
parallel <- match.arg(parallel); nc <- ncpus; ao <- add.obj; a <- list(...)
if (parallel == "multicore") a$simplify <- NULL else a$SIMPLIFY <- NULL
if (parallel != "no") {
# No. cores to use
if (is.null(nc)) nc <- parallel::detectCores()
if (parallel == "snow") {
# Create local cluster using system cores
if (is.null(cl)) {
cl <- parallel::makeCluster(getOption("cl.cores", nc))
}
# Export required objects/functions to cluster
# (search global env. for objects in calls to X/FUN)
P <- function(...) {
paste(..., collapse = " ")
}
xc <- P(unlist(rMapply(function(i) {
if (isMod(i) || isBoot(i)) P(getCall(i))
}, X)))
fa <- P(sapply(match.call(expand.dots = FALSE)$..., deparse))
fc <- P(xc, enquote(FUN)[2], fa)
o <- unlist(lapply(search(), ls))
o <- o[sapply(o, function(i) grepl(i, fc, fixed = TRUE))]
o <- c("X", o, ao)
parallel::clusterExport(cl, o, environment())
# Run parSapply using cluster
out <- do.call(parallel::parSapply, c(list(cl, X, FUN), a))
parallel::stopCluster(cl)
} else {
out <- parallel::mcmapply(FUN, X, mc.cores = nc, MoreArgs = a)
}
} else {
out <- do.call(sapply, c(list(X, FUN), a))
}
return(out)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.