Catch R errors and reject transition, closes #22

Author: andrjohns

R/util.R

@@ -100,7 +100,16 @@ prepare_inputs <- function(fn, par_inits, n_pars, extra_args_list, grad_fun, low
          call. = FALSE)
   }
 
-  fn1 <- function(v) { do.call(fn, c(list(v), extra_args_list)) }
+  fn1 <- function(v) {
+    # Catch errors in user function and return -Inf with message as attribute
+    tryCatch({
+      do.call(fn, c(list(v), extra_args_list))
+    }, error = function(e) {
+      res <- -Inf
+      attr(res, "message") <- e$message
+      res
+    })
+  }
   for (chain in seq_len(num_chains)) {
     validate_function(fn1, inits[[chain]], extra_args_list, grad = FALSE)
   }
@@ -121,7 +130,16 @@ prepare_inputs <- function(fn, par_inits, n_pars, extra_args_list, grad_fun, low
     fun_packages <- c(gp$packages, packages)
   }
   if (!is.null(grad_fun)) {
-    gr1 <- function(v) { do.call(grad_fun, c(list(v), extra_args_list)) }
+    gr1 <- function(v) {
+      # Catch errors in user function and return -Inf with message as attribute
+      tryCatch({
+        do.call(grad_fun, c(list(v), extra_args_list))
+      }, error = function(e) {
+        res <- rep(-Inf, length(v))
+        attr(res, "message") <- e$message
+        res
+      })
+    }
     for (chain in seq_len(num_chains)) {
       validate_function(gr1, inits[[chain]], extra_args_list, grad = TRUE)
     }

src/include/estimator/estimator_ext_header.hpp

@@ -43,7 +43,13 @@ double r_function(const T& v,
                   std::ostream* pstream__) {
   double lp = 0;
   auto v_cons = stan::math::lub_constrain<jacobian__>(v, lower_bounds, upper_bounds, lp);
-  return Rcpp::as<double>(internal::ll_fun(v_cons)) + lp;
+  SEXP res = internal::ll_fun(v_cons);
+  // If the result has a "message" attribute, it indicates an error in the user function
+  if (Rcpp::RObject(res).hasAttribute("message")) {
+    std::string msg = Rcpp::as<std::string>(Rcpp::RObject(res).attr("message"));
+    throw std::domain_error("Error in user-defined function: " + msg);
+  }
+  return Rcpp::as<double>(res) + lp;
 }
 
 template <bool jacobian__, typename T, stan::require_st_var<T>* = nullptr>
@@ -69,7 +75,13 @@ stan::math::var r_function(const T& v,
     rtn = funwrap(v.val());
   } else {
     arena_v = stan::math::lub_constrain<jacobian__>(v, lower_bounds, upper_bounds, lp);
-    arena_grad = Rcpp::as<Eigen::VectorXd>(internal::grad_fun(arena_v.val()));
+    SEXP res = internal::grad_fun(arena_v.val());
+    // If the result has a "message" attribute, it indicates an error in the user function
+    if (Rcpp::RObject(res).hasAttribute("message")) {
+      std::string msg = Rcpp::as<std::string>(Rcpp::RObject(res).attr("message"));
+      throw std::domain_error("Error in user-defined gradient function: " + msg);
+    }
+    arena_grad = Rcpp::as<Eigen::VectorXd>(res);
     rtn = Rcpp::as<double>(internal::ll_fun(arena_v.val()));
   }
   return make_callback_var(