gracefull error handling

R/R6Experiment.R

@@ -133,9 +133,10 @@ R6Experiment <- R6::R6Class(
     #' @param checkpoint_frequency Frequency of checkpoints during the experiment. If NULL, defaults to 10 percent of the experimental design.
     #' @param checkpoint_dir Directory to save checkpoints. Default is NULL.
     #' @param backend Backend to use for parallelization. Options are future.apply (default) or foreach.
+    #' @param graceful Logical indicating whether to handle errors gracefully. If TRUE, errors are caught and logged as warnings, and the experiment continues. Default is FALSE.
     #' @param ... Additional parameters passed to model simulation.
     #' @return A data.frame containing the results of the experiment.
-    run = function(checkpoint_frequency = NULL, checkpoint_dir = NULL, backend = "future.apply", ...) {
+    run = function(checkpoint_frequency = NULL, checkpoint_dir = NULL, backend = "future.apply", graceful = TRUE, ...) {
         if (missing(checkpoint_dir)) {
             checkpoint_dir <- file.path("experiments")
         }
@@ -168,7 +169,7 @@ R6Experiment <- R6::R6Class(
 
           for (checkpoint_iteration in seq_len(checkpoint_iterations)) {
             self$run_checkpoint_iteration(
-              checkpoint_iteration, checkpoint_frequency, remaining_steps, overall_progress, checkpoint_file, completed_steps, backend, ...
+              checkpoint_iteration, checkpoint_frequency, remaining_steps, overall_progress, checkpoint_file, completed_steps, backend, graceful, ...
             )
           }
         })
@@ -180,8 +181,9 @@ R6Experiment <- R6::R6Class(
     #' Run a single experiment
     #'
     #' @param policy_design_id ID of the policy design to run
+    #' @param graceful Logical indicating whether to handle errors gracefully. If TRUE, errors are caught and logged as warnings. Default is FALSE.
     #' @param ... additional parameters passed to model simulation
-    run_single_experiment = function(policy_design_id, ...) {
+    run_single_experiment = function(policy_design_id, graceful, ...) {
       model <- self$models[[self$policy_design$model.id[policy_design_id]]]
 
       id_cols <- c("grid.id", "lhs.id", "params_design.id", "param.id", "model.id", "all.params.id", "policy.exp.id", "rep.id", "seed")
@@ -200,7 +202,17 @@ R6Experiment <- R6::R6Class(
         set.seed(self$policy_design[policy_design_id, ]$seed)
       }
 
-      res <- model$simulate(...) %>% as.data.frame()
+      # Graceful error handling implementation
+      if (graceful) {
+        res <- tryCatch({
+          model$simulate(...) %>% as.data.frame()
+        }, error = function(e) {
+          warning("Error in experiment ", policy_design_id, ": ", e$message, call. = FALSE)
+          data.frame(error = e$message)
+        })
+      } else {
+        res <- model$simulate(...) %>% as.data.frame()
+      }
 
       return(dplyr::bind_cols(self$policy_design[policy_design_id, ], res))
     },
@@ -227,21 +239,22 @@ R6Experiment <- R6::R6Class(
     #' @param checkpoint_file Path to the file where the checkpoint will be saved.
     #' @param completed_steps Number of steps already completed in the experiment.
     #' @param backend Backend to use for parallelization. Options are "future.apply" (default) or "foreach".
+    #' @param graceful Logical indicating whether to handle errors gracefully. If TRUE, errors are caught and logged as warnings. Default is FALSE.
     #' @param ... Additional parameters passed to model simulation.
-    run_checkpoint_iteration = function(checkpoint_iteration, checkpoint_frequency, remaining_steps, overall_progress, checkpoint_file, completed_steps, backend, ...) {
+    run_checkpoint_iteration = function(checkpoint_iteration, checkpoint_frequency, remaining_steps, overall_progress, checkpoint_file, completed_steps, backend, graceful, ...) {
       checkpoint_start <- completed_steps + (checkpoint_iteration - 1) * checkpoint_frequency + 1
       checkpoint_end <- min(completed_steps + checkpoint_iteration * checkpoint_frequency, completed_steps + remaining_steps)
 
       if (backend == "future.apply") {
         checkpoint_results <- future.apply::future_lapply(seq(checkpoint_start, checkpoint_end), function(policy_design_id) {
           overall_progress(sprintf("Running policy design %d", policy_design_id))
-          self$run_single_experiment(policy_design_id, ...)
+          self$run_single_experiment(policy_design_id, graceful, ...)
         }, future.seed=TRUE, future.packages = c("dplyr", "R6Sim", "progressr"))
         checkpoint_results <- dplyr::bind_rows(checkpoint_results)
       } else if (backend == "foreach") {
         checkpoint_results <- foreach(policy_design_id = seq(checkpoint_start, checkpoint_end), .combine = dplyr::bind_rows, .options.future = list(seed = TRUE)) %dofuture% {
           overall_progress(sprintf("Running policy design %d", policy_design_id))
-          self$run_single_experiment(policy_design_id, ...)
+          self$run_single_experiment(policy_design_id, graceful, ...)
         }
       } else {
         stop("Unsupported backend. Please choose either 'future.apply' or 'foreach'.")

tests/testthat/test-R6Experiment.R

@@ -132,3 +132,145 @@ test_that("R6Experiment produces identical results with the same seed", {
   unlink(temp_checkpoint_dir1, recursive = TRUE)
   unlink(temp_checkpoint_dir2, recursive = TRUE)
 })
+
+# Test graceful error handling functionality
+
+test_that("R6Experiment handles errors gracefully when graceful = TRUE", {
+  # Create a mock model that will throw an error
+  ErrorModel <- R6::R6Class(
+    classname = "ErrorModel",
+    inherit = R6Sim,
+    public = list(
+      should_error = FALSE,
+
+      initialize = function(name) {
+        super$initialize(name = name)
+        self$set_input("Test1", 1)
+      },
+
+      simulate = function() {
+        if (self$should_error) {
+          stop("Simulated error for testing")
+        }
+        return(data.frame(result = 42))
+      }
+    )
+  )
+
+  error_model <- ErrorModel$new(name = "error_test")
+  error_model$should_error <- TRUE
+
+  experiment <- R6Experiment$new(error_model)
+  experiment$set_parameter(parameter_name = "Test1", experimental_design = "grid", values = c(1, 2))
+  experiment$set_design(n_reps = 2)
+
+  # Capture warnings
+  temp_checkpoint_dir <- tempfile()
+
+  # Test graceful = TRUE
+  expect_warning(
+    results_graceful <- experiment$run(checkpoint_dir = temp_checkpoint_dir, graceful = TRUE),
+    "Error in experiment"
+  )
+
+  # Check that results contain error column
+  expect_true("error" %in% names(results_graceful))
+  expect_true(all(results_graceful$error == "Simulated error for testing"))
+  expect_equal(nrow(results_graceful), nrow(experiment$policy_design))
+
+  # Clean up
+  unlink(temp_checkpoint_dir, recursive = TRUE)
+})
+
+test_that("R6Experiment stops execution when graceful = FALSE and error occurs", {
+  # Create a mock model that will throw an error
+  ErrorModel <- R6::R6Class(
+    classname = "ErrorModel",
+    inherit = R6Sim,
+    public = list(
+      should_error = FALSE,
+
+      initialize = function(name) {
+        super$initialize(name = name)
+        self$set_input("Test1", 1)
+      },
+
+      simulate = function() {
+        if (self$should_error) {
+          stop("Simulated error for testing")
+        }
+        return(data.frame(result = 42))
+      }
+    )
+  )
+
+  error_model <- ErrorModel$new(name = "error_test")
+  error_model$should_error <- TRUE
+
+  experiment <- R6Experiment$new(error_model)
+  experiment$set_parameter(parameter_name = "Test1", experimental_design = "grid", values = c(1, 2))
+  experiment$set_design(n_reps = 2)
+
+  temp_checkpoint_dir <- tempfile()
+
+  # Test graceful = FALSE (default behavior)
+  expect_error(
+    experiment$run(checkpoint_dir = temp_checkpoint_dir, graceful = FALSE),
+    "Simulated error for testing"
+  )
+
+  # Clean up
+  unlink(temp_checkpoint_dir, recursive = TRUE)
+})
+
+test_that("R6Experiment mixed success and error scenarios with graceful = TRUE", {
+  # Create a model that errors on specific conditions
+  ConditionalErrorModel <- R6::R6Class(
+    classname = "ConditionalErrorModel",
+    inherit = R6Sim,
+    public = list(
+      initialize = function(name) {
+        super$initialize(name = name)
+        self$set_input("Test1", 1)
+      },
+
+      simulate = function() {
+        # Error when Test1 == 2
+        if (self$inputs$Test1 == 2) {
+          stop("Error when Test1 equals 2")
+        }
+        return(data.frame(result = self$inputs$Test1 * 10))
+      }
+    )
+  )
+
+  conditional_model <- ConditionalErrorModel$new(name = "conditional_test")
+
+  experiment <- R6Experiment$new(conditional_model)
+  experiment$set_parameter(parameter_name = "Test1", experimental_design = "grid", values = c(1, 2, 3))
+  experiment$set_design(n_reps = 1)
+
+  temp_checkpoint_dir <- tempfile()
+
+  # Test with graceful = TRUE
+  expect_warning(
+    results <- experiment$run(checkpoint_dir = temp_checkpoint_dir, graceful = TRUE),
+    "Error in experiment"
+  )
+
+  # Check mixed results
+  expect_equal(nrow(results), 3)
+
+  # Check successful runs
+  successful_runs <- results[is.na(results$error) | results$error == "", ]
+  expect_equal(nrow(successful_runs), 2)
+  expect_true(all(successful_runs$result %in% c(10, 30)))
+
+  # Check error runs
+  error_runs <- results[!is.na(results$error) & results$error != "", ]
+  expect_equal(nrow(error_runs), 1)
+  expect_equal(error_runs$error, "Error when Test1 equals 2")
+
+  # Clean up
+  unlink(temp_checkpoint_dir, recursive = TRUE)
+})