R/DemandPoints.R

In jeffreyhanson/raptr: Representative and Adequate Prioritization Toolkit in R

#' @include RcppExports.R raptr-internal.R generics.R
NULL

#' DemandPoints: An S4 class to represent demand points
#'
#' This class is used to store demand point information.
#'
#' @slot coords [base::matrix()] of coordinates for each demand point.
#'
#' @slot weights `numeric` weights for each demand point.
#'
#' @seealso [DemandPoints()].
#'
#' @name DemandPoints-class
#'
#' @rdname DemandPoints-class
#'
#' @exportClass DemandPoints
methods::setClass("DemandPoints",
  methods::representation(coords = "matrix", weights = "numeric"),
  validity = function(object) {
    # check coords have variance
    if (nrow(object@coords) > 1) {
      assertthat::assert_that(
        max(apply(object@coords, 2, function(x) length(unique(x)))) > 1,
       msg = "demand points must not all be identical"
      )
    }
    # check coords are not NA
    assertthat::assert_that(
      assertthat::noNA(c(object@coords))
    )
    assertthat::assert_that(
      nrow(object@coords) > 0,
      msg = "argument to coords must have at least one row"
    )
    # weights
    assertthat::assert_that(
      assertthat::noNA(object@weights)
    )
    assertthat::assert_that(
      length(object@weights) > 0,
      msg = "argument to weights must have at least one element"
    )
    assertthat::assert_that(
      all(object@weights > 0),
      msg = "argument to weights must have positive numbers"
    )
    # cross-slot dependencies
    assertthat::assert_that(
      identical(nrow(object@coords), length(object@weights)),
      msg = paste0(
        "argument to points must have have ",
        "the same number of rows as the ",
        "length of weights"
      )
    )
    return(TRUE)
  }
)

#' Create new DemandPoints object
#'
#' This function creates a new `DemandPoints` object
#'
#' @param coords [base::matrix()] of coordinates for each demand point.
#'
#' @param weights `numeric` weights for each demand point.
#'
#' @return A new `DemandPoints` object.
#'
#' @seealso [DemandPoints-class].
#'
#' @examples
#' \dontrun{
#' # make demand points
#' dps <- DemandPoints(
#'  matrix(rnorm(100), ncol=2),
#'  runif(50)
#' )
#'
#' # print object
#' print(dps)
#' }
#' @export
DemandPoints <- function(coords, weights) {
  dp <- methods::new("DemandPoints", coords = coords, weights = weights)
  methods::validObject(dp, test = FALSE)
  return(dp)
}

#' Generate demand points for RAP
#'
#' This function generates demand points to characterize a distribution of
#' points.
#'
#' @param points [base::matrix()] object containing points.
#'
#' @param n `integer` number of demand points to use for each attribute
#'   space for each species. Defaults to `100L`.
#'
#' @param quantile `numeric` quantile to generate demand points within. If
#'   0 then demand points are generated across the full range of values the
#'   `points` intersect. Defaults to `0.5`.
#'
#' @param kernel.method `character` name of kernel method to use to
#'   generate demand points. Defaults to `'ks'`.
#'
#' @param ... arguments passed to kernel density estimating functions
#'
#' @return A new [DemandPoints()] object.
#'
#' @details Broadly speaking, demand points are generated by fitting a kernal
#'   to the input `points`. A shape is then fit to the extent of
#'   the kernal, and then points are randomly generated inside the shape. The
#'   demand points are generated as random points inside the shape. The weights
#'   for each demand point are calculated the estimated density of input points
#'   at the demand point. By supplying 'ks' as an argument to `method` in
#'   `kernel.method`, the shape is defined using a minimum convex polygon
#'   [adehabitatHR::mcp()] and [ks::kde()] is used to fit
#'   the kernel. Note this can only be used when the data is low-dimensional (d
#'   < 3). By supplying `"hypervolume"` as an argument to `method`,
#'   the [hypervolume::hypervolume()] function is used to create the
#'   demand points. This method can be used for hyper-dimensional data
#'   (\eqn{d << 3}).
#'
#' @seealso [hypervolume::hypervolume()], [ks::kde()],
#'   [adehabitatHR::mcp()].
#'
#' @examples
#' \dontrun{
#' # set random number generator seed
#' set.seed(500)
#'
#' # load data
#' cs_spp <- terra::rast(
#'   system.file("extdata", "cs_spp.tif", package = "raptr")
#' )
#' cs_space <- terra::rast(
#'   system.file("extdata", "cs_space.tif", package = "raptr")
#' )
#'
#' # generate species points
#' species.points <- randomPoints(cs_spp[[1]], n = 100, prob = TRUE)
#' env.points <- as.matrix(terra::extract(cs_space, species.points))
#'
#' # generate demand points for a 1d space using ks
#' dps1 <- make.DemandPoints(points = env.points[, 1], kernel.method = "ks")
#'
#' # print object
#' print(dps1)
#'
#' # generate demand points for a 2d space using hypervolume
#' dps2 <- make.DemandPoints(
#'   points = env.points,
#'   kernel.method = "hypervolume",
#'   samples.per.point = 50,
#'   verbose = FALSE
#' )
#'
#' # print object
#' print(dps2)
#' }
#' @export
make.DemandPoints <- function(points,
                              n = 100L, quantile = 0.5,
                              kernel.method = c("ks", "hypervolume")[1],
                              ...) {
  # check inputs for validity
  assertthat::assert_that(
    is.matrix(points) || is.numeric(points)
  )
  assertthat::assert_that(
    assertthat::noNA(c(points)),
    msg = "argument to points contains non-finite values"
  )
  kernel.method <- match.arg(kernel.method, c("ks", "hypervolume"))
  # convert to matrix
  if (!inherits(points, "matrix") && inherits(points, "numeric")) {
    points <- matrix(points, ncol = 1)
  }
  assertthat::assert_that(
    !(ncol(points) > 2 && kernel.method != "hypervolume"),
    msg = paste0(
      "argument to kernel.method must be ",
      "\"hypervolume\" when points has more two columns"
    )
  )
  # generate demand points
  if (kernel.method == "ks") {
    if (ncol(points) == 1) {
      dp <- demand.points.density1d(points, n = n, quantile = quantile, ...)
    }
    if (ncol(points) == 2) {
      dp <- demand.points.density2d(points, n = n, quantile = quantile, ...)
    }
  } else {
    dp <- demand.points.hypervolume(points, n = n, quantile = quantile, ...)
  }
  # return demand points
  DemandPoints(coords = dp$coords, weights = dp$weights)
}