Fix issue with spurious error messages due to output handling after user interrupt.

Author: MaartenMarsman

R/bgm.R

@@ -588,6 +588,41 @@ bgm = function(
     nThreads = cores, seed = seed, progress_type = progress_type
   )
 
+
+  userInterrupt = any(vapply(out, FUN = `[[`, FUN.VALUE = logical(1L), "userInterrupt"))
+  if (userInterrupt) {
+    warning("Stopped sampling after user interrupt, results are likely uninterpretable.")
+    # Try to prepare output, but catch any errors
+    output <- tryCatch(
+      prepare_output_bgm(
+        out = out, x = x, num_categories = num_categories, iter = iter,
+        data_columnnames = if (is.null(colnames(x))) paste0("Variable ", seq_len(ncol(x))) else colnames(x),
+        is_ordinal_variable = variable_bool,
+        warmup = warmup, pairwise_scale = pairwise_scale,
+        main_alpha = main_alpha, main_beta = main_beta,
+        na_action = na_action, na_impute = na_impute,
+        edge_selection = edge_selection, edge_prior = edge_prior, inclusion_probability = inclusion_probability,
+        beta_bernoulli_alpha = beta_bernoulli_alpha, beta_bernoulli_beta = beta_bernoulli_beta,
+        dirichlet_alpha = dirichlet_alpha, lambda = lambda,
+        variable_type = variable_type,
+        update_method = update_method,
+        target_accept = target_accept,
+        hmc_num_leapfrogs = hmc_num_leapfrogs,
+        nuts_max_depth = nuts_max_depth,
+        learn_mass_matrix = learn_mass_matrix,
+        num_chains = chains
+      ),
+      error = function(e) {
+        list(partial = out, error = conditionMessage(e))
+      },
+      warning = function(w) {
+        # still salvage what we can
+        list(partial = out, warning = conditionMessage(w))
+      }
+    )
+    return(output)
+  }
+
   # Main output handler in the wrapper function
   output = prepare_output_bgm (
     out = out, x = x, num_categories = num_categories, iter = iter,
@@ -634,9 +669,5 @@ bgm = function(
     }
   }
 
-  userInterrupt = any(vapply(out, FUN = `[[`, FUN.VALUE = logical(1L), "userInterrupt"))
-  if (userInterrupt)
-    warning("Stopped sampling after user interrupt, results are likely uninterpretable.")
-
   return(output)
 }

R/bgmCompare.R

@@ -514,6 +514,45 @@ bgmCompare = function(
     progress_type = progress_type
   )
 
+  userInterrupt = any(vapply(out, FUN = `[[`, FUN.VALUE = logical(1L), "userInterrupt"))
+  if (userInterrupt) {
+    warning("Stopped sampling after user interrupt, results are likely uninterpretable.")
+    output <- tryCatch(
+      prepare_output_bgmCompare(
+        out = out,
+        observations = observations,
+        num_categories = num_categories,
+        is_ordinal_variable = ordinal_variable,
+        num_groups = num_groups,
+        iter = iter,
+        warmup = warmup,
+        main_effect_indices = main_effect_indices,
+        pairwise_effect_indices = pairwise_effect_indices,
+        data_columnnames = if (is.null(colnames(x))) paste0("Variable ", seq_len(ncol(x))) else colnames(x),
+        difference_selection = difference_selection,
+        difference_prior = difference_prior,
+        difference_selection_alpha = beta_bernoulli_alpha,
+        difference_selection_beta = beta_bernoulli_beta,
+        pairwise_scale = pairwise_scale,
+        difference_scale = difference_scale,
+        update_method = update_method,
+        target_accept = target_accept,
+        nuts_max_depth = nuts_max_depth,
+        hmc_num_leapfrogs = hmc_num_leapfrogs,
+        learn_mass_matrix = learn_mass_matrix,
+        num_chains = chains,
+        projection = projection
+      ),
+      error = function(e) {
+        list(partial = out, error = conditionMessage(e))
+      },
+      warning = function(w) {
+        list(partial = out, warning = conditionMessage(w))
+      }
+    )
+    return(output)
+  }
+
   # Main output handler in the wrapper function
   output = prepare_output_bgmCompare(
     out = out,
@@ -545,9 +584,5 @@ bgmCompare = function(
     output$nuts_diag = nuts_diag
   }
 
-  userInterrupt = any(vapply(out, FUN = `[[`, FUN.VALUE = logical(1L), "userInterrupt"))
-  if (userInterrupt)
-    warning("Stopped sampling after user interrupt, results are likely uninterpretable.")
-
   return(output)
 }