R/reSummarise.R

In SimDesign: Structure for Organizing Monte Carlo Simulation Designs

#' Run a summarise step for results that have been saved to the hard drive
#'
#' When \code{runSimulation()} uses the option \code{save_results = TRUE}
#' the R replication results from the Generate-Analyse functions are
#' stored to the hard drive. As such, additional summarise components
#' may be required at a later time, whereby the respective \code{.rds} files
#' must be read back into R to be summarised. This function performs
#' the reading of these files, application of a provided summarise function,
#' and final collection of the respective results.
#'
#' @param summarise a summarise function to apply to the read-in files.
#'   See \code{\link{runSimulation}} for details.
#'
#'   Note that if the simulation contained
#'   only one row then the new summarise function can be defined as either
#'   \code{summarise <- function(results, fixed_objects)}, if
#'   \code{fixed_objects} is required, or
#'   \code{summarise <- function(results)},
#'
#' @param dir directory pointing to the .rds files to be
#'   read-in that were saved from \code{runSimulation(..., save_results=TRUE)}.
#'   If \code{NULL}, it is assumed the current working directory contains
#'   the .rds files
#'
#' @param files (optional) names of files to read-in. If \code{NULL} all files
#'   located within \code{dir} will be used
#'
#' @param results (optional) the results of \code{\link{runSimulation}} when no
#'   \code{summarise} function was provided. Can be either a \code{tibble} or
#'   \code{matrix} (indicating that exactly one design condition was evaluated),
#'   or a \code{list} of \code{matrix}/\code{tibble}
#'   objects indicating that multiple conditions were performed with no summarise evaluation.
#'
#'   Alternatively, if \code{store_results = TRUE} in the \code{runSimulation()} execution then
#'   the final SimDesign object may be passed, where the generate-analyse information will be
#'   extracted from the object instead
#'
#' @param Design (optional) if \code{results} input used, and design condition information
#'   important in the summarise step, then the original \code{design} object from
#'   \code{\link{runSimulation}} should be included
#'
#' @param fixed_objects (optional) see \code{\link{runSimulation}} for details
#'
#' @param boot_method method for performing non-parametric bootstrap confidence intervals
#'  for the respective meta-statistics computed by the \code{Summarise} function.
#'  See \code{\link{runSimulation}} for details
#'
#' @param boot_draws number of non-parametric bootstrap draws to sample for the \code{summarise}
#'   function after the generate-analyse replications are collected. Default is 1000
#'
#' @param CI bootstrap confidence interval level (default is 95\%)
#'
#' @param prefix character indicating prefix used for stored files
#'
#' @param write.dir (optional) a character vector used to indicate that after the
#'   \code{reSummarise} is complete the input file should be saved with a suitable sub directory.
#'   This is useful in output like \code{\link{runArraySimulation}} which contains all
#'   the simulation information as \code{.rds} files that should be carried over into the
#'   new files. Only applicable when input files are of class \code{'SimDesign'}
#'
#' @export
#'
#' @author Phil Chalmers \email{rphilip.chalmers@@gmail.com}
#'
#' @references
#'
#' Chalmers, R. P., & Adkins, M. C.  (2020). Writing Effective and Reliable Monte Carlo Simulations
#' with the SimDesign Package. \code{The Quantitative Methods for Psychology, 16}(4), 248-280.
#' \doi{10.20982/tqmp.16.4.p248}
#'
#' Sigal, M. J., & Chalmers, R. P. (2016). Play it again: Teaching statistics with Monte
#' Carlo simulation. \code{Journal of Statistics Education, 24}(3), 136-156.
#' \doi{10.1080/10691898.2016.1246953}
#'
#' @examples
#'
#' Design <- createDesign(N = c(10, 20, 30))
#'
#' Generate <- function(condition, fixed_objects) {
#'     dat <- with(condition, rnorm(N, 10, 5)) # distributed N(10, 5)
#'     dat
#' }
#'
#' Analyse <- function(condition, dat, fixed_objects) {
#'     ret <- c(mean=mean(dat), median=median(dat)) # mean/median of sample data
#'     ret
#' }
#'
#' Summarise <- function(condition, results, fixed_objects){
#'     colMeans(results)
#' }
#'
#' \dontrun{
#' # run the simulation
#' runSimulation(design=Design, replications=50,
#'               generate=Generate, analyse=Analyse,
#'               summarise=Summarise, save_results=TRUE,
#'               save_details = list(save_results_dirname='simresults'))
#'
#'
#' res <- reSummarise(Summarise, dir = 'simresults/')
#' res
#'
#' Summarise2 <- function(condition, results, fixed_objects){
#'     ret <- c(mean_ests=colMeans(results), SE=colSDs(results))
#'     ret
#' }
#'
#' res2 <- reSummarise(Summarise2, dir = 'simresults/')
#' res2
#'
#' SimClean(dir='simresults/')
#'
#' ###################
#' # Similar, but using runArraySimulation() implementation
#'
#' for(i in 1:nrow(Design))
#'     runArraySimulation(design=Design, arrayID=i,
#'                   replications=50,
#'                   generate=Generate, analyse=Analyse,
#'                   summarise=Summarise, iseed=42,
#'                   filename = 'simresults')
#'
#' files <- sprintf('simresults-%i.rds', 1:3)
#' res2 <- reSummarise(Summarise2, files = files)
#' res2
#'
#' # save output as though reSummarise() were used in the original .rds files
#' reSummarise(Summarise2, files = files, write.dir = 'reSummarise')
#' dir('reSummarise')     # new files in sub directory
#'
#' # inspect newly saved RDS files
#' (inp <- SimRead('reSummarise/simresults-1.rds'))
#' SimResults(inp)
#'
#' # collect from all files
#' res <- SimCollect(dir='reSummarise')
#' SimResults(res)
#'
#' # clean
#' SimClean(dirs='reSummarise', files=files)
#'
#'
#' }
#'
#' ###
#' # Results stored within the final object instead and resummarised
#'
#' res <- runSimulation(design=Design, replications=50, store_results = TRUE,
#'                      generate=Generate, analyse=Analyse, summarise=Summarise)
#' res
#'
#' # same summarise but with bootstrapping
#' res2 <- reSummarise(Summarise, results = res, boot_method = 'basic')
#' res2
#'
reSummarise <- function(summarise, dir = NULL, files = NULL, results = NULL, Design = NULL,
                        fixed_objects = NULL, boot_method = 'none', boot_draws = 1000L, CI = .95,
                        prefix = "results-row", write.dir = NULL){
    if(!is.null(results)){
        read_files <- FALSE
        if(is(results, 'SimDesign')){
            obj <- results
            if(is.null(Design))
                Design <- SimExtract(obj, 'Design')
            results <- SimExtract(obj, 'results')
        }
        if(is(results, 'tbl')){
            results <- results[,!(colnames(results) %in% colnames(Design))]
            tmp <- vector('list', nrow(Design))
            reps <- obj$REPLICATIONS[1L]
            for(i in 1L:length(tmp)){
                pick <- 1:reps + (i-1)*reps
                tmp[[i]] <- results[pick, ]
            }
            results <- tmp
        }
        files <- 1L:length(results)
    } else {
        read_files <- TRUE
        current_wd <- getwd()
        on.exit(setwd(current_wd))
        if(!is.null(dir)) setwd(dir)
        if(is.null(files)){
            files <- dir()
            expect_filenames <- paste0(prefix, '-')
            if(!all(grepl(expect_filenames, files)))
                stop('Filenames in select directory did not follow the \'results-row-#\' pattern. Please fix')
        }
    }
    res <- vector('list', length(files))
    conditions <- vector('list', length(files))
    nargs <- length(formals(args(summarise)))
    stopifnot(nargs %in% 1:3)

    for(i in 1L:length(files)){
        if(read_files){
            inp <- SimRead(files[i])
            if(is(inp, 'SimDesign')){
                conditions[[i]] <- SimExtract(inp, what='design')
                results <- SimExtract(inp, what='results')
                last <- colnames(conditions[[i]])
                last <- last[length(last)]
                if(!is.list(results))
                    results <- results[, -c(1:which(colnames(results) == last)), drop=FALSE]
            } else {
                conditions[[i]] <- inp$condition
                results <- inp$results
            }
            summ <- if(nargs == 3)
                try(summarise(condition=conditions[[i]], results=results,
                                  fixed_objects=fixed_objects))
            else if(nargs == 2)
                try(summarise(results=results, fixed_objects=fixed_objects))
            else try(summarise(results))
            if(is(summ, 'try-error'))
                stop(sprintf("File \'%s\' threw an error in the summarise() function", files[i]))
        } else {
            summ <- if(nargs == 3)
                try(summarise(condition=Design[i,], results=results[[i]],
                                  fixed_objects=fixed_objects))
            else if(nargs == 2)
                try(summarise(results=results[[i]], fixed_objects=fixed_objects))
            else try(summarise(results[[i]]))
            if(is(summ, 'try-error'))
                stop(sprintf("Results objec \'%s\' threw an error in the summarise() function", files[i]))
        }

        res[[i]] <- try(sim_results_check(summ, return_list=TRUE))
        if(is(res[[i]], 'try-error'))
            stop(sprintf("File \'%s\' did not return a valid summarise() output", files[i]))
        if(boot_method != 'none'){
            CIs <- if(read_files){
                SimBoot(inp$results, summarise=summarise, condition=inp$condition,
                        fixed_objects=if(is.null(fixed_objects)) inp$fixed_objects else fixed_objects,
                        boot_method=boot_method,
                        boot_draws=boot_draws, CI=CI)
            } else {
                SimBoot(results[[i]], summarise=summarise, condition=Design[i,],
                        fixed_objects=fixed_objects, boot_method=boot_method,
                        boot_draws=boot_draws, CI=CI)
            }
            res[[i]] <- c(res[[i]], CIs)
        }
        if(!is.null(write.dir) && is(inp, 'SimDesign')){
            if(!endsWith(write.dir, '/'))
                write.dir <- paste0(write.dir, '/')
            dir.create(write.dir, showWarnings = FALSE)
            nms <- colnames(SimExtract(inp, 'Design'))
            nms2 <- colnames(inp)
            rm <- c(which(nms[length(nms)] == nms2) + 1, which(nms2 == 'REPLICATIONS')-1)
            out <- inp[ ,-c(rm[1]:rm[2]), drop=FALSE]
            nms2 <- colnames(out)[!(colnames(out) %in% nms)]
            tmp <- res[[i]]
            if(is.numeric(res[[i]])){
                tmp <- matrix(res[[i]], 1)
                colnames(tmp) <- names(res[[i]])
            }
            out <- dplyr::bind_cols(out, tmp)
            out <- out[c(nms, colnames(out)[!(colnames(out) %in% c(nms, nms2))], nms2)]
            saveRDS(out, paste0(write.dir, files[i]))
        }
    }
    is_list <- FALSE
    new_sum <- if(!is.list(res[[1]])){
        do.call(rbind, res)
    } else {
        is_list <- TRUE
        res
    }
    if(read_files){
        Design <- dplyr::bind_rows(conditions)
        if(is_list){
            res <- Design
            res$SUMMARISE <- new_sum
        } else {
            res <- cbind(Design, new_sum)
        }
        res$REPLICATION <- res$ID <- NULL
    } else {
        if(is_list){
            res <- Design
            res$SUMMARISE <- new_sum
        } else {
            res <- cbind(Design, new_sum)
        }
    }
    dplyr::as_tibble(res)
}