#' @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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.