#### collect_simulations ####
#' Group stansim objects into a collection
#'
#' @description \code{collect_simulations()} groups together an arbitrary number
#' of objects with class \code{stansim_simulation} or
#' \code{stansim_collection} into a single \code{stansim_collection} object.
#' Allows for multiple simulations to be stored, saved, analysed and managed
#' in a single object.
#'
#' @param collection_name A name attached to the \code{stansim_collection}
#' object to help identify it. It is strongly recommended that an informative
#' and unique name is assigned.
#' @param object An object of class \code{stansim_simulation} or
#' \code{stansim_collection}. Must be provided.
#' @param ... Any further \code{stansim_simulation} or \code{stansim_collection}
#' objects to be grouped into a single \code{stansim_collection} object.
#' @return An S3 object of class \code{stansim_simulation} recording relevant
#' simulation data.
#' @examples
#' \dontrun{
#' # group together stansim_simulation objects
#' collection_basic <- collect_simulations("Linear Regression Study", simulation1,
#' simulation2)
#'
#' # group together stansim_simulations and stansim_collections
#' collection_extended <- collect_simulations("Extended Lin Reg Study", collection_basic,
#' simulation3)
#'
#' # group together multiple stansim_collections
#' merged_collections <- collect_simulations("merged collections", collection_extended,
#' collection_additional)
#' }
#'
#' @export
collect_simulations <- function(collection_name, object, ...) {
## -------------------------------------------------
## input tests
if (typeof(collection_name) != "character")
stop("collection_name must be of type character")
## extract all grouping objects
all_args <- c(as.list(environment()), list(...))
collect_args <- all_args[-which(names(all_args) == "collection_name")]
# all group objects must have correct classes
class_check <- function(obj) {
if (!(class(obj) %in% c("stansim_simulation", "stansim_collection")))
stop(
paste(
"all arguments except collection_name must be",
"of class \"stansim_simulation\" or \"stansim_collect\""
))
}
lapply(collect_args, class_check)
# no two group object should have the same sim_name or collection_name
get_name <- function(x){
if (class(x) == "stansim_simulation") return(x$sim_name)
if (class(x) == "stansim_collection") return(x$collection_name)
}
names <- unlist(lapply(collect_args, get_name))
if (anyDuplicated(names) != 0)
stop(paste("The collection_name and simulation_name values of all",
"arguments must be unique"))
## -------------------------------------------------
## base condition (length of groups = 1)
if (length(collect_args) == 1){
# error if only one stansim_simulation is provided
if (class(object) == "stansim_simulation")
stop("A single simulation cannot be used to make a collection.")
# return renamed collection
object$collection_name <- collection_name
object
} else {
## -------------------------------------------------
## recursive condition (length of groups > 1)
# extract the first two objects to merge
two_collect <- collect_args[1:2]
## dispatch to the correct joining function given obj types
# if both simulation
if (class(two_collect[[1]]) == "stansim_simulation" &
class(two_collect[[2]]) == "stansim_simulation") {
two_grouped <- collect_simulations_internal(collection_name,
two_collect[[1]],
two_collect[[2]])
} else
# if both collection
if (class(two_collect[[1]]) == "stansim_collection" &
class(two_collect[[2]]) == "stansim_collection") {
two_grouped <- collect_collections(collection_name,
two_collect[[1]],
two_collect[[2]])
} else
# if simulation and collection
if (class(two_collect[[1]]) == "stansim_simulation" &
class(two_collect[[2]]) == "stansim_collection") {
two_grouped <- collect_mixed(collection_name,
two_collect[[1]],
two_collect[[2]])
} else
# if collection and simulation
if (class(two_collect[[1]]) == "stansim_collection" &
class(two_collect[[2]]) == "stansim_simulation") {
two_grouped <- collect_mixed(collection_name,
two_collect[[2]],
two_collect[[1]])
}
## dispatch the recursive call
# set up list of args
named_recurs_args <- list("collection_name" = collection_name,
object = two_grouped)
collect_recurs_args <- c(named_recurs_args, collect_args[-c(1:2)])
# recursive call
do.call(collect_simulations, collect_recurs_args)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.