R/database.R

In rbiogeme: Interface to 'Biogeme'

#' Validate a data frame for use as a Biogeme database
#'
#' @param data An R data frame.
#' @return A validated, copied data frame.
#' @keywords internal
validate_biogeme_data <- function(data) {
  if (!is.data.frame(data)) {
    stop("data must be an R data.frame.", call. = FALSE)
  }
  if (nrow(data) == 0L) {
    stop("data must contain at least one row.", call. = FALSE)
  }
  if (ncol(data) == 0L) {
    stop("data must contain at least one column.", call. = FALSE)
  }
  column_names <- names(data)
  if (is.null(column_names) || anyNA(column_names) || any(!nzchar(column_names))) {
    stop("All data columns must have non-empty names.", call. = FALSE)
  }
  if (anyDuplicated(column_names)) {
    stop("Data column names must be unique.", call. = FALSE)
  }
  is_valid_numeric <- vapply(
    data,
    function(column) is.numeric(column) && !is.complex(column),
    logical(1)
  )
  if (any(!is_valid_numeric)) {
    invalid <- paste(column_names[!is_valid_numeric], collapse = ", ")
    stop(
      "All database columns must be numeric. Invalid column(s): ",
      invalid,
      call. = FALSE
    )
  }
  data <- as.data.frame(data, check.names = FALSE)
  row.names(data) <- NULL
  data
}

#' Create a Biogeme database
#'
#' The database remains an R object until a model is compiled. Data are copied
#' and validated at construction time, so later modifications to the original
#' data frame do not alter the model database.
#'
#' @param name Database name.
#' @param data Numeric R data frame.
#' @return An object of class `biogeme_database`.
#' @details
#' The input must contain only numeric, named, non-empty columns. The original
#' row identifiers are retained separately from the data columns and are
#' carried through native filtering and row-extraction operations.
#' @examples
#' database <- biogeme_database(
#'   "demo",
#'   data.frame(choice = c(1, 2), income = c(10, 20))
#' )
#' biogeme_database_columns(database)
#' @export
biogeme_database <- function(name, data) {
  name <- validate_name(name, "name")
  validated_data <- validate_biogeme_data(data)
  structure(
    list(
      name = name,
      data = validated_data,
      # R row names are normalised on the public data frame for backwards
      # compatibility.  The original identifiers live separately and are
      # carried through native filtering operations by the Python bridge.
      row_ids = row.names(data),
      derived_variables = list(),
      filters = list(),
      panel_id = NULL,
      filtered_row_count = NA_integer_,
      number_of_excluded_data = 0L,
      materialized = TRUE
    ),
    class = "biogeme_database"
  )
}

#' @export
print.biogeme_database <- function(x, ...) {
  cat(
    "Biogeme database '", x$name, "' with ",
    nrow(x$data), " rows and ", ncol(x$data), " columns\n",
    sep = ""
  )
  invisible(x)
}

#' @export
format.biogeme_database <- function(x, ...) {
  paste0(
    "Biogeme database '", x$name, "' (",
    nrow(x$data), " rows, ", ncol(x$data), " columns)"
  )
}

#' @export
as.data.frame.biogeme_database <- function(x, row.names = NULL, optional = FALSE, ...) {
  x$data
}

#' Return the columns available in a Biogeme database
#'
#' @param database A `biogeme_database` object.
#' @return A character vector of column names.
#' @export
biogeme_database_columns <- function(database) {
  validate_biogeme_database(database)
  unique(c(names(database$data), names(database$derived_variables)))
}

validate_biogeme_database <- function(database) {
  if (!inherits(database, "biogeme_database") ||
      !is.list(database) ||
      !is.character(database$name) ||
      length(database$name) != 1L ||
      !is.data.frame(database$data) ||
      is.null(database$row_ids) ||
      length(database$row_ids) != nrow(database$data) ||
      !is.list(database$derived_variables) ||
      !is.list(database$filters)) {
    stop("database must be a valid biogeme_database object.", call. = FALSE)
  }
  invisible(database)
}

#' Test whether a Biogeme database contains a column
#'
#' @param database A `biogeme_database` object.
#' @param column Column name.
#' @return A single logical value.
#' @export
biogeme_database_has_column <- function(database, column) {
  validate_biogeme_database(database)
  column %in% biogeme_database_columns(database)
}

