R/evaluation.R

In rbiogeme: Interface to 'Biogeme'

#' Evaluate a standalone expression with native Biogeme
#'
#' The expression is compiled once by the Python bridge. The initial result
#' contains the native function value, gradient, Hessian, and BHHH matrix. If
#' `points` is supplied, the same compiled native callable evaluates each row
#' with the requested free-parameter values. R does not evaluate the
#' expression locally and no Python object is returned.
#'
#' @param expression A Biogeme expression.
#' @param beta Optional named numeric vector used for the initial evaluation.
#'   When omitted, native Beta starting values are used.
#' @param points Optional data frame or numeric matrix. Its columns are free
#'   parameter names and its rows are the parameter vectors for repeated
#'   native evaluations.
#' @param numerically_safe Whether to request native numerically safe
#'   formulas.
#' @param use_jit Whether to use native JAX just-in-time compilation.
#' @return An object of class `biogeme_expression_evaluation` with `initial`,
#'   `free_beta_names`, and `evaluations` components.
#' @export
evaluate_biogeme_expression <- function(
    expression,
    beta = NULL,
    points = NULL,
    numerically_safe = FALSE,
    use_jit = TRUE
) {
  expression <- as_biogeme_expression(expression)

  if (!is.null(beta)) {
    if (!is.numeric(beta) || is.null(names(beta)) || length(beta) == 0L ||
        anyNA(names(beta)) || any(!nzchar(names(beta))) ||
        anyDuplicated(names(beta)) || anyNA(beta) || any(!is.finite(beta))) {
      stop(
        "beta must be a non-empty named finite numeric vector.",
        call. = FALSE
      )
    }
  }

  if (!is.null(points)) {
    if (is.matrix(points)) {
      if (!is.numeric(points)) {
        stop("points must be a numeric matrix or data frame.", call. = FALSE)
      }
      points <- as.data.frame(points, check.names = FALSE)
    } else if (!is.data.frame(points)) {
      stop("points must be a numeric matrix or data frame.", call. = FALSE)
    }
    if (is.null(names(points)) || anyNA(names(points)) ||
        any(!nzchar(names(points))) || anyDuplicated(names(points))) {
      stop("points must have unique, non-empty column names.", call. = FALSE)
    }
    if (ncol(points) > 0L &&
        !all(vapply(points, is.numeric, logical(1)))) {
      stop("Every points column must be numeric.", call. = FALSE)
    }
    if (nrow(points) > 0L &&
        any(!is.finite(as.matrix(points)))) {
      stop("points must contain only finite numeric values.", call. = FALSE)
    }
    point_rows <- lapply(seq_len(nrow(points)), function(index) {
      setNames(
        lapply(points[index, , drop = TRUE], as.numeric),
        names(points)
      )
    })
  } else {
    point_rows <- NULL
  }

  if (!is.logical(numerically_safe) || length(numerically_safe) != 1L ||
      is.na(numerically_safe) || !is.logical(use_jit) || length(use_jit) != 1L ||
      is.na(use_jit)) {
    stop(
      "numerically_safe and use_jit must be one non-missing logical value each.",
      call. = FALSE
    )
  }

  raw <- tryCatch(
    biogeme_bridge()$evaluate_expression_biogeme(
      expression = reticulate::r_to_py(biogeme_expression_ir(expression)),
      beta_values = if (is.null(beta)) NULL else reticulate::r_to_py(as.list(beta)),
      evaluation_points = if (is.null(point_rows)) NULL else
        reticulate::r_to_py(point_rows),
      numerically_safe = numerically_safe,
      use_jit = use_jit
    ),
    error = function(error) {
      biogeme_rethrow(
        error,
        class = "biogeme_evaluation_error",
        operation = "native Biogeme expression evaluation",
        suggestion = "check the expression, parameter names, and evaluation points"
      )
    }
  )
  result <- reticulate::py_to_r(raw)
  structure(result, class = "biogeme_expression_evaluation")
}

#' @export
print.biogeme_expression_evaluation <- function(x, ...) {
  cat("Native Biogeme expression evaluation\n")
  cat("Free parameters: ", paste(x$free_beta_names, collapse = ", "), "\n", sep = "")
  cat("Initial value: ", x$initial[["function"]], "\n", sep = "")
  if (length(x$evaluations) > 0L) {
    cat("Repeated evaluations: ", length(x$evaluations), "\n", sep = "")
  }
  invisible(x)
}