R/errors.R

In rbiogeme: Interface to 'Biogeme'

biogeme_error_condition <- function(
    message,
    class,
    operation = NULL,
    suggestion = NULL,
    parent = NULL,
    python_traceback = NULL
) {
  display_message <- message
  if (!is.null(suggestion) && nzchar(suggestion)) {
    display_message <- paste0(display_message, " Suggestion: ", suggestion)
  }
  structure(
    list(
      message = display_message,
      raw_message = message,
      call = NULL,
      operation = operation,
      suggestion = suggestion,
      parent = parent,
      python_traceback = python_traceback
    ),
    class = c(class, "biogeme_error", "error", "condition")
  )
}

biogeme_abort <- function(
    message,
    class,
    operation = NULL,
    suggestion = NULL,
    parent = NULL
) {
  traceback <- NULL
  if (isTRUE(.biogeme_state$debug)) {
    traceback <- tryCatch(
      paste(capture.output(reticulate::py_last_error()), collapse = "\n"),
      error = function(...) NULL
    )
  }
  stop(
    biogeme_error_condition(
      message = message,
      class = class,
      operation = operation,
      suggestion = suggestion,
      parent = parent,
      python_traceback = traceback
    )
  )
}

biogeme_rethrow <- function(
    error,
    class,
    operation,
    suggestion
) {
  if (inherits(error, "biogeme_error")) {
    stop(error)
  }
  biogeme_abort(
    message = paste0(operation, " failed: ", conditionMessage(error)),
    class = class,
    operation = operation,
    suggestion = suggestion,
    parent = error
  )
}

#' @exportS3Method conditionMessage biogeme_error
conditionMessage.biogeme_error <- function(c) {
  c$message
}

#' Return the diagnostic details attached to a Biogeme error
#'
#' @param error A condition inheriting from `biogeme_error`.
#' @return A named list with operation, suggestion, parent, and optional Python
#'   traceback details.
#' @export
biogeme_error_details <- function(error) {
  if (!inherits(error, "biogeme_error")) {
    stop("error must be a Biogeme error condition.", call. = FALSE)
  }
  list(
    class = class(error)[[1L]],
    operation = error$operation,
    suggestion = error$suggestion,
    parent = error$parent,
    python_traceback = error$python_traceback
  )
}