database_copy_metadata <- function(database, ...) {
  validate_biogeme_database(database)
  result <- database
  extras <- list(...)
  for (name in names(extras)) result[[name]] <- extras[[name]]
  result
}

#' Return the original row identifiers of a Biogeme database
#' @param database A `biogeme_database` object.
#' @return A character vector of row identifiers.
#' @export
biogeme_database_row_ids <- function(database) {
  validate_biogeme_database(database)
  as.character(database$row_ids)
}

#' Return the number of rows currently represented by a database
#' @param database A `biogeme_database` object.
#' @return An integer, or `NA` until lazy native filters are materialised.
#' @export
biogeme_database_nrow <- function(database) {
  validate_biogeme_database(database)
  if (isTRUE(database$materialized) || length(database$filters) == 0L) {
    return(as.integer(nrow(database$data)))
  }
  if (!is.na(database$filtered_row_count)) {
    return(as.integer(database$filtered_row_count))
  }
  NA_integer_
}

#' Return the number of observations excluded by native database filters
#' @param database A `biogeme_database` object.
#' @return An integer, or `NA` until lazy filters are materialised.
#' @export
biogeme_database_filtered_row_count <- function(database) {
  validate_biogeme_database(database)
  if (isTRUE(database$materialized) && is.na(database$filtered_row_count)) return(0L)
  database$filtered_row_count
}

#' Define a derived database variable using a complete Biogeme expression
#' @param database A `biogeme_database` object.
#' @param name Name of the derived column.
#' @param expression Complete Biogeme expression.
#' @return A new database specification.
#' @details
#' The expression is retained symbolically and is compiled by the Python
#' bridge together with the model. It is not evaluated by an R callback during
#' estimation or simulation.
#' @examples
#' database <- biogeme_database(
#'   "demo",
#'   data.frame(time = c(10, 12), cost = c(5, 6))
#' )
#' database <- biogeme_database_define_variable(
#'   database, "time_cost", variable("time") / variable("cost")
#' )
#' biogeme_database_columns(database)
#' @export
biogeme_database_define_variable <- function(database, name, expression) {
  validate_biogeme_database(database)
  name <- validate_name(name, "name")
  if (biogeme_database_has_column(database, name)) {
    stop("Database variable '", name, "' already exists.", call. = FALSE)
  }
  expression <- as_biogeme_expression(expression)
  unknown <- setdiff(collect_biogeme_variables(expression), biogeme_database_columns(database))
  if (length(unknown) > 0L) {
    stop("Derived variable expression refers to unknown column(s): ", paste(unknown, collapse = ", "), call. = FALSE)
  }
  derived <- database$derived_variables
  derived[[name]] <- expression
  database_copy_metadata(
    database,
    derived_variables = derived,
    materialized = FALSE,
    filtered_row_count = NA_integer_
  )
}

#' @rdname biogeme_database_define_variable
#' @export
database_define_variable <- biogeme_database_define_variable

#' @rdname biogeme_database_define_variable
#' @export
define_variable <- biogeme_database_define_variable

#' Remove observations satisfying a Biogeme logical expression
#' @param database A `biogeme_database` object.
#' @param condition Logical Biogeme expression; matching rows are removed.
#' @return A new database specification.
#' @details
#' `condition` is a symbolic indicator. Rows for which it is true are removed
#' when the database is materialized by native Biogeme.
#' @examples
#' database <- biogeme_database(
#'   "demo",
#'   data.frame(choice = c(1, 2, 1), income = c(10, 20, 30))
#' )
#' filtered <- biogeme_database_remove(database, variable("income") > 10)
#' biogeme_database_nrow(filtered)
#' @export
biogeme_database_remove <- function(database, condition) {
  validate_biogeme_database(database)
  condition <- as_biogeme_expression(condition)
  unknown <- setdiff(collect_biogeme_variables(condition), biogeme_database_columns(database))
  if (length(unknown) > 0L) {
    stop("Database filter refers to unknown column(s): ", paste(unknown, collapse = ", "), call. = FALSE)
  }
  database_copy_metadata(
    database,
    filters = c(database$filters, list(condition)),
    materialized = FALSE,
    filtered_row_count = NA_integer_
  )
}

