R/build_neighbors.R

In gwrf: Geographically Weighted Random Forests

#' Build a Spatial Neighborhood
#'
#' Identifies neighboring observations or unique spatial locations for a
#' focal observation.
#'
#' @param coords Numeric matrix or data frame containing spatial coordinates.
#' @param focal_index Integer index identifying the focal observation.
#' @param bandwidth Numeric bandwidth. For adaptive neighborhoods, this is
#'   the number of neighboring rows or unique locations.
#' @param adaptive Logical indicating whether an adaptive neighborhood is used.
#' @param neighbor_unit Character string indicating whether neighborhoods
#'   are defined using individual data rows (`"row"`) or unique spatial
#'   locations (`"location"`).
#' @param location_id Optional vector identifying the spatial location
#'   associated with each observation. Required when
#'   `neighbor_unit = "location"`.
#'
#' @return A list describing the spatial neighborhood of the focal
#' observation. The list contains:
#' \describe{
#'   \item{neighbor_index}{Integer vector giving the rows of `coords`
#'   included in the local neighborhood.}
#'   \item{distances}{Numeric vector containing the distance from the focal
#'   location to each selected neighboring row.}
#'   \item{local_bandwidth}{Numeric value giving the realized local bandwidth.
#'   For adaptive neighborhoods this is the distance to the most distant
#'   selected neighbor; for fixed neighborhoods it is the supplied bandwidth.}
#'   \item{all_distances}{Numeric vector of distances from the focal location
#'   to all candidate rows or unique locations, depending on `neighbor_unit`.}
#'   \item{neighbor_unit}{Character string indicating whether the neighborhood
#'   was constructed using rows or unique locations.}
#'   \item{neighbor_location_id}{For location-based neighborhoods, the
#'   identifiers of the selected unique locations; `NULL` for row-based
#'   neighborhoods.}
#' }
#'
#' @examples
#' coords <- matrix(
#'   c(0, 0,
#'     1, 0,
#'     2, 0,
#'     3, 0,
#'     4, 0),
#'   ncol = 2,
#'   byrow = TRUE
#' )
#'
#' build_neighbors(
#'   coords = coords,
#'   focal_index = 3,
#'   bandwidth = 3,
#'   adaptive = TRUE
#' )
#' @export
build_neighbors <- function(
    coords,
    focal_index,
    bandwidth,
    adaptive = TRUE,
    neighbor_unit = c("row", "location"),
    location_id = NULL
) {
  neighbor_unit <- match.arg(neighbor_unit)

  coords <- as.matrix(coords)

  if (!is.numeric(coords) || ncol(coords) != 2) {
    stop("coords must be a numeric matrix/data.frame with exactly 2 columns.")
  }

  if (!is.numeric(focal_index) || length(focal_index) != 1 ||
      focal_index < 1 || focal_index > nrow(coords)) {
    stop("focal_index is out of range.")
  }

  if (!is.numeric(bandwidth) || length(bandwidth) != 1 || is.na(bandwidth) || bandwidth <= 0) {
    stop("bandwidth must be one positive numeric value.")
  }

  if (neighbor_unit == "row") {
    focal_xy <- coords[focal_index, , drop = FALSE]

    dx <- coords[, 1] - focal_xy[1, 1]
    dy <- coords[, 2] - focal_xy[1, 2]
    distances <- sqrt(dx^2 + dy^2)

    if (adaptive) {
      k <- min(as.integer(bandwidth), nrow(coords))
      ord <- order(distances)
      neighbor_index <- ord[seq_len(k)]
      local_bandwidth <- max(distances[neighbor_index])
    } else {
      neighbor_index <- which(distances <= bandwidth)
      local_bandwidth <- bandwidth
    }

    return(list(
      neighbor_index = neighbor_index,
      distances = distances[neighbor_index],
      local_bandwidth = local_bandwidth,
      all_distances = distances,
      neighbor_unit = neighbor_unit,
      neighbor_location_id = NULL
    ))
  }

  if (neighbor_unit == "location") {
    if (is.null(location_id)) {
      stop("location_id is required when neighbor_unit = 'location'.")
    }

    if (length(location_id) != nrow(coords)) {
      stop("location_id must have the same length as the number of rows in coords.")
    }

    location_id <- as.character(location_id)

    if (any(is.na(location_id))) {
      stop("location_id cannot contain NA values.")
    }

    focal_location <- location_id[focal_index]

    # One coordinate per unique location, preserving first occurrence order
    unique_locations <- unique(location_id)
    first_row_for_location <- match(unique_locations, location_id)
    location_coords <- coords[first_row_for_location, , drop = FALSE]

    focal_location_pos <- match(focal_location, unique_locations)
    focal_xy <- location_coords[focal_location_pos, , drop = FALSE]

    dx <- location_coords[, 1] - focal_xy[1, 1]
    dy <- location_coords[, 2] - focal_xy[1, 2]
    location_distances <- sqrt(dx^2 + dy^2)

    if (adaptive) {
      k <- min(as.integer(bandwidth), length(unique_locations))
      ord <- order(location_distances)
      neighbor_location_pos <- ord[seq_len(k)]
      neighbor_locations <- unique_locations[neighbor_location_pos]
      local_bandwidth <- max(location_distances[neighbor_location_pos])
    } else {
      neighbor_location_pos <- which(location_distances <= bandwidth)
      neighbor_locations <- unique_locations[neighbor_location_pos]
      local_bandwidth <- bandwidth
    }

    neighbor_index <- which(location_id %in% neighbor_locations)

    # Expand location-level distances back to row-level distances
    distance_lookup <- stats::setNames(
      location_distances[neighbor_location_pos],
      neighbor_locations
    )

    row_distances <- unname(distance_lookup[location_id[neighbor_index]])

    return(list(
      neighbor_index = neighbor_index,
      distances = row_distances,
      local_bandwidth = local_bandwidth,
      all_distances = location_distances,
      neighbor_unit = neighbor_unit,
      neighbor_location_id = neighbor_locations
    ))
  }
}