|
| 1 | +#' Extract Simulation Errors |
| 2 | +#' |
| 3 | +#' Extractor function in situations where \code{\link{runSimulation}} returned a simulation |
| 4 | +#' with detected \code{ERRORS}. |
| 5 | +#' |
| 6 | +#' @param obj object returned from \code{\link{runSimulation}} containing an \code{ERRORS} column |
| 7 | +#' |
| 8 | +#' @param seeds logical; locate \code{.Random.seed} state that caused the error message? |
| 9 | +#' |
| 10 | +#' @param subset logical; take a subset of the \code{design} object showing only conditions that |
| 11 | +#' returned errors? |
| 12 | +#' |
| 13 | +#' @references |
| 14 | +#' |
| 15 | +#' Chalmers, R. P., & Adkins, M. C. (2020). Writing Effective and Reliable Monte Carlo Simulations |
| 16 | +#' with the SimDesign Package. \code{The Quantitative Methods for Psychology, 16}(4), 248-280. |
| 17 | +#' \doi{10.20982/tqmp.16.4.p248} |
| 18 | +#' |
| 19 | +#' Sigal, M. J., & Chalmers, R. P. (2016). Play it again: Teaching statistics with Monte |
| 20 | +#' Carlo simulation. \code{Journal of Statistics Education, 24}(3), 136-156. |
| 21 | +#' \doi{10.1080/10691898.2016.1246953} |
| 22 | +#' |
| 23 | +#' @author Phil Chalmers \email{rphilip.chalmers@@gmail.com} |
| 24 | +#' |
| 25 | +#' @seealso \code{\link{SimWarnings}}, \code{\link{SimExtract}} |
| 26 | +#' |
| 27 | +#' @examples |
| 28 | +#' |
| 29 | +#' sample_sizes <- c(10, 20) |
| 30 | +#' standard_deviations <- 1 |
| 31 | +#' |
| 32 | +#' Design <- createDesign(N1=sample_sizes, |
| 33 | +#' N2=sample_sizes, |
| 34 | +#' SD=standard_deviations) |
| 35 | +#' Design |
| 36 | +#' |
| 37 | +#' Generate <- function(condition, fixed_objects){ |
| 38 | +#' Attach(condition) |
| 39 | +#' group1 <- rnorm(N1) |
| 40 | +#' group2 <- rnorm(N2, sd=SD) |
| 41 | +#' dat <- data.frame(group = c(rep('g1', N1), rep('g2', N2)), |
| 42 | +#' DV = c(group1, group2)) |
| 43 | +#' dat |
| 44 | +#' } |
| 45 | +#' |
| 46 | +#' Analyse <- function(condition, dat, fixed_objects){ |
| 47 | +#' |
| 48 | +#' # raise errors with unequal sample sizes only |
| 49 | +#' if(with(condition, N1 != N2)){ |
| 50 | +#' if(runif(1, 0, 1) < .9) t.test('char') |
| 51 | +#' if(runif(1, 0, 1) < .9) aov('char') |
| 52 | +#' if(runif(1, 0, 1) < .2) stop('my error') |
| 53 | +#' } |
| 54 | +#' |
| 55 | +#' welch <- t.test(DV ~ group, dat) |
| 56 | +#' ind <- stats::t.test(DV ~ group, dat, var.equal=TRUE) |
| 57 | +#' ret <- c(welch = welch$p.value, independent = ind$p.value) |
| 58 | +#' ret |
| 59 | +#' } |
| 60 | +#' |
| 61 | +#' Summarise <- function(condition, results, fixed_objects) { |
| 62 | +#' ret <- EDR(results) |
| 63 | +#' ret |
| 64 | +#' } |
| 65 | +#' |
| 66 | +#' # print any error messages and their frequency |
| 67 | +#' res <- runSimulation(design=Design, replications=3, generate=Generate, |
| 68 | +#' analyse=Analyse, summarise=Summarise, max_errors = Inf) |
| 69 | +#' res |> select(N1, N2, SD, ERRORS) |
| 70 | +#' SimErrors(res) |
| 71 | +#' SimErrors(res, subset=FALSE) |
| 72 | +#' |
| 73 | +#' # for specific seeds (organized list of SEEDS returned) |
| 74 | +#' (seeds <- SimErrors(res, seeds=TRUE)) |
| 75 | +#' names(seeds$SEEDS[[1]]) # first row errors |
| 76 | +#' |
| 77 | +#' # extract one .Random.seed state for the first design condition where |
| 78 | +#' # error occurred, pointing to the second uniquely recorded error message |
| 79 | +#' seeds$SEEDS[[1]][[2]][, 1] -> seed_state |
| 80 | +#' seed_state # note that Design_row_2 is where the error occurred |
| 81 | +#' |
| 82 | +#' \dontrun{ |
| 83 | +#' # pass to runSimulation() to replicate issue (not run as this calls debug()) |
| 84 | +#' runSimulation(design=Design[2,], replications=3, generate=Generate, |
| 85 | +# analyse=Analyse, summarise=Summarise, |
| 86 | +# load_seed=seed_state, debug='analyse') |
| 87 | +#' } |
| 88 | +#' |
| 89 | +#' |
| 90 | +#' |
| 91 | +SimErrors <- function(obj, seeds=FALSE, subset=TRUE){ |
| 92 | + if(!any(colnames(obj) == 'ERRORS')) return(dplyr::tibble()) |
| 93 | + errors <- obj$ERRORS |
| 94 | + pick <- which(errors > 0) |
| 95 | + ret <- SimExtract(obj, what='errors') |
| 96 | + if(seeds){ |
| 97 | + eseeds <- SimExtract(obj, what = 'error_seeds') |
| 98 | + design <- SimExtract(obj, what = 'design') |
| 99 | + out <- vector('list', nrow(design)) |
| 100 | + for(i in seq_along(pick)){ |
| 101 | + p <- pick[i] |
| 102 | + ecol <- eseeds[,grepl(paste0('Design_row_', p, '.'), colnames(eseeds))] |
| 103 | + nms <- gsub(".*Error", 'Error', colnames(ecol)) |
| 104 | + nms <- gsub("\\.",' ', nms) |
| 105 | + u <- unique(nms) |
| 106 | + out[[p]] <- lapply(as.list(u), \(mtc) ecol[ ,which(mtc == nms)]) |
| 107 | + names(out[[p]]) <- u |
| 108 | + } |
| 109 | + ret <- dplyr::tibble(design, SEEDS=out) |
| 110 | + } |
| 111 | + if(subset) ret <- ret[pick, ] |
| 112 | + ret |
| 113 | +} |
0 commit comments