#' @rdname biogeme_database_remove
#' @export
database_remove <- biogeme_database_remove

#' @rdname biogeme_database_remove
#' @export
remove_observations <- biogeme_database_remove

#' Declare and validate a panel identifier
#' @param database A `biogeme_database` object.
#' @param panel_id Name of the panel identifier column.
#' @return A new panel database specification.
#' @details
#' The identifier must be numeric and finite. Observations
#' belonging to one identifier must be contiguous; the constructor rejects
#' interleaved panel rows rather than silently reordering them.
#' @examples
#' panel_database <- biogeme_panel_database(
#'   "panel_demo",
#'   data.frame(person = c(1, 1, 2, 2), choice = c(1, 2, 2, 1)),
#'   panel_id = "person"
#' )
#' biogeme_database_is_panel(panel_database)
#' @export
biogeme_database_panel <- function(database, panel_id) {
  validate_biogeme_database(database)
  panel_id <- validate_name(panel_id, "panel_id")
  if (!biogeme_database_has_column(database, panel_id)) {
    stop("Panel identifier column '", panel_id, "' is not present in the database.", call. = FALSE)
  }
  values <- database$data[[panel_id]]
  if (anyNA(values) || any(!is.finite(values))) {
    stop("Panel identifier column must not contain missing or non-finite values.", call. = FALSE)
  }
  # A panel is valid only when observations for each individual form one
  # contiguous block.  This is the same invariant enforced by Biogeme's
  # native contiguous panel map.
  runs <- rle(values)
  seen <- unique(values)
  if (length(seen) != length(runs$values)) {
    stop("Panel observations must be grouped contiguously by panel_id.", call. = FALSE)
  }
  database_copy_metadata(database, panel_id = panel_id)
}

#' Construct a panel database in one call
#' @param name Database name.
#' @param data Numeric data frame.
#' @param panel_id Panel identifier column.
#' @return A `biogeme_database` object.
#' @export
biogeme_panel_database <- function(name, data, panel_id) {
  biogeme_database_panel(biogeme_database(name, data), panel_id)
}

#' Return whether a database has a declared panel structure
#' @param database A `biogeme_database` object.
#' @return One logical value.
#' @export
biogeme_database_is_panel <- function(database) {
  validate_biogeme_database(database)
  !is.null(database$panel_id)
}

#' Extract observations from a Biogeme database
#'
#' This is the R equivalent of native `Database.extract_rows()`. Indices are
#' deliberately one-based, as in the rest of the R interface, and the
#' original row identifiers are retained in the returned database.
#'
#' @param database A `biogeme_database` object.
#' @param indices Unique positive one-based row indices, in the order to keep.
#' @return A new `biogeme_database` containing the selected observations.
#' @export
biogeme_database_extract_rows <- function(database, indices) {
  validate_biogeme_database(database)
  if (!isTRUE(database$materialized) || length(database$derived_variables) > 0L ||
      length(database$filters) > 0L) {
    database <- biogeme_materialize_database(database)
  }
  if (!is.numeric(indices) || length(indices) == 0L || anyNA(indices) ||
      any(!is.finite(indices)) || any(indices != floor(indices)) ||
      any(indices < 1) || any(indices > nrow(database$data)) ||
      anyDuplicated(indices)) {
    stop("indices must contain unique valid one-based row indices.", call. = FALSE)
  }
  indices <- as.integer(indices)
  result <- database
  result$data <- database$data[indices, , drop = FALSE]
  row.names(result$data) <- NULL
  result$row_ids <- as.character(database$row_ids[indices])
  result$filtered_row_count <- as.integer(nrow(result$data))
  result$number_of_excluded_data <- as.integer(
    database$number_of_excluded_data + nrow(database$data) - nrow(result$data)
  )
  result$derived_variables <- list()
  result$filters <- list()
  result$materialized <- TRUE
  if (!is.null(result$panel_id)) {
    result <- biogeme_database_panel(result, result$panel_id)
  }
  result
}

#' @rdname biogeme_database_extract_rows
#' @export
database_extract_rows <- biogeme_database_extract_rows