R/replace_partition.R

In kuenm2: Detailed Development of Ecological Niche Models

#' Replace partitions in prepared data
#'
#' @description
#' Replaces the test partitions in a `prepared_data` object with spatial
#' partitions generated by ENMeval or flexsdm.
#'
#' @param data A `prepared_data` object returned by [prepare_data()].
#'   It must contain `calibration_data` and `data_xy`. The latter is available
#'   when `prepare_data()` is called with `include_xy = TRUE`.
#' @param new_block A partition object. For `block_source = "ENMeval"`,
#'   it must contain `occs.grp` and `bg.grp`, as returned by
#'   `ENMeval::get.block()`. For `block_source = "flexsdm"`, it must contain
#'   a `part` data frame with `x`, `y`, `pr_ab`, and `.part` columns, as
#'   returned by `flexsdm::part_sblock()`.
#' @param block_source The package that generated `new_block`: `"ENMeval"`
#'   or `"flexsdm"`.
#' @param enmeval_occs The occurrence table supplied as `occs` to
#'   `ENMeval::get.block()`. Required when `block_source = "ENMeval"`.
#'   It must have numeric `x` and `y` columns and retain the original row order.
#' @param enmeval_bg The background table supplied as `bg` to
#'   `ENMeval::get.block()`. Required when `block_source = "ENMeval"`.
#'   It must have numeric `x` and `y` columns and retain the original row order.
#' @param tolerance Maximum absolute difference allowed between corresponding
#'   coordinate values during validation. Set to `0` to require exact numeric
#'   equality. Defaults to `1e-8`.
#'
#' @details
#' The function checks that coordinates match in the same row order before
#' replacing the partitions.
#'
#' For ENMeval, occurrence records must precede background records in
#' `data$calibration_data`. The function compares `enmeval_occs` and
#' `enmeval_bg` with the corresponding rows of `data$data_xy` separately.
#'
#' For flexsdm, the function compares the coordinates and occurrence/background
#' labels in `new_block$part` with `data$data_xy` and
#' `data$calibration_data$pr_bg`, respectively.
#'
#' The returned object has updated `part_data`, `partition_method`, and
#' `n_partitions` components.
#'
#' @return A `prepared_data` object with a new partition.
#'
#' @export
#'
#' @examples
#' # Load prepared data
#' data(sp_swd, package = "kuenm2")
#'
#' # Load environmental raster layers
#' var <- terra::rast(system.file("extdata", "Current_variables.tif",
#'                                package = "kuenm2"))
#'
#' # Use a spatial block partition from flexsdm
#' # Load example output from flexsdm::part_sblock()
#' data(flexsdm_block, package = "kuenm2")
#'
#' # Replace the existing partitions
#' d_flexsdm <- replace_partition(
#'   data = sp_swd,
#'   new_block = flexsdm_block,
#'   block_source = "flexsdm"
#' )
#' # Explore the partitions in geographic space
#' pbg_flexsdm <- explore_partition_geo(d_flexsdm, raster_variables = var)
#' terra::plot(pbg_flexsdm)
#'
#' # Use a spatial block partition from ENMeval
#' # Load example output from ENMeval::get.block()
#' data(enmeval_block, package = "kuenm2")
#'
#' # Supply the same occurrence and background points, in the same order,
#' # that were used to generate the ENMeval blocks
#' occs <- sp_swd$data_xy[sp_swd$calibration_data$pr_bg == 1, ]  # Occurrences
#' bg <- sp_swd$data_xy[sp_swd$calibration_data$pr_bg == 0, ]  # Background
#'
#' # Replace the existing partitions
#' d_enmeval <- replace_partition(
#'   data = sp_swd,
#'   new_block = enmeval_block,
#'   block_source = "ENMeval",
#'   enmeval_occs = occs,
#'   enmeval_bg = bg
#' )
#'
#' # Explore the partitions in geographic space
#' pbg_enmeval <- explore_partition_geo(d_enmeval, raster_variables = var)
#' terra::plot(pbg_enmeval)
replace_partition <- function(data, new_block,
                              block_source = c("ENMeval", "flexsdm"),
                              enmeval_occs = NULL, enmeval_bg = NULL,
                              tolerance = 1e-8) {
  block_source <- match.arg(block_source)

  if (!inherits(data, "prepared_data") ||
      is.null(data$calibration_data) ||
      is.null(data$data_xy)) {
    stop("'data' must contain calibration_data and data_xy.")
  }

  if (!is.numeric(tolerance) || length(tolerance) != 1L ||
      !is.finite(tolerance) || tolerance < 0) {
    stop("'tolerance' must be a single non-negative finite number.")
  }

  calibration_data <- data$calibration_data
  if (!"pr_bg" %in% colnames(calibration_data)) {
    stop("'data$calibration_data' must contain 'pr_bg'.")
  }

  response <- as.character(calibration_data[, "pr_bg"])
  if (anyNA(response) || !all(response %in% c("0", "1"))) {
    stop("'pr_bg' must contain only 1 (occurrence) and 0 (background).")
  }

  n_occ <- sum(response == "1")
  n_bg <- sum(response == "0")

  if (n_occ == 0L || n_bg == 0L) {
    stop("'calibration_data' must contain occurrences and background.")
  }

  if (block_source == "ENMeval") {
    if (is.null(enmeval_occs) || is.null(enmeval_bg)) {
      stop("Provide 'enmeval_occs' and 'enmeval_bg' for ENMeval blocks.")
    }
    if (!is.list(new_block) ||
        is.null(new_block$occs.grp) ||
        is.null(new_block$bg.grp)) {
      stop("'new_block' must contain 'occs.grp' and 'bg.grp'.")
    }

    # ENMeval indices assume occurrences precede background records.
    if (!identical(response, c(rep("1", n_occ), rep("0", n_bg)))) {
      stop("ENMeval requires occurrences before background in calibration_data.")
    }

    prepared_xy <- data$data_xy
    check_coordinates(
      prepared_xy[seq_len(n_occ), , drop = FALSE],
      enmeval_occs, "enmeval_occs", tolerance = tolerance
    )
    check_coordinates(
      prepared_xy[n_occ + seq_len(n_bg), , drop = FALSE],
      enmeval_bg, "enmeval_bg", tolerance = tolerance
    )

    occ_groups <- validate_groups(
      new_block$occs.grp, n_occ, "new_block$occs.grp"
    )
    bg_groups <- validate_groups(
      new_block$bg.grp, n_bg, "new_block$bg.grp"
    )

    ids <- sort(unique(c(occ_groups, bg_groups)))
    partitions <- lapply(ids, function(id) {
      c(which(occ_groups == id), n_occ + which(bg_groups == id))
    })
  } else {
    if (!is.list(new_block) ||
        !is.data.frame(new_block$part) ||
        !all(c("x", "y", "pr_ab", ".part") %in% names(new_block$part))) {
      stop(
        "'new_block$part' must have 'x', 'y', 'pr_ab', and '.part' columns."
      )
    }

    part <- new_block$part
    check_coordinates(data$data_xy, part, "new_block$part",
                      tolerance = tolerance)

    # Also confirm that occurrence/background labels match row by row.
    if (!identical(as.character(part$pr_ab), response)) {
      stop("'new_block$part$pr_ab' does not match 'calibration_data$pr_bg'.")
    }

    groups <- validate_groups(part$.part, length(response),
                              "new_block$part$.part")
    ids <- sort(unique(groups))
    partitions <- lapply(ids, function(id) which(groups == id))
  }

  if (length(partitions) < 2L) {
    stop("The new partition must contain at least two blocks.")
  }

  names(partitions) <- paste0("Partition_", ids)

  data$part_data <- partitions
  data$partition_method <- paste0("Spatial block (", block_source, ")")
  data$n_partitions <- length(partitions)
  data$train_proportion <- NULL
  return(data)
}