Add prepare function for condition-level object preparation

R/SimExtract.R

@@ -17,6 +17,10 @@
 #'   \code{runSimulation(..., control = list(store_Random.seeds=TRUE))}),
 #'   \code{'error_seeds'} and \code{'warning_seeds'}
 #'   to extract the associated \code{.Random.seed} values associated with the ERROR/WARNING messages,
+#'   \code{'prepare_seeds'} to extract the \code{.Random.seed} states captured before
+#'   \code{prepare()} was called for each condition, \code{'prepare_error_seed'} to extract the
+#'   \code{.Random.seed} state when \code{prepare()} encountered an error (useful for debugging with
+#'   \code{load_seed_prepare}),
 #'   \code{'results'} to extract the simulation results if the option \code{store_results} was passed to
 #'   \code{\link{runSimulation}}, \code{'filename'} and \code{'save_results_dirname'} for extracting
 #'   the saved file/directory name information (if used), \code{'functions'} to extract the defined functions
@@ -113,6 +117,10 @@ SimExtract <- function(object, what, fuzzy = TRUE, append = TRUE){
         if(length(wrn) && append) cbind(Design, wrn) else wrn
     } else if(what == 'warning_seeds'){
         extract_warning_seeds(object)
+    } else if(what == 'prepare_seeds'){
+        extract_prepare_seeds(object)
+    } else if(what == 'prepare_error_seed'){
+        extract_prepare_error_seed(object)
     } else if(what == 'save_results_dirname'){
         attr(object, 'extra_info')$save_info['save_results_dirname']
     } else if(what == 'filename'){
@@ -188,6 +196,18 @@ extract_functions <- function(object){
     ret
 }
 
+extract_prepare_seeds <- function(object){
+    extra_info <- attr(object, 'extra_info')
+    ret <- extra_info$prepare_seeds
+    ret
+}
+
+extract_prepare_error_seed <- function(object){
+    extra_info <- attr(object, 'extra_info')
+    ret <- extra_info$prepare_error_seeds
+    ret
+}
+
 fuzzy_reduce <- function(df){
     if(!length(df)) return(df)
     nms <- colnames(df)

R/analysis.R

@@ -1,4 +1,5 @@
-Analysis <- function(Functions, condition, replications, fixed_objects, prepare = NULL, cl, MPI, seed, save,
+Analysis <- function(Functions, condition, replications, fixed_objects, prepare = NULL,
+                     load_seed_prepare = NULL, cl, MPI, seed, save,
                      save_results, save_results_out_rootdir, save_results_dirname, max_errors,
                      boot_method, boot_draws, CI,
                      save_seeds, save_seeds_dirname, load_seed,
@@ -12,9 +13,34 @@ Analysis <- function(Functions, condition, replications, fixed_objects, prepare
     #  and number of replications desired
 
     # Call prepare function once per condition if provided
+    prepare_error_seed <- NULL
+    prepare_Random.seed <- NULL
     if(!is.null(prepare)) {
+
+        # Restore seed if debugging prepare
+        if(!is.null(load_seed_prepare))
+            .GlobalEnv$.Random.seed <- load_seed_prepare
+
+        # Ensure .Random.seed exists (initialize RNG if needed)
+        else if(!exists(".Random.seed", envir = .GlobalEnv))
+            runif(1)
+
+        # Capture seed state before prepare (similar to mainsim line 296)
+        prepare_Random.seed <- .GlobalEnv$.Random.seed
+
+        # Save seed to disk if requested
+        if(save_seeds){
+            filename <- paste0(save_seeds_dirname, '/design-row-', condition$ID, '/prepare-seed')
+            dir.create(dirname(file.path(save_results_out_rootdir, filename)),
+                       showWarnings = FALSE, recursive = TRUE)
+            write(prepare_Random.seed, file.path(save_results_out_rootdir, filename), sep = ' ')
+        }
+
         prep_result <- try(prepare(condition=condition, fixed_objects=fixed_objects), silent=FALSE)
+
         if(is(prep_result, 'try-error')){
+            # Capture seed on error (similar to mainsim)
+            prepare_error_seed <- prepare_Random.seed
             stop(sprintf('prepare() failed for condition %i with error: %s',
                          condition$ID, as.character(prep_result)), call.=FALSE)
         }
@@ -222,9 +248,17 @@ Analysis <- function(Functions, condition, replications, fixed_objects, prepare
     attr(ret, 'error_seeds') <- try_error_seeds
     attr(ret, 'warning_seeds') <- warning_message_seeds
     attr(ret, 'summarise_list') <- summarise_list
+    if(!is.null(prepare_error_seed))
+        attr(ret, 'prepare_error_seed') <- prepare_error_seed
+
     if(store_results)
         attr(ret, 'full_results') <- tabled_results
-    if(store_Random.seeds)
+    if(store_Random.seeds){
         attr(ret, 'stored_Random.seeds') <- stored_Random.seeds
+        # Store prepare seed information
+        if(!is.null(prepare)) {
+            attr(ret, 'prepare_Random.seed') <- prepare_Random.seed
+        }
+    }
     ret
 }

R/runSimulation.R

@@ -342,6 +342,15 @@
 #'   then it WILL be important to modify the \code{design} input in order to load this
 #'   exact seed for the corresponding design row. Default is \code{NULL}
 #'
+#' @param load_seed_prepare similar to \code{load_seed}, but specifically for
+#'   debugging the \code{prepare} function. Used to replicate the exact RNG state
+#'   when prepare is called for a given condition. Accepts the same input formats
+#'   as \code{load_seed}: a character string path (e.g., \code{'design-row-2/prepare-seed'}),
+#'   an integer vector containing the \code{.Random.seed} state, or a tibble/data.frame
+#'   with seed values. This is particularly useful when prepare encounters an error
+#'   and you need to reproduce the exact state. The prepare error seed can be
+#'   extracted using \code{SimExtract(res, 'prepare_error_seed')}. Default is \code{NULL}
+#'
 #' @param filename (optional) the name of the \code{.rds} file to save the final
 #' simulation results to. If the extension
 #'   \code{.rds} is not included in the file name (e.g. \code{"mysimulation"}
@@ -1030,7 +1039,8 @@
 #'
 runSimulation <- function(design, replications, generate, analyse, summarise,
                           prepare = NULL, fixed_objects = NULL, packages = NULL, filename = NULL,
-                          debug = 'none', load_seed = NULL, save = any(replications > 2),
+                          debug = 'none', load_seed = NULL, load_seed_prepare = NULL,
+                          save = any(replications > 2),
                           store_results = TRUE, save_results = FALSE,
                           parallel = FALSE, ncores = parallelly::availableCores(omit = 1L),
                           cl = NULL, notification = 'none', notifier = NULL,
@@ -1298,6 +1308,24 @@ runSimulation <- function(design, replications, generate, analyse, summarise,
             load_seed <- as.integer(as.data.frame(load_seed)[,1])
         stopifnot(is.integer(load_seed))
     }
+    # Validate load_seed_prepare (same logic as load_seed)
+    if(!is.null(load_seed_prepare)){
+        if(length(load_seed_prepare) == 7L){
+            rngkind <- RNGkind()
+            RNGkind("L'Ecuyer-CMRG")
+            on.exit(RNGkind(rngkind[1L]), add = TRUE)
+        }
+        if(is.character(load_seed_prepare)){
+            # Character path to saved prepare seed file
+            # Only prepend save_seeds_dirname if it's a relative path
+            if(!file.exists(load_seed_prepare))
+                load_seed_prepare <- paste0(save_seeds_dirname, '/', load_seed_prepare)
+            load_seed_prepare <- as.integer(scan(load_seed_prepare, sep = ' ', quiet = TRUE))
+        }
+        if(is(load_seed_prepare, 'tbl'))
+            load_seed_prepare <- as.integer(as.data.frame(load_seed_prepare)[,1])
+        stopifnot(is.integer(load_seed_prepare))
+    }
     if(MPI){
         parallel <- FALSE
         verbose <- FALSE
@@ -1515,6 +1543,7 @@ runSimulation <- function(design, replications, generate, analyse, summarise,
                                          replications=replications[i],
                                          fixed_objects=fixed_objects,
                                          prepare=prepare,
+                                         load_seed_prepare=load_seed_prepare,
                                          cl=if(i %in% not_parallel) NULL else cl,
                                          MPI=MPI, .options.mpi=.options.mpi, seed=seed,
                                          boot_draws=boot_draws, boot_method=boot_method, CI=CI,
@@ -1557,6 +1586,7 @@ runSimulation <- function(design, replications, generate, analyse, summarise,
                             replications=replications[i],
                             fixed_objects=fixed_objects,
                             prepare=prepare,
+                            load_seed_prepare=load_seed_prepare,
                             cl=if(i %in% not_parallel) NULL else cl,
                             MPI=MPI, .options.mpi=.options.mpi, seed=seed,
                             store_Random.seeds=store_Random.seeds,
@@ -1602,6 +1632,8 @@ runSimulation <- function(design, replications, generate, analyse, summarise,
             attr(Result_list[[i]], 'error_seeds') <- attr(tmp, 'error_seeds')
             attr(Result_list[[i]], 'warning_seeds') <- attr(tmp, 'warning_seeds')
             attr(Result_list[[i]], 'summarise_list') <- attr(tmp, 'summarise_list')
+            attr(Result_list[[i]], 'prepare_Random.seed') <- attr(tmp, 'prepare_Random.seed')
+            attr(Result_list[[i]], 'prepare_error_seed') <- attr(tmp, 'prepare_error_seed')
             Result_list[[i]]$COMPLETED <- date()
             time1 <- proc.time()[3L]
             Result_list[[i]]$SIM_TIME <- time1 - time0
@@ -1712,6 +1744,17 @@ runSimulation <- function(design, replications, generate, analyse, summarise,
                                 rownames(ret))
         t(ret)
     })))
+    # Collect prepare seeds
+    prepare_seeds <- lapply(1L:length(Result_list), function(x) {
+        attr(Result_list[[x]], "prepare_Random.seed")
+    })
+    prepare_error_seeds <- lapply(1L:length(Result_list), function(x) {
+        attr(Result_list[[x]], "prepare_error_seed")
+    })
+    # Remove NULL entries from error seeds
+    prepare_error_seeds <- Filter(Negate(is.null), prepare_error_seeds)
+    if(length(prepare_error_seeds) == 0L) prepare_error_seeds <- NULL
+
     summarise_list <- lapply(1L:length(Result_list), function(x)
         attr(Result_list[[x]], "summarise_list")
     )
@@ -1785,6 +1828,8 @@ runSimulation <- function(design, replications, generate, analyse, summarise,
                                       date_completed = noquote(date()), total_elapsed_time = sum(SIM_TIME),
                                       error_seeds=dplyr::as_tibble(error_seeds),
                                       warning_seeds=dplyr::as_tibble(warning_seeds),
+                                      prepare_seeds=prepare_seeds,
+                                      prepare_error_seeds=prepare_error_seeds,
                                       stored_results = if(store_results) stored_Results_list else NULL,
                                       Design.ID=Design.ID,
                                       functions=list(Generate=Generate, Analyse=Analyse, Summarise=Summarise))