diff --git a/.Rbuildignore b/.Rbuildignore index 7eecac2..de12ac6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -4,3 +4,4 @@ ^\.vscode$ ^LICENSE\.md$ ^src/Makevars$ +^\.claude$ diff --git a/DESCRIPTION b/DESCRIPTION index b181f7c..485114f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,14 +1,22 @@ Package: ClassicHCAS Type: Package Title: The Classic Habitat Condition Assessment System (HCAS) -Version: 1.1.0 -Date: 2026-03-18 -Author: Roozbeh Valavi, Eric Lehmann, Kristen Williams, Mike Birchall, Simon Collings, Simon Ferrier, and Tom Harwood -Maintainer: +Version: 2.0.0 +Date: 2026-07-02 +Authors@R: c( + person(given = "Roozbeh", family = "Valavi", + email = "roozbeh.valavi@csiro.au", role = c("aut", "cre")), + person(given = "Kristen", family = "Williams", role = "aut"), + person(given = "Eric", family = "Lehmann", role = "aut"), + person(given = "Simon", family = "Collings", role = "aut"), + person(given = "Tom", family = "Harwood", role = "aut"), + person(given = "Mike", family = "Birchall", role = "aut"), + person(given = "Simon", family = "Ferrier", role = "aut")) URL: https://github.com/csiro/ClassicHCAS BugReports: https://github.com/csiro/ClassicHCAS/issues +Maintainer: Roozbeh Valavi Description: The HCAS evaluates habitat condition by comparing observed and - predicted remote sensing variables using reference ecosystem samples (Valavi et al. 2026). + predicted remote sensing variables using reference ecosystem samples. License: GPL (>= 3) Encoding: UTF-8 LazyData: true @@ -19,12 +27,17 @@ Imports: scales, terra (>= 1.7.71) Suggests: + ggplot2, + leafem, + leaflet, methods, knitr, rmarkdown, + shiny, + shinyWidgets, tinytest, testthat (>= 3.0.0) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 VignetteBuilder: knitr Config/testthat/edition: 3 LinkingTo: diff --git a/NAMESPACE b/NAMESPACE index 0feea2a..888484c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,13 +2,17 @@ S3method(plot,reference_density) S3method(print,reference_density) +export(aggregate_importance) export(benchmark) export(calibrate) +export(hcas_inspection) export(normalise) export(palettes) export(radial_count) export(ref_density) +export(reference_use) export(tiling) +export(variable_importance) import(Rcpp) importFrom(Rcpp,sourceCpp) useDynLib(ClassicHCAS, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 874cc09..4fa0fae 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,55 +1,75 @@ +# Version 2.0.0 + +- Added a boosted condition estimator to `benchmark()`, `reference_use()`, `variable_importance()`, and `hcas_inspection()`. The default is now `boost = k2`, with `k1 = 70` and `k2 = 10`: the highest-probability retained site's kernel weight is multiplied by the boost factor before computing condition, condition attribution, or variable-importance weights. Set `boost = NULL` or `boost = NA` to use the previous unboosted LDC/ordinary-kernel behaviour. +- Renamed the public `k_pred` and `k_obs` arguments to `k1` and `k2`, respectively, to identify them as the first- and second-stage reference filters rather than imply that each filter is tied exclusively to an environmental or observed-RS definition. +- Added an experimental expanded temporal reference mode to `benchmark()`. It is off by default; supply `temporal_sigma` to enable it. `temporal_sigma` controls the bandwidth of the Gaussian temporal weighting used to select and weight the most relevant reference year for each site. Reference samples can be supplied as a named list of yearly matrices. This expands the temporal representation of reference sites rather than applying a post-hoc correction to the target condition score. +- Added selectable retained-reference distance kernels. `kernel = "Gaussian"` remains the default and uses `exp(-(distance / lambda)^2)`; `kernel = "Cauchy"` uses the standard Cauchy shape `1 / (1 + (distance / lambda)^2)`. Lower-case `gaussian` and `cauchy` are also accepted. The same option is used by `benchmark()`, `reference_use()`, `hcas_inspection()`, and `variable_importance()`. +- Added raster target support to `hcas_inspection()`. Raster inputs use x/y target coordinates, can extract reference-sample values from xy-only `samples`, and support Leaflet map clicks that snap the clicked location to the containing raster cell centre. +- Added `reference_use()` to assess how reference sites are used during benchmarking. A single run returns each site's `predicted` selection count among `k1`, `density` retention count among `k2`, and `condition` attribution. Its attribution uses the selected distance kernel and `boost` setting. Expanded temporal references are not yet supported by `reference_use()`. +- Added `variable_importance()` to attribute the observed target-to-reference departure to each RS variable. The `output` argument selects per-variable layers of `"importance"` (default; signal-to-noise ratio: the weighted mean absolute departure of the target from its references, standardised by the weighted spread among the references themselves), `"signal"` (the raw weighted departure contribution, which sums per cell to the total observed departure), or `"share"` (the per-cell departure partition, where a cell's variables sum to one — a direct percent attribution). `aggregate_importance()` summarises the per-cell scores across the landscape into a median ranking and a mean relative-share attribution. Its retained-reference weighting uses the same selected distance kernel and `boost` setting as `benchmark()`. Expanded temporal references are not yet supported. + # Version 1.1.0 -* Consolidated package colour helpers into a single `palettes()` function and removed `hcas_color()` and `ref_density_color()`. -* Changed `drop_features` so excluded RS variables are removed from the active feature set before C++ distance calculations, instead of being zeroed in place. + +- Consolidated package colour helpers into a single `palettes()` function and removed `hcas_color()` and `ref_density_color()`. +- Changed `drop_features` so excluded RS variables are removed from the active feature set before C++ distance calculations, instead of being zeroed in place. # Version 1.0.0 -* Renamed the reference density function to `ref_density()`, renamed the radial counting function (from `proximity()`) to `radial_count()`, and changed the reference density object class to `reference_density`. -* The order of input data has completely changed and both `ref_density()` and `benchmark()` functions require data with **x**, **y**, **predicted**, and **observed** remote sensing variable order. -* Complete re-write of the main C++ functions (for `ref_density()`, `benchmark()`, and `radial_count()`) using vectorised operations, including changing feature space distance calculations from `double` to `float32`, resulting in significant speed improvement (~10x) with no loss of accuracy. -* The Eigen C++ library is adapted as the main matrix engine. -* The dependency on KDtrees is dropped while keeping or even improving the speed. -* The reference density now performs only one-way pairwise distance calculations. As a result, the raw reference density values are exactly halved compared to before. This has no impact on the normalised reference density or the final output. -* The "corner value" in the reference density (previously calculated as the count of values) is no longer computed, since it is simply equal to the number of samples. -* The `calibrate()` function no longer performs interpolation. The output is now fully fitted using a monotonic spline. -* A fast spatial distance calculation is implemented (no difference for projected CRS with 0.01 meters accuracy). -* The geographic distance for lat/long is now corrected for the latitude of the source cell, not just the radius transformation to degrees. -* A new function (`tiling()`) is added for making raster tiles using raster or matrix data. -* The `NaN` pixels are now directly handled within C++ code. -* Expanded the test suite with additional C++-focused coverage, including edge cases and thread-consistency checks for core workflows. + +- Renamed the reference density function to `ref_density()`, renamed the radial counting function (from `proximity()`) to `radial_count()`, and changed the reference density object class to `reference_density`. +- The order of input data has completely changed and both `ref_density()` and `benchmark()` functions require data with **x**, **y**, **predicted**, and **observed** remote sensing variable order. +- Complete re-write of the main C++ functions (for `ref_density()`, `benchmark()`, and `radial_count()`) using vectorised operations, including changing feature space distance calculations from `double` to `float32`, resulting in significant speed improvement (\~10x) with no loss of accuracy. +- The Eigen C++ library is adapted as the main matrix engine. +- The dependency on KDtrees is dropped while keeping or even improving the speed. +- The reference density now performs only one-way pairwise distance calculations. As a result, the raw reference density values are exactly halved compared to before. This has no impact on the normalised reference density or the final output. +- The "corner value" in the reference density (previously calculated as the count of values) is no longer computed, since it is simply equal to the number of samples. +- The `calibrate()` function no longer performs interpolation. The output is now fully fitted using a monotonic spline. +- A fast spatial distance calculation is implemented (no difference for projected CRS with 0.01 meters accuracy). +- The geographic distance for lat/long is now corrected for the latitude of the source cell, not just the radius transformation to degrees. +- A new function (`tiling()`) is added for making raster tiles using raster or matrix data. +- The `NaN` pixels are now directly handled within C++ code. +- Expanded the test suite with additional C++-focused coverage, including edge cases and thread-consistency checks for core workflows. # Version 0.2.0 -* Added `drop_features` parameter to fully exclude specific remote sensing variables from both the `ref_density` and `benchmark` functions. -* Added a condition to ensure that `k_obs` is less than or equal to `k_pred`. -* A new reference density normalisation method has been implemented in R using the `legacy = FALSE` argument to mitigate edge effects. -* The zero-zero point (reference self-count) in the raw reference density is now excluded prior to normalisation. -* The `ref_density` function arguments have changed to `data` and `samples`. + +- Added `drop_features` parameter to fully exclude specific remote sensing variables from both the `ref_density` and `benchmark` functions. +- Added a condition to ensure that `k_obs` is less than or equal to `k_pred`. +- A new reference density normalisation method has been implemented in R using the `legacy = FALSE` argument to mitigate edge effects. +- The zero-zero point (reference self-count) in the raw reference density is now excluded prior to normalisation. +- The `ref_density` function arguments have changed to `data` and `samples`. # Version 0.1.6 -* Added a `scale_factor` parameter to allow user-defined correction of geographic CRS distance calculations, enhancing flexibility in handling distance conversions (previously set to a default value only). -* Enhanced C++ code for improved efficiency in point class creation. + +- Added a `scale_factor` parameter to allow user-defined correction of geographic CRS distance calculations, enhancing flexibility in handling distance conversions (previously set to a default value only). +- Enhanced C++ code for improved efficiency in point class creation. # Version 0.1.5 -* Replaced the natural spline in the `calibrate` function with a monotonically increasing spline function. + +- Replaced the natural spline in the `calibrate` function with a monotonically increasing spline function. # Version 0.1.4 -* Deprecated the linear (piece-wise) calibration method, superseded with the spline method. -* The arguments of `calibrate` are updated with `x_values` and `y_values`. -* Fixed the benchmarking `self_exclude` floating point error. + +- Deprecated the linear (piece-wise) calibration method, superseded with the spline method. +- The arguments of `calibrate` are updated with `x_values` and `y_values`. +- Fixed the benchmarking `self_exclude` floating point error. # Version 0.1.3 -* Added the `proximity` function to count the number of samples within a specified radius. -* Removed the requirement for `add_xy` in the `benchmark()` function. -* Removed `filename` and `wopt` parameters from all functions and replaced them with additional arguments `...` for more flexibility. -* Internal `terra` functions have been improved by eliminating the need for explicit creation of x and y coordinates. + +- Added the `proximity` function to count the number of samples within a specified radius. +- Removed the requirement for `add_xy` in the `benchmark()` function. +- Removed `filename` and `wopt` parameters from all functions and replaced them with additional arguments `...` for more flexibility. +- Internal `terra` functions have been improved by eliminating the need for explicit creation of x and y coordinates. # Version 0.1.2 -* Check for availability of the `terra` package is added when input is a raster -* improved documentation and imports -* a bug fix in benchmarking + +- Check for availability of the `terra` package is added when input is a raster +- improved documentation and imports +- a bug fix in benchmarking # Version 0.1.1 -* Added the geographic distance penalty for selecting the nearest predicted neighbours (`xy_penalty` and `xy_stats` parameters) -* Added an option for excluding self-assessment for benchmark sample sites (default). + +- Added the geographic distance penalty for selecting the nearest predicted neighbours (`xy_penalty` and `xy_stats` parameters) +- Added an option for excluding self-assessment for benchmark sample sites (default). # Version 0.1.0 -* Translated all legacy HCAS codes to R and Rcpp + +- Translated all legacy HCAS codes to R and Rcpp diff --git a/R/ClassicHCAS.R b/R/ClassicHCAS.R index 1fd2ce5..45490a0 100644 --- a/R/ClassicHCAS.R +++ b/R/ClassicHCAS.R @@ -1,15 +1,54 @@ -#' ClassicHCAS: The Classic Habitat Condition Assessment System (HCAS) -#' -#' The HCAS evaluates habitat condition by comparing observed and predicted -#' remote sensing (RS) variables using reference ecosystem samples. -#' It integrates multiple RS data layers to provide a comprehensive assessment of -#' habitat quality. -#' -#' @seealso \code{\link{benchmark}} and \code{\link{ref_density}}. +#' ClassicHCAS: The Classic Habitat Condition Assessment System (HCAS) #' -#' @references The Habitat Condition Assessment System (HCAS)... +#' ClassicHCAS implements the core Habitat Condition Assessment System workflow +#' for estimating habitat condition from Earth observation and environmental +#' data. HCAS compares observed remote-sensing (RS) variables with predicted +#' reference-condition RS variables. Locations whose observed signal is close to +#' the expected reference signal, relative to high-integrity reference samples, +#' receive higher condition scores. +#' +#' @details +#' The package is data-agnostic: users supply their own observed RS variables, +#' predicted reference-condition RS variables, and reference or benchmark samples. +#' The expected RS variables are usually produced outside this package by +#' modelling high-integrity reference ecosystems as a function of abiotic +#' environmental covariates such as climate, soils, water availability, and +#' landform. +#' +#' The main ClassicHCAS workflow is: +#' \enumerate{ +#' \item Use \code{\link{ref_density}} to build a reference density surface +#' from pairwise predicted and observed RS distances among reference samples. +#' \item Use \code{\link{normalise}} to trim and normalise that surface so it +#' can be used as a probability surface during benchmarking. +#' \item Use \code{\link{benchmark}} to estimate unscaled condition for target +#' locations or rasters by comparing them with nearby, environmentally similar +#' reference samples. +#' \item Use \code{\link{calibrate}} to transform unscaled condition values to +#' an interpretable 0-1 condition scale. +#' } +#' +#' Operational helpers include \code{\link{radial_count}}, for mapping local +#' reference-sample support, \code{\link{tiling}}, for splitting large raster +#' jobs into balanced processing tiles, and \code{\link{palettes}}, for package +#' plotting colours. +#' +#' @seealso \code{\link{ref_density}}, \code{\link{normalise}}, +#' \code{\link{benchmark}}, and \code{\link{calibrate}}. +#' +#' @references +#' Harwood, T. D., Donohue, R. J., Williams, K. J., Ferrier, S., +#' McVicar, T. R., Newell, G., and White, M. (2016). Habitat Condition +#' Assessment System: A new way to assess the condition of natural habitats for +#' terrestrial biodiversity across whole regions using remote sensing data. +#' \emph{Methods in Ecology and Evolution}, 7(9), 1050-1059. +#' +#' Williams, K. J., Harwood, T. D., Lehmann, E. A., Ware, C., Lyon, P., +#' Bakar, S., Schmidt, R. K., Mokany, K., Van Niel, T. G., Richards, A. E., +#' Dickson, F., McVicar, R., and Ferrier, S. (2021). Habitat Condition +#' Assessment System (HCAS version 2.1). CSIRO Publishing. #' #' @name ClassicHCAS -#' @author Roozbeh Valavi, Chris Ware, Eric Lehmann, Kristen Williams, Mike Birchall, Simon Collings, Simon Ferrier, and Tom Harwood +#' @author Roozbeh Valavi, Kristen Williams, Eric Lehmann, Simon Collings, Tom Harwood, Mike Birchall, and Simon Ferrier #' @import Rcpp NULL diff --git a/R/RcppExports.R b/R/RcppExports.R index 65e9b4a..9c4939e 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,8 +1,8 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -bench_cpp <- function(raster_vals, sample_vals, ref_density, xy_stats, xy_penalty = 0.0, geographic = FALSE, radius_km = 200, k_env = 50L, k_rs = 20L, bin_width = 0.05, bin_num = 400L, offset = 0L, confidence = 0.5, lambda = 2.0, exclude_slef = TRUE, make_su = FALSE, num_threads = -1L) { - .Call(`_ClassicHCAS_bench_cpp`, raster_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, confidence, lambda, exclude_slef, make_su, num_threads) +bench_cpp <- function(raster_vals, sample_vals, ref_density, xy_stats, xy_penalty = 0.0, geographic = FALSE, radius_km = 200, k_env = 70L, k_rs = 10L, bin_width = 0.05, bin_num = 400L, offset = 0L, confidence = 0.5, lambda = 1.0, exclude_slef = TRUE, temporal_weights = NULL, make_su = FALSE, num_threads = -1L, kernel = "gaussian", boost = NULL) { + .Call(`_ClassicHCAS_bench_cpp`, raster_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, confidence, lambda, exclude_slef, temporal_weights, make_su, num_threads, kernel, boost) } norm_cpp <- function(x, trim_size = 400L, offset = 0L) { @@ -17,7 +17,15 @@ ref_density_cpp <- function(rs_vals, pr_vals, xy_vals, radius_km = 1000.0, bin_w .Call(`_ClassicHCAS_ref_density_cpp`, rs_vals, pr_vals, xy_vals, radius_km, bin_width, bin_num, geographic, num_threads) } +reference_use_cpp <- function(target_vals, sample_vals, ref_density, xy_stats, xy_penalty = 0.0, geographic = FALSE, radius_km = 200, k_env = 70L, k_rs = 10L, bin_width = 0.05, bin_num = 400L, offset = 0L, confidence = 0.5, lambda = 1.0, exclude_slef = TRUE, num_threads = -1L, weighted_max = FALSE, kernel = "gaussian", boost = NULL) { + .Call(`_ClassicHCAS_reference_use_cpp`, target_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, confidence, lambda, exclude_slef, num_threads, weighted_max, kernel, boost) +} + tiling_cpp <- function(x, n_tiles, method = "best", exact = TRUE) { .Call(`_ClassicHCAS_tiling_cpp`, x, n_tiles, method, exact) } +variable_importance_cpp <- function(target_vals, sample_vals, ref_density, xy_stats, xy_penalty = 0.0, geographic = FALSE, radius_km = 200, k_env = 70L, k_rs = 10L, bin_width = 0.05, bin_num = 400L, offset = 0L, lambda = 1.0, epsilon = 1e-6, output = "importance", exclude_slef = TRUE, num_threads = -1L, kernel = "gaussian", boost = NULL) { + .Call(`_ClassicHCAS_variable_importance_cpp`, target_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, lambda, epsilon, output, exclude_slef, num_threads, kernel, boost) +} + diff --git a/R/benchmark.R b/R/benchmark.R index f94479d..e531804 100644 --- a/R/benchmark.R +++ b/R/benchmark.R @@ -1,135 +1,300 @@ -#' Condition benchmarking of target points -#' -#' The HCAS (Habitat Condition Assessment System) benchmarking function evaluates habitat -#' condition by comparing observed and predicted remote sensing (RS) variables. It integrates -#' multiple RS data layers to provide a comprehensive assessment of habitat quality and changes -#' over time. This function is designed to help researchers and conservationists quantify the -#' impacts of environmental changes and management interventions on habitat condition. -#' -#' Ensure that the order of remote sensing variables is consistent between predicted and observed inputs -#' (for both raster and matrix formats). The RS variable values must be centered and scaled -#' prior to prediction. Failure to do so may result in variables with larger ranges having -#' disproportionate influence in the multi-dimensional distance calculations. -#' -#' This function uses an integer-based distance checks for fast radius searches on either -#' geographic or projected coordinates. In geographic mode, coordinates are -#' stored in micro-degrees (degree * 1000_000) and the distance is approximated by: -#' -#' distance² ≈ (dlat)² + (dlon × cos(lat₁))² -#' -#' where cos(lat₁) is derived from the query latitude. This avoids floating- -#' point overhead and provides substantial performance gains but introduces -#' distortion at larger distances. For applications requiring higher accuracy, -#' especially beyond regional scales (more than several 100s of kilometers in \code{radius_km}), -#' use a projected coordinate system so distances in meters can be evaluated directly. -#' -#' Ensure that \href{https://en.wikipedia.org/wiki/OpenMP}{OpenMP} is installed on your system -#' to take advantage of parallel processing and accelerate computations. While most systems -#' include OpenMP by default, you may need to load the appropriate module if you're using an HPC -#' system. -#' -#' \strong{Note for macOS users:} Install OpenMP via Homebrew with \code{brew install libomp} -#' before installing this package. -#' -#' Note that the default parameters are tailored for Australia and may not be suitable for other -#' regions. -#' -#' @inheritParams ref_density -#' @param samples A matrix or data.frame containing x, y, predicted-RS, and observed-RS values -#' (in that specific order) for benchmark samples (also known as reference sites). If the -#' \code{data} argument is a SpatRaster, you can provide only the x and y coordinates of the -#' benchmark samples. In this case, the corresponding values will be extracted from the raster -#' layers. Consider extra time for sample value extraction in this case. -#' @param ref_density A matrix or \strong{reference_density} object of normalised HCAS -#' reference density (see \code{\link{ref_density}} and \code{\link{normalise}}). -#' @param xy_stats A vector, mean and standard deviation of coordinates for centre and -#' scaling the coordinate to use as a penalty. The order should be: mean(x), mean(y), sd(x), sd(y). -#' This argument helps achieving consistent results when running benchmarking over multiple tiles. -#' @param xy_penalty Numeric. The spatial distance penalty value for selecting benchmark points. -#' The higher the value the more penalise the distant location will be. The value 0 means no penalty. -#' @param radius_km Numeric. Search radius in kilometers for considering benchmark samples. -#' See details section for more information on distance calculation. -#' @param k_pred Integer. Number of nearest predicted RS samples to take. -#' @param k_obs Integer. Number of nearest observed RS sample to takes. -#' @param bin_width Numeric. Specifies the bin width of the reference density. If \code{ref_density} is -#' a \strong{reference_density} object, this value can be read from its attributes and may be left \code{NULL}. -#' The bin width must be consistent between the reference density creation and the benchmarking step to -#' ensure condition is accurately calculated. -#' @param interpolate Logical. Whether to interpolate the reference density for a smoother result. -#' @param offset Integer. Specifies the number of reference density bins that were ignored during -#' normalisation (see \code{\link{normalise}}). If \code{ref_density} is a \strong{reference_density} object, -#' this value can be read from its attributes and may be set \code{NULL}. Similar to bin-width, -#' the \code{offset} must be consistent between the reference density normalisation and the benchmarking -#' step to ensure condition is accurately calculated. -#' @param confidence Numeric. The confidence value for LDC methods. See details below.. -#' @param lambda Numeric. The lambda param for LDC Cauchy weighting... -#' @param exclude_slef Logical. To exclude a benchmark point from assessing itself. -#' @param drop_features Integer vector. Completely remove RS variables from the benchmarking process. -#' Positions are 1-based within the RS feature set, not the full input column order. For -#' consistency, it is recommended to exclude the same variables used in the reference density step; unless -#' you have a specific reason not to. -#' @param make_su Logical. To make the uncertainty map or not. -#' @param ... Additional arguments for writing raster outputs e.g. \code{filename}, -#' \code{overwrite}, and \code{wopt} from terra \code{\link[terra]{predict}}. -#' -#' @seealso \code{\link{ref_density}}, \code{\link{normalise}}, and \code{\link{calibrate}} -#' -#' @return A matrix or SpatRaster, depending on the inputs. -#' @export -#' -#' @examples -#' \donttest{ -#' library(ClassicHCAS) -#' -#' -#' -#' } -benchmark <- function( - data, - samples, - ref_density, - xy_stats = c(0, 0, 1, 1), - xy_penalty = 0.0, - radius_km = 200, - k_pred = 50, - k_obs = 20, - bin_width = NULL, - interpolate = TRUE, - offset = 0, - confidence = 0.5, - lambda = 2.0, - exclude_slef = TRUE, - drop_features = NULL, - make_su = FALSE, - num_threads = -1, - ...) { - - # check k_pred and k_obs - if (k_pred < k_obs) stop("'k_obs' must be smaller or equal to 'k_pred'.") - # check samples and reference density - samples <- if (.is_mat(samples)) .check_mat(samples) else stop("'samples' must be a matrix or convertible to one.") - ref_density <- if (.is_mat(ref_density)) .check_mat(ref_density) else stop("'ref_density' must be a matrix or convertible to one.") - if (nrow(ref_density) != ncol(ref_density)) warning("Reference density dimensions are not equal!\n") - - if (methods::is(ref_density, "reference_density")) { - # check for reference density bin_width consistency - if (is.null(bin_width)) { - bin_width <- attributes(ref_density)$bin.width - } else { - if (bin_width != attributes(ref_density)$bin.width) { - warning("Provided 'bin_width' differs from reference density attribute.") - } - } - # check for reference density offset consistency - if (is.null(offset)) { - offset <- attributes(ref_density)$offset - } else { - if (offset != attributes(ref_density)$offset) { - warning("Provided 'offset' differs from reference density attribute.") - } - } - } - +#' Benchmark target locations against HCAS reference condition +#' +#' Estimates raw HCAS habitat condition by comparing target locations with +#' nearby, environmentally similar reference samples and a normalised reference +#' density surface. +#' +#' @details +#' In HCAS, predicted RS variables represent the expected signal under reference +#' condition and observed RS variables represent the actual Earth observation +#' signal. \code{benchmark()} asks whether the observed departure from expected +#' reference condition is typical of high-integrity reference ecosystems. The +#' output is an unscaled relative condition value; use \code{\link{calibrate}} to +#' map it to a 0-1 condition scale. +#' +#' \strong{Experimental temporal mode:} the mechanism controlled by +#' \code{temporal_sigma} is exploratory, is off by default, and should not be +#' treated as equivalent to the standard non-temporal benchmark without +#' independent validation. Standard benchmarking remains non-temporal unless a +#' finite \code{temporal_sigma} is supplied. +#' +#' The function uses a two-stage reference-sample selection process for each +#' target location: +#' \enumerate{ +#' \item Candidate benchmark samples are restricted to those within +#' \code{radius_km}. +#' \item From those candidates, up to \code{k1} samples with the smallest +#' predicted RS distance are retained. If \code{xy_penalty > 0}, scaled +#' geographic coordinates are included in this distance so distant samples are +#' penalised even when they are spectrally similar. +#' \item The target and retained samples are queried against +#' \code{ref_density} using predicted-distance and observed-distance bins. +#' If the experimental temporal mode is enabled, each retained site is queried +#' once per reference year, and a Gaussian year weight selects and weights the +#' site's most relevant year. +#' \item Up to \code{k2} samples with the highest reference-density +#' probability are retained for condition estimation. +#' } +#' +#' The retained probability values are combined using the distance kernel +#' selected by \code{kernel}. The default Gaussian kernel is +#' \code{exp(-(distance / lambda)^2)}. The optional Cauchy kernel is +#' \code{1 / (1 + (distance / lambda)^2)}, the standard Cauchy shape +#' normalised to weight one at zero. +#' +#' By default, \code{boost = k2} replaces the LDC blend with a boosted weighted +#' mean. The kernel weight of the retained site with the highest unweighted +#' probability is multiplied by \code{boost}, and condition is the weighted mean +#' using that adjusted weight. In this mode, \code{confidence} does not affect +#' condition. Set \code{boost = NULL} or \code{boost = NA} to use the original +#' LDC blend, where \code{confidence} controls how strongly the raw condition +#' value relies on the maximum unweighted probability contribution compared +#' with the distance-weighted mean probability. A value of \code{boost = 1} +#' gives the ordinary kernel-weighted mean. If +#' \code{make_su = TRUE}, the result also includes \code{su}, the log of the +#' original, unboosted total distance-weight sum, which is a support diagnostic +#' rather than a calibrated confidence interval. +#' +#' Matrix and data.frame inputs must be ordered as \code{x}, \code{y}, predicted +#' RS variables, then observed RS variables. Raster inputs must contain predicted +#' RS layers followed by observed RS layers in the same variable order. The +#' sample matrix can either contain only \code{x} and \code{y} coordinates, in +#' which case values are extracted from a raster \code{data} object, or the full +#' \code{x}, \code{y}, predicted RS, observed RS table. Predicted and observed +#' variables should be centred and scaled consistently before benchmarking. +#' +#' The most influential tuning parameters are usually \code{radius_km}, +#' \code{xy_penalty}, \code{k1}, \code{k2}, \code{lambda}, and +#' \code{boost}. Defaults were chosen for Australian HCAS applications and +#' should be assessed before use in other regions, data products, or ecological +#' contexts. When field condition data are unavailable, tuning can be guided by +#' whether scores discriminate among independent land-use or disturbance classes +#' in the expected order. +#' +#' In geographic coordinates, radius searches use a fast integer approximation. +#' Coordinates are stored in micro-degrees (\code{degree * 1000000}) and distance +#' is approximated by: +#' +#' \deqn{distance^2 \approx (\Delta \mathrm{lat})^2 + (\Delta \mathrm{lon} \times \cos(\mathrm{lat}_1))^2}{distance^2 ~= (Delta lat)^2 + ((Delta lon) * cos(lat_1))^2} +#' +#' where \eqn{\Delta \mathrm{lat}}{Delta lat} and \eqn{\Delta \mathrm{lon}}{Delta lon} +#' are coordinate differences, and \eqn{\cos(\mathrm{lat}_1)}{cos(lat_1)} is +#' derived from the query latitude. This is efficient for large analyses but +#' introduces distortion over large areas. For high accuracy at broad regional +#' or continental radii, use a projected coordinate reference system so +#' distances can be evaluated in metres. +#' +#' \code{num_threads} uses OpenMP when available. On macOS, installing OpenMP +#' support with \code{brew install libomp} before installing the package may be +#' required for multi-threaded execution. +#' +#' @inheritParams ref_density +#' @param samples Benchmark/reference sample data. Normally this is a matrix or +#' data.frame containing \code{x}, \code{y}, predicted RS variables, then +#' observed RS variables in the same order as \code{data}. For raster +#' \code{data}, it can instead contain only two coordinate columns, in which +#' case raster values are extracted. When \code{temporal_sigma} is specified, +#' supply a named list of full sample matrices, one per year, with numeric year names. +#' All matrices must contain the same sites, row order, XY coordinates, +#' predicted values, and feature order; only observed values may vary. +#' @param ref_density A normalised \code{reference_density} object or matrix +#' produced by \code{\link{normalise}}. +#' @param xy_stats Numeric vector of length four used to scale coordinates when +#' \code{xy_penalty > 0}: \code{mean(x)}, \code{mean(y)}, \code{sd(x)}, +#' \code{sd(y)}. Use the same values across tiles to keep tiled benchmarking +#' consistent. +#' @param xy_penalty Numeric. Weight applied to scaled coordinates when selecting +#' the \code{k1} most similar benchmark samples. \code{0} disables the +#' spatial penalty. +#' @param radius_km Numeric. Search radius, in kilometres, for candidate +#' benchmark samples. +#' @param k1 Integer. First-stage filter size: the number of nearest samples to +#' retain after the predicted RS distance search. +#' @param k2 Integer. Second-stage filter size: the number of high-probability +#' samples to retain from the reference density query. Must be less than or +#' equal to \code{k1}. +#' @param bin_width Numeric. Bin width used to create and normalise +#' \code{ref_density}. If \code{ref_density} is a \code{reference_density} +#' object, this value is read from its \code{bin.width} attribute when +#' \code{bin_width = NULL}. +#' @param interpolate Logical. If \code{TRUE}, bilinearly interpolates the +#' reference density surface before benchmarking for smoother lookup. +#' @param offset Integer. Number of reference-density bins ignored during +#' normalisation. If \code{ref_density} is a \code{reference_density} object, +#' this value is read from its \code{offset} attribute when \code{offset = NULL}. +#' @param confidence Numeric between 0 and 1. Weight given to the selected +#' maximum probability component relative to the distance-weighted mean +#' probability when computing raw condition. Ignored when \code{boost} is not +#' \code{NULL} or \code{NA}; the default is \code{boost = k2}. +#' @param boost \code{NULL}, \code{NA}, or one positive finite numeric factor. +#' The default \code{k2} multiplies the kernel weight of the +#' highest-probability retained site by \code{k2} and returns the resulting weighted +#' mean instead of the LDC blend. \code{confidence} is ignored in this mode. +#' Use \code{NULL} or \code{NA} for the unboosted LDC blend. +#' @param lambda Positive numeric. Distance-scale bandwidth for the selected +#' \code{kernel}. Both kernels treat \code{lambda} in predicted RS L1 distance +#' units: the Gaussian kernel uses \code{exp(-(distance / lambda)^2)} and the +#' Cauchy kernel uses \code{1 / (1 + (distance / lambda)^2)}. +#' @param exclude_slef Logical. If \code{TRUE}, exclude samples whose predicted +#' RS distance is less than one bin width, preventing a benchmark point from +#' assessing itself. The argument name preserves the existing API spelling. +#' @param drop_features Optional integer vector of RS variable positions to +#' exclude from benchmarking. Positions are 1-based within the RS feature set, +#' not within the full input column order. Use the same exclusion used in +#' \code{\link{ref_density}} unless there is a deliberate reason not to. +#' @param assessment_year Numeric. Year being assessed and the centre of the +#' experimental Gaussian temporal kernel. Required when +#' \code{temporal_sigma} is specified. +#' @param temporal_sigma Positive numeric or \code{NULL}. Standard deviation of +#' the experimental Gaussian temporal kernel, in the same units as the +#' temporal sample names. Supplying a value enables an exploratory temporal +#' mode that has not been validated as a drop-in replacement for standard +#' non-temporal benchmarking; \code{NULL} or \code{NA} disables it. When +#' enabled, the selected reference-density probability is multiplied by the +#' selected year's temporal weight before \code{k2} selection and condition +#' estimation. +#' @param make_su Logical. If \code{TRUE}, return both raw condition and +#' \code{su}, the log of the total distance-weight sum. +#' @param kernel Character. Distance kernel applied to retained-reference +#' predicted RS L1 distances: \code{"Gaussian"} (default) or \code{"Cauchy"}. +#' Lower-case \code{"gaussian"} and \code{"cauchy"} are also accepted. +#' @param ... Additional arguments passed to \code{\link[terra]{interpolate}} +#' when benchmarking raster outputs, such as \code{filename}, \code{overwrite}, +#' or \code{wopt}. +#' +#' @seealso \code{\link{ref_density}}, \code{\link{normalise}}, and \code{\link{calibrate}} +#' +#' @return A matrix or \pkg{terra} \code{SpatRaster}, depending on the inputs. +#' @export +#' +#' @examples +#' \donttest{ +#' library(ClassicHCAS) +#' +#' target_data <- cbind( +#' x = c(0.1, 0.9), +#' y = c(0.1, 0.9), +#' rs1 = c(0.12, 0.42), +#' rs1 = c(0.13, 0.50) +#' ) +#' +#' sample_data <- cbind( +#' x = c(0.0, 0.4, 0.8, 1.2), +#' y = c(0.0, 0.3, 0.8, 1.1), +#' rs1 = c(0.10, 0.20, 0.40, 0.55), +#' rs1 = c(0.11, 0.18, 0.43, 0.58) +#' ) +#' +#' ref <- matrix(1, nrow = 20, ncol = 20) +#' class(ref) <- c("reference_density", "matrix", "array") +#' attr(ref, "bin.width") <- 0.1 +#' attr(ref, "offset") <- 0 +#' +#' benchmark( +#' target_data, +#' samples = sample_data, +#' ref_density = ref, +#' radius_km = 200, +#' k1 = 3, +#' k2 = 2, +#' interpolate = FALSE, +#' exclude_slef = FALSE, +#' num_threads = 1 +#' ) +#' } +benchmark <- function( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0.0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + kernel = c("Gaussian", "Cauchy"), + lambda = 1.0, + confidence = 0.5, + exclude_slef = TRUE, + drop_features = NULL, + assessment_year = NULL, + temporal_sigma = NULL, + make_su = FALSE, + num_threads = -1, + boost = k2, + ...) { + + kernel <- .check_kernel(kernel) + dots <- list(...) + legacy_k <- intersect(names(dots), c("k_pred", "k_obs")) + if (length(legacy_k)) { + stop("'k_pred' and 'k_obs' were renamed to 'k1' and 'k2'.") + } + if ("temporal_correct" %in% names(dots)) { + stop( + "'temporal_correct' has been removed; supply 'temporal_sigma' ", + "to enable the experimental temporal mode." + ) + } + if ("temporal_weighted" %in% names(dots)) { + stop( + "'temporal_weighted' has been removed; temporal weights are ", + "always applied when 'temporal_sigma' enables the experimental ", + "temporal mode." + ) + } + if ("weighted_max" %in% names(dots)) { + stop("'weighted_max' is not an argument to benchmark().") + } + + # The second-stage filter cannot retain more samples than the first stage. + if (k1 < k2) stop("'k2' must be less than or equal to 'k1'.") + boost <- .check_boost(boost) + + temporal_sigma_missing <- is.null(temporal_sigma) || + (length(temporal_sigma) == 1L && isTRUE(is.na(temporal_sigma))) + use_temporal_correction <- !temporal_sigma_missing + + temporal <- NULL + temporal_weights <- NULL + if (use_temporal_correction) { + temporal <- .prepare_temporal_samples( + samples = samples, + assessment_year = assessment_year, + temporal_sigma = temporal_sigma, + drop_features = drop_features + ) + samples <- temporal$samples + temporal_weights <- temporal$weights + } else { + samples <- if (.is_mat(samples)) .check_mat(samples) else stop("'samples' must be a matrix or convertible to one.") + } + + # check reference density + ref_density <- if (.is_mat(ref_density)) .check_mat(ref_density) else stop("'ref_density' must be a matrix or convertible to one.") + if (nrow(ref_density) != ncol(ref_density)) warning("Reference density dimensions are not equal!\n") + + if (methods::is(ref_density, "reference_density")) { + # check for reference density bin_width consistency + if (is.null(bin_width)) { + bin_width <- attributes(ref_density)$bin.width + } else { + if (bin_width != attributes(ref_density)$bin.width) { + warning("Provided 'bin_width' differs from reference density attribute.") + } + } + # check for reference density offset consistency + if (is.null(offset)) { + offset <- attributes(ref_density)$offset + } else { + if (offset != attributes(ref_density)$offset) { + warning("Provided 'offset' differs from reference density attribute.") + } + } + } + # interpolate reference density if (interpolate) { ref_density <- terra::as.matrix( @@ -143,134 +308,157 @@ benchmark <- function( # update the binwidth and offset bin_width <- bin_width / 2 offset <- offset * 2 - } - # get the bin number after interpolation - bin_num <- min(dim(ref_density)) - - if (.is_mat(data)) { - # check and convert to matrix - data <- .check_mat(data) - - if (ncol(samples) != ncol(data)) { - stop("Samples must include all raster values (matching column count with 'data').") - } - - keep_features <- .keep_rs_features(drop_features, .num_rs_vars_mat(samples, "samples")) - samples <- .subset_rs_mat(samples, keep_features) - data <- .subset_rs_mat(data, keep_features) - - tryCatch( - { - output <- .benchmarking( - model = list(), - newdata = data, # rast_stack arg - sample_vals = samples, - ref_density = ref_density, - xy_stats = xy_stats, - xy_penalty = xy_penalty, - radius_km = radius_km, - geographic = .is_lonlat(data), - bin_width = bin_width, - bin_num = bin_num, - offset = offset, - k_env = k_pred, - k_rs = k_obs, - confidence = confidence, - lambda = lambda, - exclude_slef = exclude_slef, - make_su = make_su, - num_threads = num_threads - ) - }, - error = function(cond) { - stop("HCAS benchmarking C++ function failed!\n", cond) - } - ) - } else if (.is_rast(data)) { - # check terra is available - .check_pkgs("terra") - # check and convert to SpatRaster object - data <- .check_rast(data) - - # sample extraction if needed - if (ncol(samples) == 2) { - cat("Extracting sample values...\n") - samples <- cbind(samples, as.matrix(terra::extract(data, samples, ID = FALSE))) - } else if ((ncol(samples) - 2) != terra::nlyr(data)) { - stop("Sample feature count does not match number of raster layers.") - } - - keep_features <- .keep_rs_features(drop_features, terra::nlyr(data) / 2L) - samples <- .subset_rs_mat(samples, keep_features) - data <- .subset_rs_rast(data, keep_features) - - tryCatch( - { - output <- terra::interpolate( - object = data, - model = list(), - fun = .benchmarking, - sample_vals = samples, - ref_density = ref_density, - xy_stats = xy_stats, - xy_penalty = xy_penalty, - radius_km = radius_km, - geographic = .is_lonlat(data), - bin_width = bin_width, - bin_num = bin_num, - offset = offset, - k_env = k_pred, - k_rs = k_obs, - confidence = confidence, - lambda = lambda, - exclude_slef = exclude_slef, - make_su = make_su, - num_threads = num_threads, - ... - ) - }, - error = function(cond) { - stop("HCAS benchmarking C++ function failed!\n", cond) - } - ) - - } else { - stop("The 'data' must be raster or a matrix, or convertiable object to these classes.") - } - - return( - output - ) -} - - -# a function to handling predicting with terra -.benchmarking <- function(model, newdata, make_su, ...){ - nr <- nrow(newdata) - nc <- make_su + 1 - col_names <- c("condition", "su")[1:nc] - - dat <- as.matrix(newdata) - - tryCatch( - { - hcas_cond <- bench_cpp( - raster_vals = dat, - make_su = make_su, - ... - ) - }, - error = function(cond) { - message("Benchmarking C++ function failed. Returning -0.02 for all cells.") - # return error values -0.02 - return( - matrix(-0.02, nrow = nr, ncol = nc, dimnames = list(NULL, col_names)) - ) - } - ) - - colnames(hcas_cond) <- col_names - - return(hcas_cond) -} - + } + # get the bin number after interpolation + bin_num <- min(dim(ref_density)) + + if (.is_mat(data)) { + # check and convert to matrix + data <- .check_mat(data) + + if (use_temporal_correction) { + if (.num_rs_vars_mat(data, "data") != temporal$n_vars) { + stop("Temporal samples and 'data' must contain the same RS feature count.") + } + data <- .subset_rs_mat(data, temporal$keep_features) + } else { + if (ncol(samples) != ncol(data)) { + stop("Samples must include all raster values (matching column count with 'data').") + } + + keep_features <- .keep_rs_features(drop_features, .num_rs_vars_mat(samples, "samples")) + samples <- .subset_rs_mat(samples, keep_features) + data <- .subset_rs_mat(data, keep_features) + } + + tryCatch( + { + output <- .benchmarking( + model = list(), + newdata = data, # rast_stack arg + sample_vals = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + radius_km = radius_km, + geographic = .is_lonlat(data), + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + k_env = k1, + k_rs = k2, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + temporal_weights = temporal_weights, + make_su = make_su, + num_threads = num_threads, + kernel = kernel + ) + }, + error = function(cond) { + stop("HCAS benchmarking C++ function failed!\n", cond) + } + ) + } else if (.is_rast(data)) { + # check terra is available + .check_pkgs("terra") + # check and convert to SpatRaster object + data <- .check_rast(data) + + if (terra::nlyr(data) %% 2L) { + stop("'data' must contain matching predicted and observed RS layers.") + } + + if (use_temporal_correction) { + if (terra::nlyr(data) / 2L != temporal$n_vars) { + stop("Temporal samples and 'data' must contain the same RS feature count.") + } + data <- .subset_rs_rast(data, temporal$keep_features) + } else { + # sample extraction if needed + if (ncol(samples) == 2) { + cat("Extracting sample values...\n") + samples <- cbind(samples, as.matrix(terra::extract(data, samples, ID = FALSE))) + } else if ((ncol(samples) - 2) != terra::nlyr(data)) { + stop("Sample feature count does not match number of raster layers.") + } + + keep_features <- .keep_rs_features(drop_features, terra::nlyr(data) / 2L) + samples <- .subset_rs_mat(samples, keep_features) + data <- .subset_rs_rast(data, keep_features) + } + + tryCatch( + { + output <- terra::interpolate( + object = data, + model = list(), + fun = .benchmarking, + sample_vals = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + radius_km = radius_km, + geographic = .is_lonlat(data), + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + k_env = k1, + k_rs = k2, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + temporal_weights = temporal_weights, + make_su = make_su, + num_threads = num_threads, + kernel = kernel, + ... + ) + }, + error = function(cond) { + stop("HCAS benchmarking C++ function failed!\n", cond) + } + ) + + } else { + stop("The 'data' must be raster or a matrix, or convertiable object to these classes.") + } + + return( + output + ) +} + + +# a function to handling predicting with terra +.benchmarking <- function(model, newdata, make_su, ...){ + nr <- nrow(newdata) + nc <- make_su + 1 + col_names <- c("condition", "su")[1:nc] + + dat <- as.matrix(newdata) + + tryCatch( + { + hcas_cond <- bench_cpp( + raster_vals = dat, + make_su = make_su, + ... + ) + }, + error = function(cond) { + message("Benchmarking C++ function failed. Returning -0.02 for all cells.") + # return error values -0.02 + return( + matrix(-0.02, nrow = nr, ncol = nc, dimnames = list(NULL, col_names)) + ) + } + ) + + colnames(hcas_cond) <- col_names + + return(hcas_cond) +} diff --git a/R/calibrate.R b/R/calibrate.R index 6bf4df9..b19f22b 100644 --- a/R/calibrate.R +++ b/R/calibrate.R @@ -1,29 +1,61 @@ -#' Calibrate habitat condition output -#' -#' This function calibrates the HCAS habitat condition values and scales them between 0 and 1 -#' using a monotonically increasing Spline function. -#' -#' @param x A SpatRaster, matrix, data.frame, or vector containing HCAS habitat condition values from -#' the benchmarking function (see \code{\link{benchmark}}). If \code{x} is a matrix or data.frame, -#' the calibration will be applied to all columns. -#' @param x_values Numeric vector of un-calibrated condition values. It is recommended that \code{x_values} -#' cover the full range of values, including the minimum and maximum of the raw condition data. -#' @param y_values Numeric vector of calibrated target condition value corresponding to \code{x_values}. -#' @param ... Additional arguments for writing raster outputs e.g. \code{filename}, -#' \code{overwrite}, and \code{wopt} from terra \code{\link[terra]{predict}}. -#' -#' @seealso \code{\link{benchmark}} -#' -#' @return A matrix, SpatRaster or vector, depending on the inputs. -#' @export -#' -#' @examples -#' \donttest{ -#' library(ClassicHCAS) -#' -#' -#' -#' } +#' Calibrate HCAS condition values +#' +#' Transforms raw, unscaled HCAS benchmarking values to a standard 0-1 habitat +#' condition scale using a monotonic spline. +#' +#' @details +#' \code{\link{benchmark}} returns an unscaled relative condition value. The +#' range and distribution of that value can differ among regions, data sources, +#' remote-sensing summaries, and model settings. \code{calibrate()} maps those +#' raw values to an interpretable 0-1 scale, where 0 represents a completely +#' degraded or removed state and 1 represents reference or near-natural +#' condition. +#' +#' Calibration uses paired \code{x_values} and \code{y_values}. The +#' \code{x_values} are raw condition values from the benchmark output, often +#' including the minimum, the median of highly modified sites, the median of +#' reference sites, and the maximum. The \code{y_values} are the desired +#' calibrated condition values for those knots, supplied from empirical evidence, +#' expert judgement, or another accepted condition scale. A monotonic spline is +#' fitted through the pairs, preserving the rank order of raw condition while +#' enforcing a smooth increasing transformation. Values outside the 0-1 range +#' after transformation are clipped to 0 or 1. +#' +#' \code{x_values} and \code{y_values} must have the same length. For a stable +#' calibration curve, \code{x_values} should be sorted from low to high and +#' should span the raw condition values in \code{x}. The default +#' \code{y_values} assumes four calibration knots and should be replaced when a +#' different number of \code{x_values} is supplied. +#' +#' @param x A \pkg{terra} \code{SpatRaster}, matrix, data.frame, or vector +#' containing raw HCAS condition values returned by \code{\link{benchmark}}. For +#' matrix and data.frame inputs, calibration is applied column-wise. +#' @param x_values Numeric vector of raw, uncalibrated condition values used as +#' calibration knots. +#' @param y_values Numeric vector of calibrated target values corresponding to +#' \code{x_values}. Values should usually be between 0 and 1. +#' @param ... Additional arguments passed to \code{\link[terra]{app}} when +#' calibrating raster outputs, such as \code{filename}, \code{overwrite}, or +#' \code{wopt}. +#' +#' @seealso \code{\link{benchmark}} +#' +#' @return A vector, matrix, or \pkg{terra} \code{SpatRaster}, depending on the +#' input. +#' @export +#' +#' @examples +#' library(ClassicHCAS) +#' +#' raw_condition <- c(0.000, 0.005, 0.020, 0.035, 0.050) +#' +#' calibrated <- calibrate( +#' raw_condition, +#' x_values = c(0.000, 0.005, 0.035, 0.050), +#' y_values = c(0.0, 0.1, 0.9, 1.0) +#' ) +#' +#' calibrated calibrate <- function( x, x_values, diff --git a/R/checks.R b/R/checks.R index 6c272dc..39c7fb5 100644 --- a/R/checks.R +++ b/R/checks.R @@ -73,7 +73,7 @@ return(r) } -# check for required packages +# check for required packages .check_pkgs <- function(pkg){ pkgna <- names(which(sapply(sapply(pkg, find.package, quiet = TRUE), length) == 0)) if(length(pkgna) > 0){ @@ -89,6 +89,28 @@ } +# validate and canonicalise distance-kernel names +.check_kernel <- function(kernel) { + if (length(kernel) > 1L) { + kernel <- kernel[[1L]] + } + + if (!is.character(kernel) || + length(kernel) != 1L || + is.na(kernel) || + !nzchar(kernel)) { + stop("'kernel' must be 'Gaussian'/'gaussian' or 'Cauchy'/'cauchy'.") + } + + kernel <- tolower(kernel) + if (!(kernel %in% c("gaussian", "cauchy"))) { + stop("'kernel' must be 'Gaussian'/'gaussian' or 'Cauchy'/'cauchy'.") + } + + kernel +} + + # get the number of RS variables from x, y, predicted..., observed... matrix input .num_rs_vars_mat <- function(x, name = "x") { n_vars <- (ncol(x) - 2L) / 2L @@ -154,3 +176,123 @@ keep_layers <- c(keep_features, keep_features + n_vars) x[[keep_layers]] } + + +# validate and pack a named list of yearly reference sample matrices +.prepare_temporal_samples <- function( + samples, + assessment_year, + temporal_sigma, + drop_features = NULL) { + + if (!is.list(samples) || !length(samples)) { + stop( + "When 'temporal_sigma' is specified, 'samples' must be a non-empty ", + "named list of yearly sample matrices." + ) + } + + sample_year_names <- names(samples) + if (is.null(sample_year_names) || any(!nzchar(sample_year_names))) { + stop("Temporal 'samples' must be named with their numeric years.") + } + + sample_years <- suppressWarnings(as.numeric(sample_year_names)) + if (any(!is.finite(sample_years)) || anyDuplicated(sample_years)) { + stop("Temporal sample names must be unique numeric years.") + } + if (length(assessment_year) != 1L || !is.finite(assessment_year)) { + stop("'assessment_year' must be one finite numeric value.") + } + if (length(temporal_sigma) != 1L || + !is.finite(temporal_sigma) || + temporal_sigma <= 0) { + stop("'temporal_sigma' must be one finite number greater than zero.") + } + + year_order <- order(sample_years) + sample_years <- sample_years[year_order] + samples <- samples[year_order] + samples <- lapply( + seq_along(samples), + function(i) { + if (!.is_mat(samples[[i]])) { + stop( + sprintf( + "Temporal sample '%s' must be a matrix or convertible to one.", + sample_year_names[year_order][i] + ) + ) + } + .check_mat(samples[[i]]) + } + ) + + n_vars <- .num_rs_vars_mat(samples[[1L]], "samples[[1]]") + keep_features <- .keep_rs_features(drop_features, n_vars) + base_xy <- samples[[1L]][, 1:2, drop = FALSE] + base_pred <- samples[[1L]][, 2L + seq_len(n_vars), drop = FALSE] + + for (i in seq_along(samples)) { + current <- samples[[i]] + year_label <- sample_year_names[year_order][i] + + if (.num_rs_vars_mat(current, sprintf("samples[['%s']]", year_label)) != n_vars || + nrow(current) != nrow(samples[[1L]])) { + stop("All temporal sample matrices must have identical dimensions.") + } + if (!isTRUE(all.equal( + current[, 1:2, drop = FALSE], + base_xy, + check.attributes = FALSE + ))) { + stop("All temporal sample matrices must contain the same XY sites in the same row order.") + } + if (!isTRUE(all.equal( + current[, 2L + seq_len(n_vars), drop = FALSE], + base_pred, + check.attributes = FALSE + ))) { + stop("Predicted RS values must be constant across temporal sample years.") + } + if (anyNA(current)) { + stop(sprintf("Temporal sample year '%s' contains missing values.", year_label)) + } + } + + pred_cols <- 2L + keep_features + obs_cols <- 2L + n_vars + keep_features + packed <- cbind( + base_xy, + samples[[1L]][, pred_cols, drop = FALSE], + do.call( + cbind, + lapply(samples, function(x) x[, obs_cols, drop = FALSE]) + ) + ) + temporal_weights <- exp( + -0.5 * ((sample_years - assessment_year) / temporal_sigma)^2 + ) + + list( + samples = packed, + weights = temporal_weights, + years = sample_years, + n_vars = n_vars, + keep_features = keep_features + ) +} + +.check_boost <- function(boost) { + if (is.null(boost) || + (length(boost) == 1L && isTRUE(is.na(boost)))) { + return(NULL) + } + if (!is.numeric(boost) || + length(boost) != 1L || + !is.finite(boost) || + boost <= 0) { + stop("'boost' must be NULL, NA, or one finite number greater than zero.") + } + as.numeric(boost) +} diff --git a/R/colours.R b/R/colours.R index c73e3fe..b136095 100644 --- a/R/colours.R +++ b/R/colours.R @@ -1,10 +1,23 @@ -#' ClassicHCAS palettes +#' ClassicHCAS colour palettes #' -#' @param n Integer. Number of color codes to return. -#' @param name Character. Palette name. One of `"hcas"` or `"ref_density"`. +#' Returns colour palettes used by ClassicHCAS plots. #' -#' @return A character vector of color codes. +#' @details +#' The \code{"hcas"} palette is intended for habitat condition maps, with low +#' condition shown in purple, intermediate values in yellow, and high condition +#' in green. The \code{"ref_density"} palette is intended for raw or normalised +#' reference density surfaces. +#' +#' @param n Integer. Number of colour codes to return. +#' @param name Character. Palette name. One of \code{"hcas"} or +#' \code{"ref_density"}. +#' +#' @return A character vector of hexadecimal colour codes. #' @export +#' +#' @examples +#' palettes(5) +#' palettes(5, "ref_density") palettes <- function(n = 10, name = c("hcas", "ref_density")) { name <- match.arg(name) @@ -21,4 +34,3 @@ palettes <- function(n = 10, name = c("hcas", "ref_density")) { palette_fn(n) } - diff --git a/R/hcas_inspection.R b/R/hcas_inspection.R new file mode 100644 index 0000000..c34ac1f --- /dev/null +++ b/R/hcas_inspection.R @@ -0,0 +1,1298 @@ +#' Launch an interactive HCAS point-inspection tool +#' +#' Builds a Shiny application for inspecting how individual target locations +#' are benchmarked against reference samples. The application shows the raw +#' condition estimate, the reference samples inside the geographic search +#' radius, the samples retained by the two-stage HCAS selection, and their +#' predicted and observed distances on the reference-density surface. +#' +#' @details +#' The inspection tool uses the current \code{\link{benchmark}} and +#' \code{\link{reference_use}} implementations. Consequently, its controls map +#' directly to the current benchmarking arguments: \code{k1} is the first-stage +#' predicted-distance filter, \code{k2} is the reference-density filter, and +#' \code{xy_penalty} applies the optional scaled-coordinate penalty. Feature +#' counts, geographic distance handling, density dimensions, and density +#' metadata are inferred by ClassicHCAS rather than supplied as legacy fixed +#' values. +#' +#' The user interface intentionally retains the standalone inspection tool's +#' default Shiny theme, \pkg{shinyWidgets} controls, layout, labels, map styling, +#' and reference-density plot styling. +#' +#' Matrix and data.frame inputs must be ordered as \code{x}, \code{y}, predicted +#' RS variables, then observed RS variables. Raster inputs must contain +#' predicted RS layers followed by observed RS layers in the same variable +#' order. For raster inputs, the target selector uses \code{x} and \code{y} +#' coordinates in the raster coordinate reference system. Map clicks are +#' projected back to that coordinate system and snapped to the containing raster +#' cell centre before values are extracted. Temporal reference-sample lists are +#' not supported because \code{\link{reference_use}} currently supports only a +#' single reference year. +#' +#' The map requires longitude/latitude coordinates. If the input coordinates +#' are projected, supply their coordinate reference system through \code{crs}; +#' the display coordinates are then transformed to EPSG:4326. The CRS affects +#' map display only. Benchmarking uses the coordinate handling implemented by +#' \code{\link{benchmark}}. +#' +#' @inheritParams benchmark +#' @param data A matrix, data.frame, or \pkg{terra} \code{SpatRaster} of target +#' locations. Matrix and data.frame inputs use a row-ID selector. Raster inputs +#' use coordinate inputs and extract the selected cell values. +#' @param samples A matrix or data.frame of reference locations in the same +#' column order as \code{data}. For raster \code{data}, this may contain only +#' \code{x} and \code{y} coordinates, in which case raster values are extracted. +#' Temporal sample lists are not supported. +#' @param crs Optional coordinate reference system understood by +#' \code{\link[terra]{vect}}, such as \code{"EPSG:3577"}. Required for the map +#' when matrix/data.frame coordinates are projected or when raster coordinates +#' are projected and the raster has no CRS. +#' @param background Optional background raster drawn beneath the sample +#' markers, given as a file path to a GeoTIFF or a \pkg{terra} +#' \code{SpatRaster}. The map renderer reads web mercator directly, so a +#' single-band Cloud-Optimized GeoTIFF (COG) already in \code{"EPSG:3857"} or +#' \code{"EPSG:4326"} is served unchanged and its internal overviews stream for +#' fast, overview-accelerated rendering. Any other input is reduced to its +#' first layer, reprojected to \code{"EPSG:3857"} when needed, and written to a +#' temporary COG with overviews. Requires the suggested package \pkg{leafem}. +#' @param background_colors Optional character vector of colours (for example +#' hexadecimal codes such as \code{c("#430E59", "#CCCC66", "#184F0F")}) used as +#' the continuous colour ramp for \code{background}. Defaults to the +#' \code{"hcas"} palette from \code{\link{palettes}}. Ignored when +#' \code{background} is \code{NULL}. +#' @param launch Logical. If \code{TRUE}, run the application with +#' \code{\link[shiny]{runApp}}. If \code{FALSE}, return the application object +#' without running it, which is useful for testing or custom deployment. +#' @param confidence Numeric between 0 and 1. Weight given to the selected +#' maximum probability component relative to the distance-weighted mean +#' probability when computing raw condition. Ignored when \code{boost} is not +#' \code{NULL} or \code{NA}; the inspection app default is \code{boost = k2}. +#' @param boost \code{NULL}, \code{NA}, or one positive finite numeric factor. +#' The inspection app default \code{k2} multiplies the kernel weight of the +#' highest-probability retained site by \code{k2} and returns the resulting +#' weighted mean instead of the LDC blend. \code{confidence} is ignored in this +#' mode. Use \code{NULL} or \code{NA} for the unboosted LDC blend. +#' @param ... Additional arguments passed to \code{\link[shiny]{runApp}} when +#' \code{launch = TRUE}, such as \code{host}, \code{port}, or +#' \code{launch.browser}. +#' +#' @return A Shiny application object when \code{launch = FALSE}. When +#' \code{launch = TRUE}, the return value from \code{\link[shiny]{runApp}} is +#' returned invisibly after the application stops. +#' @seealso \code{\link{benchmark}}, \code{\link{reference_use}} +#' @export +#' +#' @examples +#' \dontrun{ +#' app <- hcas_inspection( +#' data = reference_samples, +#' samples = reference_samples, +#' ref_density = normalised_density, +#' crs = "EPSG:3577", +#' launch = FALSE +#' ) +#' shiny::runApp(app) +#' } +hcas_inspection <- function( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0.0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + confidence = 0.5, + lambda = 1.0, + exclude_slef = FALSE, + drop_features = NULL, + num_threads = -1, + crs = NULL, + background = NULL, + background_colors = NULL, + launch = interactive(), + kernel = c("Gaussian", "Cauchy"), + boost = k2, + ...) { + + kernel <- .check_kernel(kernel) + required <- c("shiny", "shinyWidgets", "leaflet", "ggplot2") + available <- vapply(required, requireNamespace, logical(1), quietly = TRUE) + if (!all(available)) { + stop( + "'hcas_inspection()' requires the suggested package(s): ", + paste(required[!available], collapse = ", "), + "." + ) + } + if (!is.null(background) && !requireNamespace("leafem", quietly = TRUE)) { + stop("The 'background' map requires the suggested package 'leafem'.") + } + + raster_data <- .is_rast(data) + data <- if (raster_data) { + .check_rast(data, name = "data") + } else if (.is_mat(data)) { + .check_mat(data, name = "data") + } else { + stop("'data' must be a raster, matrix, or data.frame.") + } + if (raster_data && !inherits(data, "SpatRaster")) { + stop("'data' must be convertible to a terra SpatRaster object.") + } + if (raster_data && .inspection_has_crs(crs)) { + terra::crs(data) <- crs + } + samples <- if (.is_mat(samples)) { + .check_mat(samples, name = "samples") + } else { + stop("'samples' must be a matrix or data.frame, not a temporal list.") + } + if (!raster_data && !nrow(data)) { + stop("'data' must contain at least one target row.") + } + if (raster_data && terra::ncell(data) < 1L) { + stop("'data' raster must contain at least one cell.") + } + if (!nrow(samples)) { + stop("'samples' must contain at least one reference row.") + } + if (raster_data) { + if (terra::nlyr(data) %% 2L) { + stop("'data' raster must contain matching predicted and observed RS layers.") + } + samples <- .inspection_raster_samples(data, samples) + } else { + if (ncol(data) != ncol(samples)) { + stop("'data' and 'samples' must have matching columns.") + } + .num_rs_vars_mat(data, "data") + } + .num_rs_vars_mat(samples, "samples") + + background_file <- .inspection_background_cog(background) + background_colors <- .inspection_background_colors(background_colors) + + if (length(k1) != 1L || !is.finite(k1) || k1 < 1) { + stop("'k1' must be one finite number greater than or equal to one.") + } + if (length(k2) != 1L || !is.finite(k2) || k2 < 1 || k2 > k1) { + stop("'k2' must be between one and 'k1'.") + } + boost <- .check_boost(boost) + + density <- .inspection_density( + ref_density = ref_density, + bin_width = bin_width, + offset = offset, + interpolate = interpolate + ) + geographic <- .is_lonlat(data) + map_crs <- if (raster_data) { + .inspection_data_crs(data, crs) + } else { + crs + } + if (!geographic && !.inspection_has_crs(map_crs)) { + stop("'crs' must be supplied to display projected coordinates on the map.") + } + + condition_mode_default <- if (is.null(boost)) "ldc" else "boost" + boost_default <- if (is.null(boost)) as.numeric(k2) else boost + condition_value_default <- if (condition_mode_default == "ldc") { + confidence + } else { + boost_default + } + condition_value_label <- if (condition_mode_default == "ldc") { + "LDC confidence" + } else { + "Boost factor" + } + condition_value_max <- if (condition_mode_default == "ldc") 1 else Inf + condition_value_step <- if (condition_mode_default == "ldc") 0.05 else 1 + + radius_choices <- sort(unique(c(seq(0, 500, 50), radius_km))) + k1_choices <- sort(unique(c(seq(0, 100, 5), as.integer(k1)))) + k2_choices <- sort(unique(c(seq(0, 50, 5), as.integer(k2)))) + map_bounds <- if (raster_data) { + .inspection_raster_map_bounds(data, map_crs, geographic) + } else { + NULL + } + target_selector <- if (raster_data) { + default_xy <- .inspection_raster_default_xy(data) + shiny::fluidRow( + shiny::column( + width = 4, + shiny::numericInput( + "target_x", "X coordinate:", + value = default_xy[1], + min = terra::xmin(data), + max = terra::xmax(data) + ) + ), + shiny::column( + width = 4, + shiny::numericInput( + "target_y", "Y coordinate:", + value = default_xy[2], + min = terra::ymin(data), + max = terra::ymax(data) + ) + ), + shiny::column( + width = 3, + shiny::HTML("
"), + shinyWidgets::actionBttn( + inputId = "submit", + style = "pill", + color = "default", + size = "md", + label = "Run", + icon = shiny::icon("play") + ) + ) + ) + } else { + shiny::fluidRow( + shiny::column( + width = 6, + shiny::numericInput( + "point_id", "Enter sample id:", + value = 1, min = 1, max = nrow(data) + ) + ), + shiny::column( + width = 3, + shiny::HTML("
"), + shinyWidgets::actionBttn( + inputId = "submit", + style = "pill", + color = "default", + size = "md", + label = "Run", + icon = shiny::icon("play") + ) + ) + ) + } + + ui <- shiny::fluidPage( + shiny::tags$head( + shiny::tags$style(shiny::HTML( + " + #condition_mode .radiobtn.btn, + #kernel .radiobtn.btn { + background-color: #e6e9ed; + border-color: #c7ccd1; + color: #2f3942; + } + + #condition_mode .radiobtn.btn.active, + #kernel .radiobtn.btn.active { + background-color: #2f80c1; + border-color: #246aa2; + color: #ffffff; + } + + #condition_mode .radiobtn.btn:not(.active):hover, + #kernel .radiobtn.btn:not(.active):hover { + background-color: #d8dde3; + border-color: #b7bec6; + color: #25313b; + } + " + )) + ), + shiny::titlePanel("HCAS inspection tool"), + shiny::sidebarLayout( + shiny::sidebarPanel( + target_selector, + shiny::h4("Benchmarking Options:"), + shiny::fluidRow( + shiny::column( + width = 6, + shinyWidgets::radioGroupButtons( + inputId = "condition_mode", + label = "Condition estimator", + choices = c( + "LDC confidence" = "ldc", + "Boost" = "boost" + ), + selected = condition_mode_default, + justified = TRUE, + status = "default", + size = "sm" + ) + ), + shiny::column( + width = 3, + shinyWidgets::numericInputIcon( + inputId = "condition_value", + value = condition_value_default, + step = condition_value_step, + min = 0, + max = condition_value_max, + label = condition_value_label + ) + ) + ), + shiny::fluidRow( + shiny::column( + width = 3, + shinyWidgets::numericInputIcon( + inputId = "xy_penalty", + value = xy_penalty, + step = 0.5, + min = 0, + max = Inf, + label = "Geo-penalty" + ) + ), + shiny::column( + width = 9, + shiny::h3(" "), + shiny::HTML("
"), + shinyWidgets::materialSwitch( + inputId = "exclude_self", + value = exclude_slef, + label = "Exclude self-assessment", + status = "primary", + inline = FALSE, + right = TRUE + ) + ) + ), + shiny::fluidRow( + shiny::column( + width = 6, + shinyWidgets::radioGroupButtons( + inputId = "kernel", + label = "Kernel", + choices = c( + "Gaussian" = "gaussian", + "Cauchy" = "cauchy" + ), + selected = kernel, + justified = TRUE, + status = "default", + size = "sm" + ) + ), + shiny::column( + width = 3, + shinyWidgets::numericInputIcon( + inputId = "lambda", + value = lambda, + step = 0.1, + min = 0, + max = Inf, + label = "Lambda" + ) + ) + ), + shinyWidgets::sliderTextInput( + inputId = "radius_km", + label = "Search radius", + choices = radius_choices, + selected = radius_km, + grid = TRUE + ), + shinyWidgets::sliderTextInput( + inputId = "k1", + label = "Number of ENV neighbours", + choices = k1_choices, + selected = as.integer(k1), + grid = TRUE + ), + shinyWidgets::sliderTextInput( + inputId = "k2", + label = "Number of RS neighbours", + choices = k2_choices, + selected = as.integer(k2), + grid = TRUE + ), + shiny::textOutput("condition"), + shiny::textOutput("nearby_count"), + shiny::plotOutput("density_plot", width = "100%", height = "300px") + ), + shiny::mainPanel( + leaflet::leafletOutput("map", height = 1000) + ) + ) + ) + + server <- function(input, output, session) { + condition_values <- shiny::reactiveValues( + ldc = confidence, + boost = boost_default + ) + previous_condition_mode <- shiny::reactiveVal(condition_mode_default) + get_condition_value <- function(mode) { + if (mode == "ldc") { + condition_values$ldc + } else { + condition_values$boost + } + } + set_condition_value <- function(mode, value) { + if (mode == "ldc") { + condition_values$ldc <- value + } else { + condition_values$boost <- value + } + } + + shiny::observeEvent(input$condition_mode, { + old_mode <- previous_condition_mode() + if (!is.null(input$condition_value) && + old_mode %in% c("ldc", "boost")) { + set_condition_value(old_mode, input$condition_value) + } + + new_mode <- input$condition_mode + if (is.null(new_mode) || !(new_mode %in% c("ldc", "boost"))) { + return() + } + previous_condition_mode(new_mode) + + new_value <- get_condition_value(new_mode) + shiny::updateNumericInput( + session, + inputId = "condition_value", + label = if (new_mode == "ldc") { + "LDC confidence" + } else { + "Boost factor" + }, + value = new_value, + min = 0, + max = if (new_mode == "ldc") 1 else Inf, + step = if (new_mode == "ldc") 0.05 else 1 + ) + }, ignoreInit = FALSE) + + shiny::observeEvent(input$condition_value, { + mode <- previous_condition_mode() + if (mode %in% c("ldc", "boost")) { + set_condition_value(mode, input$condition_value) + } + }, ignoreInit = TRUE) + + if (raster_data) { + shiny::observeEvent(input$map_click, { + clicked <- input$map_click + target_xy <- tryCatch( + .inspection_raster_click_xy( + data, + lng = clicked$lng, + lat = clicked$lat, + crs = map_crs + ), + error = function(cond) { + shiny::showNotification( + conditionMessage(cond), + type = "warning" + ) + NULL + } + ) + if (is.null(target_xy)) { + return() + } + + shiny::updateNumericInput(session, "target_x", value = target_xy[1]) + shiny::updateNumericInput(session, "target_y", value = target_xy[2]) + + target_map <- .inspection_map_coordinates( + data.frame(x = target_xy[1], y = target_xy[2]), + map_crs, + geographic + ) + leaflet::leafletProxy("map", session = session) |> + leaflet::clearGroup("target_preview") |> + leaflet::addCircleMarkers( + data = target_map, + lng = ~x, + lat = ~y, + color = "red", + radius = 4, + group = "target_preview", + label = "Selected target" + ) + }, ignoreNULL = TRUE) + } + + inspected <- shiny::eventReactive(input$submit, { + target <- NULL + point_id <- NULL + target_error <- NULL + if (raster_data) { + target_x <- input$target_x + target_y <- input$target_y + shiny::validate( + shiny::need( + length(target_x) == 1L && is.finite(target_x) && + length(target_y) == 1L && is.finite(target_y), + "Target coordinates must be finite numbers." + ) + ) + target <- tryCatch( + .inspection_raster_target(data, target_x, target_y), + error = function(cond) { + target_error <<- conditionMessage(cond) + NULL + } + ) + shiny::validate(shiny::need(is.null(target_error), target_error)) + } else { + point_id <- as.integer(input$point_id) + } + radius_value <- as.numeric(input$radius_km) + k1_value <- as.integer(input$k1) + k2_value <- as.integer(input$k2) + kernel_value <- if (is.null(input$kernel)) { + NA_character_ + } else { + input$kernel + } + lambda_value <- input$lambda + condition_mode <- if (is.null(input$condition_mode)) { + NA_character_ + } else { + input$condition_mode + } + condition_value <- input$condition_value + shiny::validate( + shiny::need( + raster_data || + (is.finite(point_id) && + point_id >= 1L && + point_id <= nrow(data)), + "Sample id is outside the available target rows." + ), + shiny::need( + condition_mode %in% c("ldc", "boost"), + "Choose either LDC confidence or Boost." + ), + shiny::need( + length(condition_value) == 1L && is.finite(condition_value), + "The estimator value must be finite." + ), + shiny::need( + condition_mode != "ldc" || + (condition_value >= 0 && condition_value <= 1), + "LDC confidence must be between 0 and 1." + ), + shiny::need( + condition_mode != "boost" || condition_value > 0, + "Boost must be greater than zero." + ), + shiny::need( + kernel_value %in% c("gaussian", "cauchy"), + "Choose either Gaussian or Cauchy kernel." + ), + shiny::need( + length(lambda_value) == 1L && + is.finite(lambda_value) && + lambda_value > 0, + "Lambda must be greater than zero." + ), + shiny::need(k1_value >= 1L, "k1 must be greater than zero."), + shiny::need(k2_value >= 1L, "k2 must be greater than zero."), + shiny::need(k2_value <= k1_value, "k2 must be less than or equal to k1.") + ) + active_confidence <- if (condition_mode == "ldc") { + condition_value + } else { + confidence + } + active_boost <- if (condition_mode == "boost") { + condition_value + } else { + NULL + } + if (!raster_data) { + target <- data[point_id, , drop = FALSE] + } + + .inspection_point( + target = target, + samples = samples, + ref_density = density$values, + xy_stats = xy_stats, + xy_penalty = input$xy_penalty, + radius_km = radius_value, + k1 = k1_value, + k2 = k2_value, + bin_width = density$bin_width, + offset = density$offset, + confidence = active_confidence, + boost = active_boost, + lambda = lambda_value, + exclude_slef = input$exclude_self, + drop_features = drop_features, + num_threads = num_threads, + kernel = kernel_value, + geographic = geographic, + crs = map_crs + ) + }, ignoreNULL = TRUE) + + output$condition <- shiny::renderText({ + result <- inspected() + paste("Estimated condition:", round(result$condition, 5)) + }) + + output$nearby_count <- shiny::renderText({ + result <- inspected() + paste("Number of gray points:", nrow(result$nearby)) + }) + + output$density_plot <- shiny::renderPlot({ + result <- inspected() + .inspection_density_plot( + density = density$values, + selected = result$selected, + bin_width = density$bin_width, + offset = density$offset + ) + }, bg = "grey96") + + # Render the base map once so it appears immediately, before any Run, + # and is never torn down. Markers are updated in place via leafletProxy. + output$map <- leaflet::renderLeaflet({ + .inspection_leaflet_map( + result = NULL, + bounds = map_bounds, + background = background_file, + background_colors = background_colors + ) + }) + + shiny::observeEvent(input$submit, { + result <- tryCatch(inspected(), error = function(cond) NULL) + proxy <- leaflet::leafletProxy("map", session = session) |> + leaflet::clearGroup("target_preview") |> + leaflet::clearGroup("nearby") |> + leaflet::clearGroup("selected") |> + leaflet::clearGroup("target") + if (!is.null(result)) { + proxy <- .inspection_leaflet_result_markers(proxy, result) + zoom_bounds <- .inspection_result_bounds(result) + if (!is.null(zoom_bounds)) { + leaflet::flyToBounds( + proxy, + lng1 = zoom_bounds[1], + lat1 = zoom_bounds[2], + lng2 = zoom_bounds[3], + lat2 = zoom_bounds[4] + ) + } + } + }, ignoreInit = TRUE) + } + + app <- shiny::shinyApp(ui = ui, server = server) + if (!isTRUE(launch)) { + return(app) + } + + invisible(shiny::runApp(app, ...)) +} + + +.inspection_density <- function(ref_density, bin_width, offset, interpolate) { + if (!.is_mat(ref_density)) { + stop("'ref_density' must be a matrix or convertible to one.") + } + + is_density <- methods::is(ref_density, "reference_density") + if (is_density) { + density_bin_width <- attr(ref_density, "bin.width") + density_offset <- attr(ref_density, "offset") + if (is.null(bin_width)) { + bin_width <- density_bin_width + } else if (!is.null(density_bin_width) && bin_width != density_bin_width) { + warning("Provided 'bin_width' differs from reference density attribute.") + } + if (is.null(offset)) { + offset <- density_offset + } else if (!is.null(density_offset) && offset != density_offset) { + warning("Provided 'offset' differs from reference density attribute.") + } + } + + if (length(bin_width) != 1L || !is.finite(bin_width) || bin_width <= 0) { + stop("'bin_width' must be supplied and greater than zero.") + } + if (is.null(offset)) { + offset <- 0 + } + if (length(offset) != 1L || !is.finite(offset) || offset < 0) { + stop("'offset' must be one non-negative number.") + } + + values <- .check_mat(unclass(ref_density), name = "ref_density") + if (isTRUE(interpolate)) { + values <- terra::as.matrix( + terra::disagg( + terra::rast(values), + fact = 2, + method = "bilinear" + ), + wide = TRUE + ) + bin_width <- bin_width / 2 + offset <- offset * 2 + } + + list(values = values, bin_width = bin_width, offset = as.integer(offset)) +} + + +.inspection_has_crs <- function(x) { + crs <- if (inherits(x, "SpatRaster")) { + terra::crs(x) + } else { + x + } + + length(crs) == 1L && !is.na(crs) && nzchar(crs) +} + + +.inspection_data_crs <- function(data, crs) { + if (inherits(data, "SpatRaster") && .inspection_has_crs(data)) { + return(terra::crs(data)) + } + if (.inspection_has_crs(crs)) { + return(crs) + } + NULL +} + + +.inspection_raster_samples <- function(data, samples) { + if (ncol(samples) == 2L) { + samples <- cbind( + samples, + as.matrix(terra::extract(data, samples)) + ) + } else if ((ncol(samples) - 2L) != terra::nlyr(data)) { + stop("Sample feature count does not match number of raster layers.") + } + + if (anyNA(samples)) { + stop("'samples' contains missing values or locations outside the raster.") + } + + samples +} + + +.inspection_raster_default_xy <- function(data) { + # Start at the centre of the raster extent. The point need not fall on a + # populated cell; the map renders there and the user can move it elsewhere. + c( + (terra::xmin(data) + terra::xmax(data)) / 2, + (terra::ymin(data) + terra::ymax(data)) / 2 + ) +} + + +.inspection_raster_cell_xy <- function(data, x, y) { + .inspection_raster_cell_info(data, x, y)$xy +} + + +.inspection_raster_cell_info <- function(data, x, y) { + if (length(x) != 1L || !is.finite(x) || + length(y) != 1L || !is.finite(y)) { + stop("Target coordinates must be finite numbers.") + } + + cell <- terra::cellFromXY(data, cbind(x, y)) + if (!length(cell) || is.na(cell[1])) { + stop("Target coordinate is outside the raster extent.") + } + + list( + cell = cell[1], + xy = unname(terra::xyFromCell(data, cell[1])[1, ]) + ) +} + + +.inspection_raster_target <- function(data, x, y) { + target <- .inspection_raster_cell_info(data, x, y) + values <- as.matrix(terra::extract(data, target$cell)) + if (!nrow(values)) { + stop("Target coordinate could not be extracted from the raster.") + } + if (anyNA(values)) { + missing_layers <- names(data)[which(is.na(values[1, ]))] + if (is.null(missing_layers) || any(!nzchar(missing_layers))) { + missing_layers <- paste0("layer ", which(is.na(values[1, ]))) + } + stop( + "Target raster cell ", target$cell, + " has missing values in: ", + paste(missing_layers, collapse = ", "), + "." + ) + } + + cbind( + matrix(target$xy, nrow = 1L, dimnames = list(NULL, c("x", "y"))), + values + ) +} + + +.inspection_map_click_xy <- function(lng, lat, crs) { + if (length(lng) != 1L || !is.finite(lng) || + length(lat) != 1L || !is.finite(lat)) { + stop("Map click did not provide finite coordinates.") + } + if (!.inspection_has_crs(crs)) { + return(c(lng, lat)) + } + + point <- terra::vect( + data.frame(x = lng, y = lat), + geom = c("x", "y"), + crs = "EPSG:4326" + ) + point <- terra::project(point, crs) + unname(terra::crds(point)[1, ]) +} + + +.inspection_raster_click_xy <- function(data, lng, lat, crs) { + xy <- .inspection_map_click_xy(lng, lat, crs) + .inspection_raster_cell_info(data, xy[1], xy[2])$xy +} + + +.inspection_raster_map_bounds <- function(data, crs, geographic) { + extent <- terra::ext(data) + corners <- data.frame( + x = c(extent[1], extent[1], extent[2], extent[2]), + y = c(extent[3], extent[4], extent[3], extent[4]) + ) + corners <- .inspection_map_coordinates(corners, crs, geographic) + bounds <- c( + lng1 = min(corners$x, na.rm = TRUE), + lat1 = min(corners$y, na.rm = TRUE), + lng2 = max(corners$x, na.rm = TRUE), + lat2 = max(corners$y, na.rm = TRUE) + ) + + if (any(!is.finite(bounds))) { + return(NULL) + } + if (bounds["lng1"] == bounds["lng2"]) { + bounds[c("lng1", "lng2")] <- bounds[c("lng1", "lng2")] + c(-0.01, 0.01) + } + if (bounds["lat1"] == bounds["lat2"]) { + bounds[c("lat1", "lat2")] <- bounds[c("lat1", "lat2")] + c(-0.01, 0.01) + } + + bounds +} + + +# lon/lat bounding box (lng1, lat1, lng2, lat2) of the inspected target and its +# nearby/selected reference samples, used to zoom the map in on Run. +.inspection_result_bounds <- function(result) { + xs <- c(result$target$x, result$nearby$x, result$selected$x) + ys <- c(result$target$y, result$nearby$y, result$selected$y) + xs <- xs[is.finite(xs)] + ys <- ys[is.finite(ys)] + if (!length(xs) || !length(ys)) { + return(NULL) + } + + bounds <- c(min(xs), min(ys), max(xs), max(ys)) + # Pad a single-point (or single-line) extent so the map does not over-zoom. + if (bounds[1] == bounds[3]) { + bounds[c(1, 3)] <- bounds[c(1, 3)] + c(-0.05, 0.05) + } + if (bounds[2] == bounds[4]) { + bounds[c(2, 4)] <- bounds[c(2, 4)] + c(-0.05, 0.05) + } + + bounds +} + + +# georaster-layer-for-leaflet renders EPSG:3857 and EPSG:4326 natively. +.inspection_is_webmercator <- function(r) { + isTRUE(terra::same.crs(r, "EPSG:3857")) || + isTRUE(terra::same.crs(r, "EPSG:4326")) +} + + +# Normalise the 'background' argument to a single-band Cloud-Optimized GeoTIFF +# in web mercator that is served to leafem::addGeotiff() via url = (not file =). +# The url = path performs no gdal_translate/gdalwarp, so internal overviews are +# preserved and streamed. A single-band EPSG:3857/4326 file on disk is served +# as-is; anything else is reduced to its first layer, reprojected to EPSG:3857 +# when needed, and written to a COG with overviews under the session tempdir. +.inspection_background_cog <- function(background) { + if (is.null(background)) { + return(NULL) + } + if (is.character(background)) { + if (length(background) != 1L || !nzchar(background)) { + stop("'background' must be a single file path or a terra SpatRaster.") + } + if (!file.exists(background)) { + stop("'background' file does not exist: ", background) + } + r <- terra::rast(background) + if (terra::nlyr(r) == 1L && .inspection_is_webmercator(r)) { + return(background) + } + } else if (.is_rast(background)) { + r <- .check_rast(background, name = "background") + } else { + stop("'background' must be a file path or a terra SpatRaster.") + } + if (terra::nlyr(r) > 1L) { + r <- r[[1L]] + } + if (!.inspection_is_webmercator(r)) { + r <- terra::project(r, "EPSG:3857") + } + dir <- file.path(tempdir(), "hcas_background") + dir.create(dir, recursive = TRUE, showWarnings = FALSE) + path <- file.path(dir, "background.tif") + terra::writeRaster( + r, path, filetype = "COG", + gdal = c("OVERVIEWS=AUTO", "COMPRESS=DEFLATE"), overwrite = TRUE + ) + path +} + + +# Validate the optional colour ramp for the background raster. +.inspection_background_colors <- function(colors) { + if (is.null(colors)) { + return(NULL) + } + if (!is.character(colors) || !length(colors)) { + stop( + "'background_colors' must be a character vector of colours, ", + "e.g. c(\"#430E59\", \"#CCCC66\", \"#184F0F\")." + ) + } + valid <- tryCatch({ + grDevices::col2rgb(colors) + TRUE + }, error = function(cond) FALSE) + if (!valid) { + stop("'background_colors' contains invalid colour codes.") + } + colors +} + + +.inspection_leaflet_map <- function(result = NULL, bounds = NULL, + background = NULL, + background_colors = NULL) { + map <- leaflet::leaflet() + map <- leaflet::addTiles(map) + map <- leaflet::addProviderTiles(map, "Esri.WorldImagery") + + if (!is.null(background)) { + palette <- if (is.null(background_colors)) palettes() else background_colors + # Serve the COG over url = (not file =): the url = path skips leafem's + # gdal_translate/gdalwarp, so the internal overviews survive and stream. + # group/layerId must be set explicitly here because leafem derives them + # from `file`, which is NULL on the url = path. autozoom = FALSE leaves + # the view to fitBounds() below; bands = 1 renders one thematic layer. + shiny::addResourcePath("hcas_background", dirname(background)) + map <- leafem::addGeotiff( + map, + url = paste0("hcas_background/", basename(background)), + group = "background", + layerId = "background", + bands = 1, + opacity = 0.8, + autozoom = FALSE, + colorOptions = leafem::colorOptions( + palette = palette, + na.color = "transparent" + ) + ) + } + + if (!is.null(bounds)) { + # Open at the raster extent. Strip names: leaflet serialises a named + # scalar to a JSON object ({"lng1": 133}) instead of a bare number, + # which breaks fitBounds. + bounds <- unname(bounds[c("lng1", "lat1", "lng2", "lat2")]) + map <- leaflet::fitBounds( + map, + lng1 = bounds[1], + lat1 = bounds[2], + lng2 = bounds[3], + lat2 = bounds[4] + ) + } + + if (is.null(result)) { + return(map) + } + + .inspection_leaflet_result_markers(map, result) +} + + +.inspection_leaflet_result_markers <- function(map, result) { + if (nrow(result$nearby)) { + map <- leaflet::addCircleMarkers( + map, + data = result$nearby, + lng = ~x, + lat = ~y, + color = "gray", + radius = 2, + group = "nearby", + label = ~paste("Sample id:", id) + ) + } + if (nrow(result$selected)) { + map <- leaflet::addCircleMarkers( + map, + data = result$selected, + lng = ~x, + lat = ~y, + color = "blue", + radius = 3, + group = "selected", + label = ~paste("Selected sample id:", id) + ) + } + leaflet::addCircleMarkers( + map, + data = result$target, + lng = ~x, + lat = ~y, + color = "red", + radius = 3, + group = "target", + label = "Target" + ) +} + + +.inspection_point <- function( + target, + samples, + ref_density, + xy_stats, + xy_penalty, + radius_km, + k1, + k2, + bin_width, + offset, + confidence, + boost, + lambda, + exclude_slef, + drop_features, + num_threads, + kernel, + geographic, + crs) { + + n_vars <- .num_rs_vars_mat(samples, "samples") + keep_features <- .keep_rs_features(drop_features, n_vars) + samples_kept <- .subset_rs_mat(samples, keep_features) + target_kept <- .subset_rs_mat(target, keep_features) + kept_n_vars <- length(keep_features) + predicted_columns <- 2L + seq_len(kept_n_vars) + observed_columns <- predicted_columns + kept_n_vars + bin_num <- min(dim(ref_density)) + + use <- reference_use_cpp( + target_vals = target_kept, + sample_vals = samples_kept, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + geographic = geographic, + radius_km = radius_km, + k_env = k1, + k_rs = k2, + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + num_threads = num_threads, + weighted_max = FALSE, + kernel = kernel + ) + condition <- bench_cpp( + raster_vals = target_kept, + sample_vals = samples_kept, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + geographic = geographic, + radius_km = radius_km, + k_env = k1, + k_rs = k2, + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + temporal_weights = NULL, + make_su = FALSE, + num_threads = num_threads, + kernel = kernel + ) + + selected_ids <- which(use$density > 0) + selected <- data.frame( + id = selected_ids, + x = samples_kept[selected_ids, 1], + y = samples_kept[selected_ids, 2], + predicted_distance = numeric(length(selected_ids)), + observed_distance = numeric(length(selected_ids)) + ) + if (length(selected_ids)) { + selected$predicted_distance <- rowSums(abs( + sweep( + samples_kept[selected_ids, predicted_columns, drop = FALSE], + 2, + target_kept[1, predicted_columns], + FUN = "-" + ) + )) + selected$observed_distance <- rowSums(abs( + sweep( + samples_kept[selected_ids, observed_columns, drop = FALSE], + 2, + target_kept[1, observed_columns], + FUN = "-" + ) + )) + } + + nearby_ids <- .inspection_radius_ids( + target_xy = target[1, 1:2], + sample_xy = samples_kept[, 1:2, drop = FALSE], + radius_km = radius_km, + geographic = geographic + ) + nearby <- data.frame( + id = nearby_ids, + x = samples_kept[nearby_ids, 1], + y = samples_kept[nearby_ids, 2] + ) + target_map <- data.frame(x = target[1, 1], y = target[1, 2]) + + list( + condition = unname(condition[1, 1]), + nearby = .inspection_map_coordinates(nearby, crs, geographic), + selected = .inspection_map_coordinates(selected, crs, geographic), + target = .inspection_map_coordinates(target_map, crs, geographic) + ) +} + + +.inspection_radius_ids <- function(target_xy, sample_xy, radius_km, geographic) { + radius_m <- radius_km * 1000 + dx <- sample_xy[, 1] - target_xy[1] + dy <- sample_xy[, 2] - target_xy[2] + if (geographic) { + dx <- dx * cos(target_xy[2] * pi / 180) + radius <- radius_m / 111320 + } else { + radius <- radius_m + } + which(dx * dx + dy * dy <= radius * radius) +} + + +.inspection_map_coordinates <- function(x, crs, geographic) { + if (!nrow(x)) { + return(x) + } + if (geographic && !.inspection_has_crs(crs)) { + return(x) + } + + source_crs <- if (.inspection_has_crs(crs)) crs else "EPSG:4326" + points <- terra::vect( + x[, c("x", "y"), drop = FALSE], + geom = c("x", "y"), + crs = source_crs + ) + if (!terra::is.lonlat(points, perhaps = TRUE, warn = FALSE)) { + points <- terra::project(points, "EPSG:4326") + } + x[, c("x", "y")] <- terra::crds(points) + x +} + + +.inspection_density_plot <- function(density, selected, bin_width, offset) { + colours <- c( + "gray92", "#F5F2D8", "#C6E8BC", "#7ED5B8", + "#34B8C0", "#478EC1", "#7A55AB", "#80146E" + ) + density_x <- (seq_len(nrow(density)) - 1L + offset) * bin_width + density_y <- (seq_len(ncol(density)) - 1L + offset) * bin_width + density_plot <- expand.grid(x = density_x, y = density_y) + density_plot$value <- as.vector(density) + maximum <- if (nrow(selected)) { + max(selected[, c("predicted_distance", "observed_distance")]) + 0.5 + } else { + 0.5 + } + + x <- y <- value <- predicted_distance <- observed_distance <- NULL + ggplot2::ggplot( + data = selected, + ggplot2::aes(x = predicted_distance, y = observed_distance) + ) + + ggplot2::geom_tile( + data = density_plot, + ggplot2::aes(x = x, y = y, fill = value), + alpha = 0.7, + inherit.aes = FALSE + ) + + ggplot2::geom_point(alpha = 0.5, colour = "blue", size = 3) + + ggplot2::scale_x_continuous(limits = c(-0.1, maximum)) + + ggplot2::scale_y_continuous(limits = c(-0.1, maximum)) + + ggplot2::geom_abline(intercept = 0, slope = 1, alpha = 0.5, linetype = 3) + + ggplot2::scale_fill_gradientn(colours = colours) + + ggplot2::theme( + plot.background = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + legend.background = ggplot2::element_blank() + ) + + ggplot2::coord_equal() + + ggplot2::labs( + x = "Predicted distance", + y = "Observed distance", + fill = "Condition" + ) +} diff --git a/R/normalise.R b/R/normalise.R index d4aa9d8..ce7afb2 100644 --- a/R/normalise.R +++ b/R/normalise.R @@ -1,35 +1,59 @@ -#' Clean and normalise HCAS reference density +#' Clean and normalise an HCAS reference density surface #' -#' This process includes trimming the reference density surface to remove noise and -#' normalising its values. +#' Trims and normalises the raw reference density surface returned by +#' \code{\link{ref_density}} so it can be used as a probability surface in +#' \code{\link{benchmark}}. +#' +#' @details +#' The raw reference density surface is a two-dimensional surface of predicted +#' and observed RS distances among reference samples. Before benchmarking, the +#' surface is smoothed, trimmed to remove noisy outer bins, and normalised with +#' respect to predicted-distance bins. This makes each predicted-distance slice +#' comparable when \code{\link{benchmark}} asks how probable an observed +#' departure is for a target location. +#' +#' \code{trim_size} controls the dimensions of the retained square surface. It +#' should be smaller than the number of bins used in +#' \code{\link{ref_density}}. The default is chosen for the standard HCAS +#' workflow; smaller examples or exploratory analyses can use smaller values. +#' +#' \code{offset} removes bins nearest the origin before normalisation. It is +#' useful when the near-zero distance cells contain self-overlap or other +#' artefacts. The value is stored on the returned \code{reference_density} +#' object and must be kept consistent in \code{\link{benchmark}}. #' #' @param x An HCAS \code{reference_density} object or a matrix representing the -#' reference density surface (see \code{\link{ref_density}}). -#' @param bin_width Numeric. Specifies the bin width of the reference density. If -#' \code{x} is a \strong{reference_density} object, this value can be read from -#' its attributes and may be left \code{NULL}. The bin width must be consistent -#' between the reference density creation and the benchmarking step to ensure -#' condition is accurately calculated. -#' @param trim_size Integer. Defines the number of rows and columns in the trimmed reference density. The default -#' is 400, and it is generally advisable to retain this default setting. -#' @param offset Integer. Specifies the number of reference density bins to ignore during normalization. This value -#' will be stored as an attribute in the output object. -#' @param legacy Logical. Whether to use the legacy C++ code for normalisation (for backward -#' compatibility) or the modern R version (default). The modern version solves the edge effect -#' issue without any speed compromise. -#' @param filename Char (optional). The output file name for the .text file. +#' raw reference density surface created by \code{\link{ref_density}}. +#' @param bin_width Numeric. Bin width used to create the reference density. If +#' \code{x} is a \code{reference_density} object, the value is read from its +#' \code{bin.width} attribute when \code{bin_width = NULL}. The value must match +#' the density surface used during benchmarking. +#' @param trim_size Integer. Number of rows and columns to keep in the trimmed +#' reference density surface. +#' @param offset Integer. Number of near-origin bins to ignore during +#' normalisation. Stored as an attribute on the output. +#' @param legacy Logical. If \code{TRUE}, use the legacy C++ normalisation code +#' for backward compatibility. The default R implementation avoids the previous +#' edge effect while retaining similar speed for typical use. +#' @param filename Optional character. File path for writing the normalised +#' surface as a tab-delimited \file{.txt} file. #' #' @seealso \code{\link{ref_density}}, and \code{\link{benchmark}} #' -#' @return A \code{reference_density} object (also matrix, array) +#' @return A \code{reference_density} object, which is also a matrix/array. #' @export #' #' @examples #' \donttest{ #' library(ClassicHCAS) #' +#' raw <- matrix(rexp(30 * 30), nrow = 30) +#' class(raw) <- c("reference_density", "matrix", "array") +#' attr(raw, "bin.width") <- 0.1 #' -#' +#' norm <- normalise(raw, trim_size = 15) +#' attr(norm, "bin.width") +#' attr(norm, "offset") #' } normalise <- function( x, @@ -130,4 +154,3 @@ normalise <- function( t(mat) ) } - diff --git a/R/radial_count.R b/R/radial_count.R index fa9af2a..ef59edb 100644 --- a/R/radial_count.R +++ b/R/radial_count.R @@ -1,112 +1,123 @@ -#' Number of samples within a radius -#' -#' This function calculates the number of samples (x, y coordinates) within a specified radius -#' for each pixel in a raster map. -#' -#' This function uses an integer-based distance checks for fast radius searches on either -#' geographic or projected coordinates. In geographic mode, coordinates are -#' stored in micro-degrees (degree * 1000_000) and the distance is approximated by: -#' -#' distance² ≈ (dlat)² + (dlon × cos(lat₁))² -#' -#' where cos(lat₁) is derived from the query latitude. This avoids floating- -#' point overhead and provides substantial performance gains but introduces -#' distortion at larger distances. For applications requiring higher accuracy, -#' especially beyond regional scales (more than several 100s of kilometers in \code{radius_km}), -#' use a projected coordinate system so distances in meters can be evaluated directly. -#' -#' Ensure that \href{https://en.wikipedia.org/wiki/OpenMP}{OpenMP} is installed on your system -#' to take advantage of parallel processing and accelerate computations. While most systems -#' include OpenMP by default, you may need to load the appropriate module if you're using an HPC -#' system. -#' -#' \strong{Note for macOS users:} Install OpenMP via Homebrew with \code{brew install libomp} -#' before installing this package. -#' -#' @param x A SpatRaster representing the study area over which sample density will be calculated. -#' @param samples_xy A matrix or data.frame containing x and y coordinates (longitude and latitude) -#' of the reference points used for density calculation. -#' @param radius_km Numeric. Specifies the search radius (buffer) in kilometers. -#' @param num_threads Integer. Specifies the number of CPU threads to be used for processing. A value -#' below 1 indicates that all available threads will be utilized. Refer to the details section for -#' more information. -#' @param ... Additional arguments for writing raster outputs e.g. \code{filename}, -#' \code{overwrite}, and \code{wopt} from terra \code{\link[terra]{predict}}. -#' -#' @seealso \code{\link{benchmark}} -#' -#' @return A SpatRaster -#' @export -#' -#' @examples -#' \donttest{ -#' library(ClassicHCAS) -#' -#' -#' -#' } -radial_count <- function( - x, - samples_xy, - radius_km = 200, - num_threads = -1, - ...) { - - # check samples - if (.is_mat(samples_xy)) { - samples_xy <- .check_mat(samples_xy) - } else { - stop("'samples_xy' must be a matrix or an object convertibe to matrix.") - } - - # check terra is available - .check_pkgs("terra") - # get the raster layers - x <- .check_rast(x) - - tryCatch( - { - output <- terra::interpolate( - object = x[[1]], - model = list(), - fun = .proxy_count, - xy = samples_xy[, 1:2], - radius_km = radius_km, - geographic = .is_lonlat(x), - num_threads = num_threads, - ... - ) - }, - error = function(cond) { - stop("Radial count calculation failed!\n", cond) - } - ) - - return( - output - ) -} - -# wrapper function for radial_count_cpp -.proxy_count <- function(model, newdata, ...) { - nr <- nrow(newdata) - - tryCatch( - { - pcount <- radial_count_cpp( - rast = as.matrix(newdata), - ... - ) - }, - error = function(cond) { - message("Error: the radial_count C++ function faild, returning -2!") - # return error values -0.02 - return( - rep(-2, nr) - ) - } - ) - - return(pcount) -} - +#' Count samples within a radius around each raster cell +#' +#' Counts how many sample points fall within a specified radius of each cell in a +#' raster. In HCAS workflows this is mainly an operational helper for mapping +#' local reference-sample support and for creating workload weights before +#' tiling large benchmarking jobs. +#' +#' @details +#' \code{radial_count()} does not calculate habitat condition. It produces a +#' sample-density raster that can help diagnose sparse reference coverage or +#' guide \code{\link{tiling}} so densely sampled areas with heavy computation +#' are balanced across tiles. +#' +#' In geographic coordinates, radius searches use a fast integer approximation. +#' Coordinates are stored in micro-degrees (\code{degree * 1000000}) and distance +#' is approximated by: +#' +#' \deqn{distance^2 \approx (\Delta \mathrm{lat})^2 + (\Delta \mathrm{lon} \times \cos(\mathrm{lat}_1))^2}{distance^2 ~= (Delta lat)^2 + ((Delta lon) * cos(lat_1))^2} +#' +#' where \eqn{\Delta \mathrm{lat}}{Delta lat} and \eqn{\Delta \mathrm{lon}}{Delta lon} +#' are coordinate differences, and \eqn{\cos(\mathrm{lat}_1)}{cos(lat_1)} is +#' derived from the query latitude. This is efficient for large analyses but +#' introduces distortion over large areas. For high accuracy at broad regional +#' or continental radii, use a projected coordinate reference system so +#' distances can be evaluated in metres. +#' +#' \code{num_threads} uses OpenMP when available. On macOS, installing OpenMP +#' support with \code{brew install libomp} before installing the package may be +#' required for multi-threaded execution. +#' +#' @param x A \pkg{terra} \code{SpatRaster} whose cells define the locations +#' where sample counts are calculated. Only the first layer is used. +#' @param samples_xy A two-column matrix or data.frame containing sample +#' coordinates in the same coordinate reference system as \code{x}. +#' @param radius_km Numeric. Search radius, in kilometres. +#' @param num_threads Integer. Number of CPU threads to use. Values below 1 use +#' all available OpenMP threads. +#' @param ... Additional arguments passed to \code{\link[terra]{interpolate}}, +#' such as \code{filename}, \code{overwrite}, or \code{wopt}. +#' +#' @seealso \code{\link{benchmark}}, \code{\link{tiling}} +#' +#' @return A \pkg{terra} \code{SpatRaster} containing sample counts. +#' @export +#' +#' @examples +#' \donttest{ +#' library(ClassicHCAS) +#' +#' r <- terra::rast( +#' nrows = 10, ncols = 10, +#' xmin = 0, xmax = 1, ymin = 0, ymax = 1, +#' crs = "EPSG:4326" +#' ) +#' +#' samples <- cbind(x = c(0.2, 0.8), y = c(0.2, 0.8)) +#' counts <- radial_count(r, samples, radius_km = 50, num_threads = 1) +#' counts +#' } +radial_count <- function( + x, + samples_xy, + radius_km = 200, + num_threads = -1, + ...) { + + # check samples + if (.is_mat(samples_xy)) { + samples_xy <- .check_mat(samples_xy) + } else { + stop("'samples_xy' must be a matrix or an object convertibe to matrix.") + } + + # check terra is available + .check_pkgs("terra") + # get the raster layers + x <- .check_rast(x) + + tryCatch( + { + output <- terra::interpolate( + object = x[[1]], + model = list(), + fun = .proxy_count, + xy = samples_xy[, 1:2], + radius_km = radius_km, + geographic = .is_lonlat(x), + num_threads = num_threads, + ... + ) + }, + error = function(cond) { + stop("Radial count calculation failed!\n", cond) + } + ) + + return( + output + ) +} + +# wrapper function for radial_count_cpp +.proxy_count <- function(model, newdata, ...) { + nr <- nrow(newdata) + + tryCatch( + { + pcount <- radial_count_cpp( + rast = as.matrix(newdata), + ... + ) + }, + error = function(cond) { + message("Error: the radial_count C++ function faild, returning -2!") + # return error values -0.02 + return( + rep(-2, nr) + ) + } + ) + + return(pcount) +} diff --git a/R/ref_density.R b/R/ref_density.R index 87096d1..eb4a644 100644 --- a/R/ref_density.R +++ b/R/ref_density.R @@ -1,73 +1,111 @@ -#' Reference density surface -#' -#' The HCAS reference density surface calculation is based on pair-point densities. -#' It is an integral part of HCAS, designed to -#' learn the expected observed remote sensing (RS) values from the predicted RS -#' values across a wide range of reference sites. Note that the reference sites -#' used for \code{ref_density} do not need to be the same as those used in the -#' \code{\link{benchmark}} function. See more in details. -#' -#' Ensure that the order of remote sensing variables is consistent between predicted and observed inputs -#' (for both raster and matrix formats). The RS variable values must be centered and scaled -#' prior to prediction. Failure to do so may result in variables with larger ranges having -#' disproportionate influence in the multi-dimensional distance calculations. -#' -#' This function uses an integer-based distance checks for fast radius searches on either -#' geographic or projected coordinates. In geographic mode, coordinates are -#' stored in micro-degrees (degree * 1000_000) and the distance is approximated by: -#' -#' distance² ≈ (dlat)² + (dlon × cos(lat₁))² -#' -#' where cos(lat₁) is derived from the query latitude. This avoids floating- -#' point overhead and provides substantial performance gains but introduces -#' distortion at larger distances. For applications requiring higher accuracy, -#' especially beyond regional scales (more than several 100s of kilometers in \code{radius_km}), -#' use a projected coordinate system so distances in meters can be evaluated directly. -#' -#' Ensure that \href{https://en.wikipedia.org/wiki/OpenMP}{OpenMP} is installed on your system -#' to take advantage of parallel processing and accelerate computations. While most systems -#' include OpenMP by default, you may need to load the appropriate module if you're using an HPC -#' system. -#' -#' \strong{Note for macOS users:} Install OpenMP via Homebrew with \code{brew install libomp} -#' before installing this package. -#' -#' @param data A matrix, SpatRaster (from the \pkg{terra} package), or data.frame containing the input data. -#' The data \strong{must} be organised in the following order: \strong{x}, \strong{y}, \strong{predicted-RS}, -#' \strong{observed-RS} variables. If using a SpatRaster, the \strong{x} and \strong{y} are not required. -#' If using a matrix or data.frame, ensure that the variables are in the -#' correct order. For more see the details section. -#' @param samples A matrix or data.frame containing the x and y coordinates (longitude and latitude) -#' of the reference points used for the observed and predicted RS value extraction if \code{data} is a -#' raster object. If \code{data} argument is matrix, this will be ignored. -#' @param radius_km Numeric. Specifies the search radius in kilometers for considering reference samples -#' when creating the reference density surface. See details section for more information on distance calculation. -#' @param bin_width Numeric. Specifies the bin width of the reference density surface. Finding the optimal bin width -#' may require some experimentation to achieve the best results. The bin width is added as an attribute -#' to the output object, ensuring consistency and accuracy in subsequent benchmarking steps. -#' @param bin_num Integer. Specifies the number of bins for the reference density surface. It is generally recommended -#' to use the default value of 650. Adjusting \code{bin_width} is often more effective than changing -#' \code{bin_num}. -#' @param drop_features Integer vector. Completely remove RS variables from the reference density calculation. -#' Positions are 1-based within the RS feature set, not the full input column order. For -#' consistency, it is recommended to exclude the same variables later in the benchmarking step; unless -#' you have a specific reason not to. -#' @param num_threads Integer. Specifies the number of CPU threads to be used for processing. A value -#' below 1 indicates that all available threads will be utilized (default). Refer to the details section for -#' more information. -#' @param filename Character (optional). The name of the output file for saving the results as a .txt file. +#' Build an HCAS reference density surface +#' +#' Builds the raw reference density, or probability, surface used by HCAS to +#' describe natural variation between predicted and observed remote-sensing (RS) +#' variables at reference sites. +#' +#' @details +#' In HCAS, predicted RS values represent the expected reference-condition signal +#' for a site, usually estimated from environmental covariates using +#' high-integrity reference ecosystems. Observed RS values are the actual Earth +#' observation summaries for the same sites. \code{ref_density()} compares +#' reference samples with one another and records how predicted-distance and +#' observed-distance co-vary under reference condition. +#' +#' For each pair of reference samples within \code{radius_km}, the function +#' calculates L1 (Manhattan) distances across all retained RS variables: +#' +#' \deqn{d(x, y) = \sum_{j = 1}^{m} |x_j - y_j|} +#' +#' where \eqn{m} is the number of RS variables. The predicted-distance and +#' observed-distance values are then added to a two-dimensional surface with +#' resolution controlled by \code{bin_width} and \code{bin_num}. The resulting +#' surface is a compact empirical summary of how much observed RS variation is +#' expected for a given predicted RS distance among intact or near-intact +#' reference samples. +#' +#' The output of this function is raw and should normally be passed to +#' \code{\link{normalise}} before use in \code{\link{benchmark}}. The +#' \code{bin.width} attribute is stored on the returned object so that the same +#' bin width can be reused during normalisation and benchmarking. +#' +#' Matrix and data.frame inputs must be ordered as \code{x}, \code{y}, predicted +#' RS variables, then observed RS variables. Raster inputs should contain the +#' predicted RS layers followed by the observed RS layers in the same variable +#' order; the reference coordinates are supplied separately through +#' \code{samples}. Predicted and observed variables should be centred and scaled +#' consistently before running this function so that no variable dominates the +#' multidimensional distance calculation because of its units or numeric range. +#' +#' In geographic coordinates, radius searches use a fast integer approximation. +#' Coordinates are stored in micro-degrees (\code{degree * 1000000}) and distance +#' is approximated by: +#' +#' \deqn{distance^2 \approx (\Delta \mathrm{lat})^2 + (\Delta \mathrm{lon} \times \cos(\mathrm{lat}_1))^2}{distance^2 ~= (Delta lat)^2 + ((Delta lon) * cos(lat_1))^2} +#' +#' where \eqn{\Delta \mathrm{lat}}{Delta lat} and \eqn{\Delta \mathrm{lon}}{Delta lon} +#' are coordinate differences, and \eqn{\cos(\mathrm{lat}_1)}{cos(lat_1)} is +#' derived from the query latitude. This is efficient for large analyses but +#' introduces distortion over large areas. For high accuracy at broad regional +#' or continental radii, use a projected coordinate reference system so +#' distances can be evaluated in metres. +#' +#' \code{num_threads} uses OpenMP when available. On macOS, installing OpenMP +#' support with \code{brew install libomp} before installing the package may be +#' required for multi-threaded execution. +#' +#' @param data A matrix, data.frame, or \pkg{terra} \code{SpatRaster} containing +#' input RS data. Matrix and data.frame inputs must be organised as \code{x}, +#' \code{y}, predicted RS variables, then observed RS variables. Raster inputs +#' must contain predicted RS layers followed by observed RS layers in the same +#' variable order; +#' @param samples A two-column matrix or data.frame of sample coordinates used +#' to extract predicted and observed RS values when \code{data} is a raster. +#' Ignored for matrix or data.frame inputs. +#' @param radius_km Numeric. Search radius, in kilometres, for deciding which +#' reference-sample pairs contribute to the density surface. +#' @param bin_width Numeric. Width of each predicted-distance and +#' observed-distance bin. Smaller values increase resolution but can produce a +#' sparse surface; larger values smooth more aggressively. The value is stored +#' as a \code{bin.width} attribute on the output. +#' @param bin_num Integer. Number of bins along each axis of the density surface. +#' The default is usually adequate; tuning \code{bin_width} is generally more +#' useful than changing \code{bin_num}. +#' @param drop_features Optional integer vector of RS variable positions to +#' exclude from the density calculation. Positions are 1-based within the RS +#' feature set, not within the full input column order. Use the same exclusion +#' in \code{\link{benchmark}} unless there is a deliberate reason not to. +#' @param num_threads Integer. Number of CPU threads to use. Values below 1 use +#' all available OpenMP threads. +#' @param filename Optional character. File path for writing the raw density +#' surface as a tab-delimited \file{.txt} file. #' #' @seealso \code{\link{normalise}}, and \code{\link{benchmark}} #' -#' @return A \code{reference_density} object (also matrix, array) +#' @return A \code{reference_density} object, which is also a matrix/array. #' @export #' #' @examples #' \donttest{ #' library(ClassicHCAS) #' +#' # Matrix inputs are x, y, predicted RS variables, then observed RS variables. +#' reference_data <- cbind( +#' x = c(0, 0.4, 0.8, 1.2, 1.6, 2.0), +#' y = c(0, 0.2, 0.8, 1.0, 1.4, 1.8), +#' rs1 = c(0.10, 0.12, 0.25, 0.30, 0.42, 0.50), +#' rs1 = c(0.11, 0.14, 0.22, 0.33, 0.40, 0.52) +#' ) #' +#' rd <- ref_density( +#' reference_data, +#' radius_km = 250, +#' bin_width = 0.1, +#' bin_num = 20, +#' num_threads = 1 +#' ) #' +#' rd_norm <- normalise(rd, trim_size = 10) #' } ref_density <- function( data, diff --git a/R/reference_use.R b/R/reference_use.R new file mode 100644 index 0000000..5856e3a --- /dev/null +++ b/R/reference_use.R @@ -0,0 +1,347 @@ +#' Assess reference-site use during HCAS benchmarking +#' +#' Records how often and how strongly each reference site is used across the +#' three stages of the HCAS benchmarking selection process. +#' +#' @details +#' \code{reference_use()} runs the same non-temporal reference-site selection +#' stages used by \code{\link{benchmark}}, but returns one row per reference +#' site instead of habitat-condition values. It is implemented separately from +#' the benchmarking routine so normal benchmarking does not incur diagnostic +#' bookkeeping costs. +#' +#' The returned columns represent: +#' \describe{ +#' \item{\code{"predicted"}}{Count selection among the \code{k1} nearest +#' reference sites in predicted feature space after the radius restriction +#' and optional XY penalty.} +#' \item{\code{"density"}}{Count retention among the \code{k2} sites with +#' the highest reference-density probability.} +#' \item{\code{"condition"}}{Attribute each retained site's use according to +#' its contribution to the condition estimator. The +#' distance-weighted mean component uses normalised weights from the selected +#' \code{kernel}. With \code{boost} (the default is \code{k2}), attribution +#' uses boosted normalised kernel weights. Set \code{boost = NULL} or +#' \code{boost = NA} to use the LDC attribution, where the LDC component is +#' assigned to the site with the selected maximum probability contribution, +#' controlled by \code{weighted_max}; ties split that component equally. +#' Attribution weights sum to one for each evaluated target location.} +#' } +#' +#' The experimental temporal mode is not currently supported. Supply a single +#' reference sample matrix containing \code{x}, \code{y}, predicted RS +#' variables, then observed RS variables. +#' +#' Raster inputs are processed in blocks and accumulated into the reference-site +#' table, so the complete raster is not loaded into memory. +#' +#' @inheritParams benchmark +#' @param data A matrix, data.frame, or \pkg{terra} \code{SpatRaster} +#' containing target RS data. Matrix and data.frame inputs must be organised as +#' \code{x}, \code{y}, predicted RS variables, then observed RS variables. +#' Raster inputs must contain predicted RS layers followed by observed RS +#' layers in the same variable order. +#' @param samples A matrix or data.frame containing reference sites as +#' \code{x}, \code{y}, predicted RS variables, then observed RS variables in +#' the same order as \code{data}. For raster \code{data}, this can instead be a +#' two-column coordinate table, in which case values are extracted from the +#' raster. Temporal sample lists are not supported. +#' @param weighted_max Logical. If \code{FALSE} (the default), the LDC +#' attribution component uses the maximum unweighted probability. If +#' \code{TRUE}, it uses the maximum probability-times-distance-weight +#' contribution. This option affects attribution only when \code{boost = NULL} +#' or \code{boost = NA}. +#' +#' @return A data.frame with one row per reference site and four columns: +#' \itemize{ +#' \item \code{id}: 1-based row index in \code{samples}. +#' \item \code{predicted}: number of selections among \code{k1}. +#' \item \code{density}: number of retentions among \code{k2}. +#' \item \code{condition}: summed distance-kernel/LDC attribution weight. +#' } +#' +#' @seealso \code{\link{benchmark}} +#' @export +#' +#' @examples +#' target <- matrix( +#' c( +#' 0, 0, 0.1, 0.1, +#' 1, 1, 0.8, 0.8 +#' ), +#' ncol = 4, +#' byrow = TRUE +#' ) +#' samples <- matrix( +#' c( +#' 0, 0, 0.1, 0.1, +#' 1, 1, 0.8, 0.8 +#' ), +#' ncol = 4, +#' byrow = TRUE +#' ) +#' ref <- matrix(1, nrow = 20, ncol = 20) +#' +#' reference_use( +#' target, +#' samples, +#' ref, +#' radius_km = 1000, +#' k1 = 2, +#' k2 = 1, +#' bin_width = 0.1, +#' interpolate = FALSE, +#' exclude_slef = FALSE, +#' num_threads = 1 +#' ) +reference_use <- function( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0.0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + confidence = 0.5, + lambda = 1.0, + exclude_slef = TRUE, + drop_features = NULL, + num_threads = -1, + weighted_max = FALSE, + kernel = c("Gaussian", "Cauchy"), + boost = k2) { + + kernel <- .check_kernel(kernel) + boost <- .check_boost(boost) + if (k1 < k2) { + stop("'k2' must be less than or equal to 'k1'.") + } + if (length(confidence) != 1L || + !is.finite(confidence) || + confidence < 0 || + confidence > 1) { + stop("'confidence' must be one finite number between 0 and 1.") + } + if (length(lambda) != 1L || !is.finite(lambda) || lambda <= 0) { + stop("'lambda' must be one finite number greater than zero.") + } + if (!is.logical(weighted_max) || + length(weighted_max) != 1L || + is.na(weighted_max)) { + stop("'weighted_max' must be one non-missing logical value.") + } + if (is.list(samples) && !.is_mat(samples)) { + stop("Temporal sample lists are not supported by 'reference_use()'.") + } + samples <- if (.is_mat(samples)) { + .check_mat(samples) + } else { + stop("'samples' must be a matrix or convertible to one.") + } + + ref_density <- if (.is_mat(ref_density)) { + .check_mat(ref_density) + } else { + stop("'ref_density' must be a matrix or convertible to one.") + } + if (nrow(ref_density) != ncol(ref_density)) { + warning("Reference density dimensions are not equal!\n") + } + + if (methods::is(ref_density, "reference_density")) { + if (is.null(bin_width)) { + bin_width <- attributes(ref_density)$bin.width + } else if (bin_width != attributes(ref_density)$bin.width) { + warning("Provided 'bin_width' differs from reference density attribute.") + } + + if (is.null(offset)) { + offset <- attributes(ref_density)$offset + } else if (offset != attributes(ref_density)$offset) { + warning("Provided 'offset' differs from reference density attribute.") + } + } + if (is.null(bin_width)) { + stop("'bin_width' must be supplied when 'ref_density' has no bin-width attribute.") + } + + if (interpolate) { + ref_density <- terra::as.matrix( + terra::disagg( + terra::rast(.check_mat(unclass(ref_density), name = "ref_density")), + fact = 2, + method = "bilinear" + ), + wide = TRUE + ) + bin_width <- bin_width / 2 + offset <- offset * 2 + } + bin_num <- min(dim(ref_density)) + + sample_count <- nrow(samples) + if (.is_mat(data)) { + data <- .check_mat(data) + if (ncol(samples) != ncol(data)) { + stop("Samples must include all target values and match the columns in 'data'.") + } + + keep_features <- .keep_rs_features( + drop_features, + .num_rs_vars_mat(samples, "samples") + ) + samples <- .subset_rs_mat(samples, keep_features) + data <- .subset_rs_mat(data, keep_features) + + result <- reference_use_cpp( + target_vals = data, + sample_vals = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + geographic = .is_lonlat(data), + radius_km = radius_km, + k_env = k1, + k_rs = k2, + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + num_threads = num_threads, + weighted_max = weighted_max, + kernel = kernel + ) + } else if (.is_rast(data)) { + data <- .check_rast(data) + if (terra::nlyr(data) %% 2L) { + stop("'data' must contain matching predicted and observed RS layers.") + } + + if (ncol(samples) == 2L) { + samples <- cbind( + samples, + as.matrix(terra::extract(data, samples, ID = FALSE)) + ) + } else if ((ncol(samples) - 2L) != terra::nlyr(data)) { + stop("Sample feature count does not match number of raster layers.") + } + + keep_features <- .keep_rs_features( + drop_features, + terra::nlyr(data) / 2L + ) + samples <- .subset_rs_mat(samples, keep_features) + data <- .subset_rs_rast(data, keep_features) + + result <- .reference_use_raster( + data = data, + samples = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + radius_km = radius_km, + k1 = k1, + k2 = k2, + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + num_threads = num_threads, + weighted_max = weighted_max, + kernel = kernel + ) + } else { + stop("'data' must be a raster, matrix, or convertible object.") + } + + data.frame( + id = seq_len(sample_count), + predicted = result$predicted, + density = result$density, + condition = result$condition + ) +} + + +.reference_use_raster <- function( + data, + samples, + ref_density, + xy_stats, + xy_penalty, + radius_km, + k1, + k2, + bin_width, + bin_num, + offset, + confidence, + boost, + lambda, + exclude_slef, + num_threads, + weighted_max, + kernel) { + + predicted <- numeric(nrow(samples)) + density <- numeric(nrow(samples)) + condition <- numeric(nrow(samples)) + geographic <- .is_lonlat(data) + block <- terra::blocks(data) + + terra::readStart(data) + on.exit(terra::readStop(data), add = TRUE) + + for (i in seq_len(block$n)) { + values <- terra::readValues( + data, + row = block$row[i], + nrows = block$nrows[i], + mat = TRUE + ) + first_cell <- (block$row[i] - 1L) * terra::ncol(data) + 1L + last_cell <- (block$row[i] + block$nrows[i] - 1L) * terra::ncol(data) + xy <- terra::xyFromCell(data, first_cell:last_cell) + + current <- reference_use_cpp( + target_vals = cbind(xy, values), + sample_vals = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + geographic = geographic, + radius_km = radius_km, + k_env = k1, + k_rs = k2, + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + confidence = confidence, + boost = boost, + lambda = lambda, + exclude_slef = exclude_slef, + num_threads = num_threads, + weighted_max = weighted_max, + kernel = kernel + ) + predicted <- predicted + current$predicted + density <- density + current$density + condition <- condition + current$condition + } + + list( + predicted = predicted, + density = density, + condition = condition + ) +} diff --git a/R/tiling.R b/R/tiling.R index b70c04e..664e536 100644 --- a/R/tiling.R +++ b/R/tiling.R @@ -1,65 +1,75 @@ -#' Generate raster tiles using raster or matrix data +#' Create raster processing tiles #' -#' Creates either rectangular or balanced tiles for raster or matrix data. Balanced tiles -#' attempt to distribute the data values evenly across tiles, while rectangular tiles simply -#' divide the raster into equal-sized grids. This function helps creating tiles for running -#' \code{benchmark} function over multiple tiles or systems (e.g. in a cluster). The output -#' of the \code{\link{radial_count}} function can be used to balance the run time over each tile. +#' Creates rectangular or value-balanced tiles for splitting large raster +#' processing jobs, especially HCAS benchmarking runs, into smaller spatial +#' chunks. #' -#' @param data A `SpatRaster` object or a numeric matrix. For balanced tiling, either a matrix -#' or raster can be used. For rectangular tiling, a raster is required. -#' @param n_tiles Integer. Number of tiles to generate. -#' @param balanced Logical. If `TRUE` (default), tiles are created to balance the sum of values within each tile. -#' If `FALSE`, rectangular tiles of equal size are generated. -#' @param method Character. One of `"best"`, `"row"`, `"col"`, or `"both"` (default `"best"`). -#' Specifies how the balanced tiles should be split: -#' \describe{ -#' \item{"best"}{Automatically chooses the split direction that balances node weights and avoids overly skinny tiles.} -#' \item{"row"}{Always splits by rows.} -#' \item{"col"}{Always splits by columns.} -#' \item{"both"}{Splits along both dimensions, favoring the longer dimension.} -#' } -#' @param exact Logical. If `TRUE` (default), ensures exactly `n_tiles` are produced in balanced mode. -#' @param weighted Logical. If `TRUE` (default), tile weights are based on the scaled data values. -#' If `FALSE`, all non-zero values are treated equally. -#' @param spatial Logical. If `TRUE`, returns a `SpatVector` polygon of tiles. -#' If `FALSE` (default), returns a matrix or data frame with tile extents. -#' @param extent Optional. A `terra::ext` object specifying the raster extent. Required when `data` is a matrix. +#' @details +#' Large HCAS benchmarking jobs can be uneven because areas with many nearby +#' reference samples require more work than sparse areas. \code{tiling()} can +#' split a raster or matrix into tiles whose total cell weights are roughly +#' balanced, making distributed or multi-node processing more even. A common +#' workflow is to run \code{\link{radial_count}} first, then use the resulting +#' count raster as the \code{data} argument for balanced tiling. +#' +#' If \code{balanced = FALSE}, the function creates simple rectangular tiles of +#' similar size and ignores cell values. Rectangular tiling requires a +#' \pkg{terra} \code{SpatRaster}. If \code{balanced = TRUE}, the function treats +#' \code{NA} as zero, rescales non-missing values to positive weights, and +#' recursively splits the raster or matrix so each tile has a similar total +#' weight. If \code{weighted = FALSE}, all non-zero cells are treated equally. #' -#' @return Either: -#' \itemize{ -#' \item A `SpatVector` of polygons representing tiles (if `spatial = TRUE`), or -#' \item A matrix/data.frame with columns `"xmin"`, `"xmax"`, `"ymin"`, `"ymax"` for each tile (if `spatial = FALSE`). +#' @param data A \pkg{terra} \code{SpatRaster} or numeric matrix. Balanced tiling +#' accepts either form; rectangular tiling requires a raster. +#' @param n_tiles Integer. Number of tiles to generate. +#' @param balanced Logical. If \code{TRUE}, create tiles with approximately +#' balanced total weights. If \code{FALSE}, create rectangular tiles of similar +#' size. +#' @param method Character. Splitting strategy for balanced tiles. One of +#' \code{"best"}, \code{"row"}, \code{"col"}, or \code{"both"}: +#' \describe{ +#' \item{\code{"best"}}{Automatically chooses a split direction that balances +#' weights while avoiding very narrow tiles.} +#' \item{\code{"row"}}{Always splits by rows.} +#' \item{\code{"col"}}{Always splits by columns.} +#' \item{\code{"both"}}{Splits along both dimensions, favouring the longer +#' dimension.} #' } +#' @param exact Logical. If \code{TRUE}, force exactly \code{n_tiles} in balanced +#' mode. +#' @param weighted Logical. If \code{TRUE}, tile weights are based on the scaled +#' data values. If \code{FALSE}, all non-zero cells receive equal weight. +#' @param spatial Logical. If \code{TRUE}, return a \pkg{terra} +#' \code{SpatVector} polygon layer. If \code{FALSE}, return tile extents. +#' @param extent Optional \code{\link[terra]{ext}} object specifying the raster +#' extent. Required when \code{data} is a matrix. #' -#' @details -#' - Rectangular tiling divides the raster into equal-sized tiles regardless of data values. -#' - Balanced tiling attempts to split the data such that the sum of the cell values in each tile is roughly equal. -#' - The splitting process recursively divides the matrix/raster along rows or columns, according to the `method`. -#' - NA values are treated as zero for the purpose of balanced tiling. +#' @return If \code{spatial = TRUE}, a \pkg{terra} \code{SpatVector} of tile +#' polygons. Otherwise, a matrix with columns \code{xmin}, \code{xmax}, +#' \code{ymin}, and \code{ymax}. #' #' @examples -#' \dontrun{ +#' \donttest{ #' library(ClassicHCAS) -#' library(terra) #' -#' r <- rast(nrows=100, ncols=100) -#' values(r) <- runif(ncell(r)) +#' r <- terra::rast(nrows = 20, ncols = 20) +#' terra::values(r) <- runif(terra::ncell(r)) #' -#' # Balanced tiles -#' tiles_poly <- ClassicHCAS::tiling(r, n_tiles = 4, balanced = TRUE, spatial = TRUE) +#' # Balanced tiles from raster weights. +#' balanced_tiles <- tiling(r, n_tiles = 4, balanced = TRUE) #' -#' # Rectangular tiles -#' tiles_rect <- ClassicHCAS::tiling(r, n_tiles = 4, balanced = FALSE) +#' # Rectangular tiles. +#' rectangular_tiles <- tiling(r, n_tiles = 4, balanced = FALSE) #' -#' # Balanced tiles from a matrix -#' mat <- as.matrix(r) -#' ext <- ext(r) -#' tiles_from_matrix <- ClassicHCAS::tiling(mat, n_tiles = 4, balanced = TRUE, extent = ext) +#' # Balanced tiles from a matrix need an explicit extent. +#' mat <- terra::as.matrix(r, wide = TRUE) +#' matrix_tiles <- tiling(mat, n_tiles = 4, extent = terra::ext(r)) #' } #' #' @seealso -#' \code{\link[terra]{rast}}, \code{\link[terra]{as.polygons}}, \code{\link[terra]{ext}} +#' \code{\link{radial_count}}, \code{\link{benchmark}}, +#' \code{\link[terra]{rast}}, \code{\link[terra]{as.polygons}}, +#' \code{\link[terra]{ext}} #' #' @export tiling <- function( diff --git a/R/variable_importance.R b/R/variable_importance.R new file mode 100644 index 0000000..d68331d --- /dev/null +++ b/R/variable_importance.R @@ -0,0 +1,512 @@ +#' Per-variable departure attribution for HCAS benchmarking +#' +#' Quantifies, for each target location, how much each remote-sensing (RS) +#' variable contributes to the observed departure from its locally selected +#' reference sites, standardised by how tightly those references agree among +#' themselves on that variable. It answers which RS variables drive habitat +#' condition variation, conditional on the local intact ecological distribution, +#' rather than treating importance as a global property of a variable. +#' +#' @details +#' \code{variable_importance()} reuses the same non-temporal three-stage +#' reference selection as \code{\link{benchmark}}: candidates are restricted to +#' those within \code{radius_km}, the \code{k1} nearest in predicted RS +#' space (with an optional XY penalty) are retained, and the \code{k2} with +#' the highest reference-density probability are kept. Each retained reference +#' is weighted with the same selected distance kernel on predicted RS +#' distance used by \code{benchmark()}, so the diagnostic reports on the +#' reference set and weights that benchmarking actually uses. With +#' \code{boost} (the default is \code{k2}), the kernel weight of the retained +#' reference with the highest reference-density probability is multiplied by +#' that factor before signal and noise are computed. Set \code{boost = NULL} or +#' \code{boost = NA} to use the ordinary unboosted kernel weights. +#' +#' For each RS variable \eqn{v} the importance at a target cell is a +#' signal-to-noise ratio +#' +#' \deqn{importance_v = \frac{signal_v}{noise_v + \epsilon}} +#' +#' where, with normalised distance-kernel weights \eqn{w_k} that sum to \eqn{W}, +#' +#' \deqn{signal_v = \frac{1}{W} \sum_k w_k\, |obs^{target}_v - obs^{ref,k}_v|} +#' \deqn{noise_v = \frac{1}{W^2} \sum_k \sum_l w_k w_l\, |obs^{ref,k}_v - obs^{ref,l}_v|} +#' +#' The signal is the weighted mean absolute departure of the target from its +#' references on variable \eqn{v}; the noise is the weighted mean absolute +#' difference among the references themselves (a distance-weighted Gini mean +#' difference). Both quantities stay in the L1 geometry of the engine, +#' so the per-variable signals sum to the weighted total observed departure that +#' the reference-density lookup consumes. +#' +#' This is an attribution of the \emph{observed departure} that drives habitat +#' condition, not a sensitivity decomposition of the condition score itself: the +#' departure enters condition non-linearly through the reference-density surface. +#' Importances are univariate and so do not de-correlate variables; collinear RS +#' variables each receive their marginal share. The local-maximum (LDC) +#' component of condition is intentionally excluded, so the metric corresponds to +#' the distance-weighted-mean component of \code{benchmark()}. +#' +#' \code{epsilon} guards the denominator against variables on which the +#' references agree almost perfectly (near-zero noise). Raise it to dampen +#' unstable ratios for low-dispersion variables. Because the noise estimate uses +#' only \code{k2} references, it is itself noisy when the distance weights are +#' concentrated on a single reference; interpret single-reference cells (where +#' noise is zero) with care. +#' +#' Predicted and observed RS variables should be centred and scaled consistently +#' before use, exactly as for \code{\link{benchmark}}, so that per-variable +#' departures and dispersions are comparable across variables. +#' +#' The \code{output} argument selects what each layer/column holds: +#' \describe{ +#' \item{\code{"importance"}}{the signal-to-noise ratio above (default). Best +#' for ranking and for mapping where a variable is anomalous relative to its +#' local references. It is open-ended (not normalised) and inherits the +#' \code{epsilon} sensitivity for low-dispersion variables.} +#' \item{\code{"signal"}}{the raw weighted absolute departure \eqn{signal_v}. +#' Per cell these sum to the distance-weighted total observed departure that the +#' reference-density lookup consumes, so they have a conserved total and are +#' unaffected by \code{epsilon}.} +#' \item{\code{"share"}}{the per-cell departure partition +#' \eqn{signal_v / \sum_u signal_u}. Each cell's variables sum to one (mutually +#' exclusive), giving "variable \eqn{v} accounts for this fraction of the +#' observed departure here". Cells whose total departure is zero are +#' \code{NaN}. This is the most direct percent-attribution map.} +#' } +#' +#' Use \code{\link{aggregate_importance}} to summarise per-cell output across the +#' landscape into a robust ranking (median) and an average attribution (mean of +#' per-cell relative shares). +#' +#' @inheritParams benchmark +#' @param data A matrix, data.frame, or \pkg{terra} \code{SpatRaster} of target +#' RS data. Matrix and data.frame inputs must be organised as \code{x}, +#' \code{y}, predicted RS variables, then observed RS variables. Raster inputs +#' must contain predicted RS layers followed by observed RS layers in the same +#' variable order. +#' @param samples A matrix or data.frame of reference sites as \code{x}, +#' \code{y}, predicted RS variables, then observed RS variables in the same +#' order as \code{data}. For raster \code{data} it may instead be a two-column +#' coordinate table, in which case raster values are extracted. Temporal sample +#' lists are not supported. +#' @param lambda Positive numeric. Distance-scale bandwidth for the selected +#' \code{kernel} applied to retained-reference predicted RS L1 distances. See +#' \code{\link{benchmark}} for the kernel-specific parameterisation. +#' @param epsilon Numeric, non-negative. Floor added to the noise term to avoid +#' division by (near-)zero reference dispersion. Used only when +#' \code{output = "importance"}. +#' @param output Character. One of \code{"importance"} (default; per-variable +#' signal-to-noise ratio), \code{"signal"} (raw weighted departure +#' contribution), or \code{"share"} (per-cell departure partition summing to one +#' across variables). See Details. +#' @param boost \code{NULL}, \code{NA}, or one positive finite numeric factor. +#' The default \code{k2} multiplies the kernel weight of the +#' highest-probability retained reference by \code{k2} before signal and noise +#' are computed. Use \code{NULL} or \code{NA} for ordinary unboosted kernel +#' weights. +#' +#' @return When \code{data} is a matrix, a numeric matrix with one row per +#' target cell and one column per RS variable. When \code{data} is a raster, a +#' \pkg{terra} \code{SpatRaster} with one layer per RS variable. Cells with +#' missing observed values or no usable references are \code{NaN}; with +#' \code{output = "share"}, cells with zero total departure are also \code{NaN}. +#' +#' @seealso \code{\link{benchmark}}, \code{\link{reference_use}}, and +#' \code{\link{aggregate_importance}} +#' @export +#' +#' @examples +#' target <- matrix( +#' c( +#' 0, 0, 0.1, 0.2, 0.1, 0.2, +#' 1, 1, 0.8, 0.7, 0.9, 0.6 +#' ), +#' ncol = 6, +#' byrow = TRUE +#' ) +#' samples <- matrix( +#' c( +#' 0, 0, 0.1, 0.2, 0.12, 0.18, +#' 1, 1, 0.8, 0.7, 0.85, 0.72, +#' 0, 1, 0.4, 0.5, 0.42, 0.55 +#' ), +#' ncol = 6, +#' byrow = TRUE +#' ) +#' ref <- matrix(1, nrow = 20, ncol = 20) +#' +#' variable_importance( +#' target, +#' samples, +#' ref, +#' radius_km = 1000, +#' k1 = 3, +#' k2 = 2, +#' bin_width = 0.1, +#' interpolate = FALSE, +#' exclude_slef = FALSE, +#' num_threads = 1 +#' ) +variable_importance <- function( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0.0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + lambda = 1.0, + epsilon = 1e-6, + output = c("importance", "signal", "share"), + exclude_slef = TRUE, + drop_features = NULL, + num_threads = -1, + kernel = c("Gaussian", "Cauchy"), + boost = k2, + ...) { + + legacy_k <- intersect(names(list(...)), c("k_pred", "k_obs")) + if (length(legacy_k)) { + stop("'k_pred' and 'k_obs' were renamed to 'k1' and 'k2'.") + } + + output <- match.arg(output) + kernel <- .check_kernel(kernel) + boost <- .check_boost(boost) + # The engine returns either the signal-to-noise importance or the raw + # per-variable signal; "share" is the per-cell normalised signal computed + # here, so the engine is asked for "signal" in that case. + cpp_output <- if (output == "share") "signal" else output + + if (k1 < k2) { + stop("'k2' must be less than or equal to 'k1'.") + } + # Reject benchmark()-only arguments that would otherwise be silently passed + # through '...' to terra::interpolate and on to the C++ engine, which does + # not accept them. 'confidence' is the most common copy-paste mistake. + benchmark_only <- intersect( + names(list(...)), + c("confidence", "make_su", "temporal_correct", + "assessment_year", "temporal_sigma") + ) + if (length(benchmark_only)) { + stop( + "variable_importance() does not accept benchmark() argument(s): ", + paste(benchmark_only, collapse = ", "), ".\n", + " In particular, 'confidence' has no effect here: the metric ", + "attributes the distance-weighted-mean departure and deliberately ", + "excludes the LDC/confidence component. Remove it from the call." + ) + } + if (length(lambda) != 1L || !is.finite(lambda) || lambda <= 0) { + stop("'lambda' must be one finite number greater than zero.") + } + if (length(epsilon) != 1L || !is.finite(epsilon) || epsilon < 0) { + stop("'epsilon' must be one finite, non-negative number.") + } + if (is.list(samples) && !.is_mat(samples)) { + stop("Temporal sample lists are not supported by 'variable_importance()'.") + } + samples <- if (.is_mat(samples)) { + .check_mat(samples) + } else { + stop("'samples' must be a matrix or convertible to one.") + } + + ref_density <- if (.is_mat(ref_density)) { + .check_mat(ref_density) + } else { + stop("'ref_density' must be a matrix or convertible to one.") + } + if (nrow(ref_density) != ncol(ref_density)) { + warning("Reference density dimensions are not equal!\n") + } + + if (methods::is(ref_density, "reference_density")) { + if (is.null(bin_width)) { + bin_width <- attributes(ref_density)$bin.width + } else if (bin_width != attributes(ref_density)$bin.width) { + warning("Provided 'bin_width' differs from reference density attribute.") + } + + if (is.null(offset)) { + offset <- attributes(ref_density)$offset + } else if (offset != attributes(ref_density)$offset) { + warning("Provided 'offset' differs from reference density attribute.") + } + } + if (is.null(bin_width)) { + stop("'bin_width' must be supplied when 'ref_density' has no bin-width attribute.") + } + + if (interpolate) { + ref_density <- terra::as.matrix( + terra::disagg( + terra::rast(.check_mat(unclass(ref_density), name = "ref_density")), + fact = 2, + method = "bilinear" + ), + wide = TRUE + ) + bin_width <- bin_width / 2 + offset <- offset * 2 + } + bin_num <- min(dim(ref_density)) + + if (.is_mat(data)) { + data <- .check_mat(data) + if (ncol(samples) != ncol(data)) { + stop("Samples must include all target values and match the columns in 'data'.") + } + + keep_features <- .keep_rs_features( + drop_features, + .num_rs_vars_mat(samples, "samples") + ) + samples <- .subset_rs_mat(samples, keep_features) + data <- .subset_rs_mat(data, keep_features) + var_names <- .rs_var_names(data, keep_features) + + result <- variable_importance_cpp( + target_vals = data, + sample_vals = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + geographic = .is_lonlat(data), + radius_km = radius_km, + k_env = k1, + k_rs = k2, + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + lambda = lambda, + epsilon = epsilon, + output = cpp_output, + exclude_slef = exclude_slef, + num_threads = num_threads, + kernel = kernel, + boost = boost + ) + if (output == "share") { + result <- .importance_shares(result) + } + colnames(result) <- var_names + return(result) + + } else if (.is_rast(data)) { + .check_pkgs("terra") + data <- .check_rast(data) + if (terra::nlyr(data) %% 2L) { + stop("'data' must contain matching predicted and observed RS layers.") + } + + if (ncol(samples) == 2L) { + cat("Extracting sample values...\n") + samples <- cbind( + samples, + as.matrix(terra::extract(data, samples, ID = FALSE)) + ) + } else if ((ncol(samples) - 2L) != terra::nlyr(data)) { + stop("Sample feature count does not match number of raster layers.") + } + + keep_features <- .keep_rs_features( + drop_features, + terra::nlyr(data) / 2L + ) + samples <- .subset_rs_mat(samples, keep_features) + data <- .subset_rs_rast(data, keep_features) + var_names <- .rs_var_names_rast(data) + + out_rast <- terra::interpolate( + object = data, + model = list(), + fun = .variable_importance_predict, + var_names = var_names, + sample_vals = samples, + ref_density = ref_density, + xy_stats = xy_stats, + xy_penalty = xy_penalty, + radius_km = radius_km, + geographic = .is_lonlat(data), + bin_width = bin_width, + bin_num = bin_num, + offset = offset, + k_env = k1, + k_rs = k2, + lambda = lambda, + epsilon = epsilon, + output = cpp_output, + exclude_slef = exclude_slef, + num_threads = num_threads, + kernel = kernel, + boost = boost, + ... + ) + if (output == "share") { + total <- terra::app(out_rast, "sum") + total <- terra::ifel(total == 0, NA, total) + out_rast <- out_rast / total + } + names(out_rast) <- var_names + return(out_rast) + + } else { + stop("'data' must be a raster, matrix, or convertible object.") + } +} + + +# terra::interpolate prediction helper: returns one column per RS variable. +# Surfaces the real error rather than silently NA-ing the block: the C++ engine +# returns NaN rows for empty/missing cells itself, so any thrown error is a +# structural problem that would affect every block and must abort the run. +.variable_importance_predict <- function(model, newdata, var_names, ...) { + dat <- as.matrix(newdata) + + out <- tryCatch( + variable_importance_cpp(target_vals = dat, ...), + error = function(cond) { + stop( + "variable_importance() failed while evaluating a raster block: ", + conditionMessage(cond), + call. = FALSE + ) + } + ) + + colnames(out) <- var_names + out +} + + +# observed RS variable names from a x,y,pred...,obs... matrix +.rs_var_names <- function(x, keep_features) { + n_vars <- (ncol(x) - 2L) / 2L + obs_names <- colnames(x)[(2L + n_vars + 1L):ncol(x)] + if (is.null(obs_names) || any(!nzchar(obs_names))) { + return(paste0("var", keep_features)) + } + obs_names +} + + +# observed RS variable names from a pred...,obs... raster +.rs_var_names_rast <- function(x) { + n_vars <- terra::nlyr(x) / 2L + obs_names <- names(x)[(n_vars + 1L):terra::nlyr(x)] + if (is.null(obs_names) || any(!nzchar(obs_names))) { + return(paste0("var", seq_len(n_vars))) + } + obs_names +} + + +# per-cell normalisation of a per-variable signal matrix into shares summing to +# one; rows whose total signal is zero or non-finite become NA +.importance_shares <- function(x) { + rs <- rowSums(x) + rs[!is.finite(rs) | rs == 0] <- NA_real_ + x / rs +} + + +#' Summarise per-variable importance across the landscape +#' +#' Aggregates the per-cell output of \code{\link{variable_importance}} into a +#' landscape-level characterisation of which RS variables most drive habitat +#' condition variation. +#' +#' @details +#' Two complementary summaries are returned for each variable. The +#' \code{median} importance gives a robust ranking that is insensitive to a +#' minority of cells with extreme ratios. The \code{mean_share} is the mean over +#' cells of the variable's relative share of importance, +#' \eqn{importance_v / \sum_u importance_u}, expressed as a proportion; multiply +#' by 100 for an average percent attribution. The two can disagree when a +#' variable is usually modest but occasionally dominant, so reporting both is +#' recommended. +#' +#' Shares are computed only over cells where every variable's importance is +#' finite and the row sum is positive. Because importances are conditional on +#' overlapping local reference sets, nearby cells are not independent draws; +#' treat the aggregate as a description of the landscape rather than a basis for +#' naive inferential standard errors. Where the premise that importance is local +#' matters, aggregate within ecologically meaningful strata (for example region +#' or vegetation class) instead of a single global summary. +#' +#' @param x A numeric matrix (one row per cell, one column per variable) as +#' returned by \code{\link{variable_importance}} for matrix input, or a +#' \pkg{terra} \code{SpatRaster} as returned for raster input. Raster values are +#' read into memory, so summarise per tile for very large analyses. +#' +#' @return A data.frame with one row per variable, ordered by descending +#' \code{median}, containing: +#' \itemize{ +#' \item \code{variable}: variable name. +#' \item \code{median}: median per-cell importance (robust ranking). +#' \item \code{mean_share}: mean per-cell relative share (average attribution). +#' \item \code{rank}: 1-based rank by \code{median}. +#' \item \code{n}: number of cells contributing to \code{mean_share}. +#' } +#' +#' @seealso \code{\link{variable_importance}} +#' @export +#' +#' @examples +#' imp <- matrix( +#' c( +#' 0.8, 0.2, 0.1, +#' 0.6, 0.3, 0.1, +#' 0.7, 0.2, 0.2 +#' ), +#' ncol = 3, +#' byrow = TRUE, +#' dimnames = list(NULL, c("a", "b", "c")) +#' ) +#' aggregate_importance(imp) +aggregate_importance <- function(x) { + if (inherits(x, "SpatRaster")) { + var_names <- names(x) + x <- terra::values(x, mat = TRUE) + } else if (.is_mat(x)) { + x <- .check_mat(x) + var_names <- colnames(x) + } else { + stop("'x' must be a matrix or SpatRaster of per-cell importances.") + } + + if (is.null(var_names) || any(!nzchar(var_names))) { + var_names <- paste0("var", seq_len(ncol(x))) + } + + med <- apply(x, 2L, stats::median, na.rm = TRUE) + + row_sums <- rowSums(x) + valid <- is.finite(row_sums) & row_sums > 0 + if (any(valid)) { + shares <- x[valid, , drop = FALSE] / row_sums[valid] + mean_share <- colMeans(shares, na.rm = TRUE) + n_valid <- sum(valid) + } else { + mean_share <- rep(NA_real_, ncol(x)) + n_valid <- 0L + } + + out <- data.frame( + variable = var_names, + median = as.numeric(med), + mean_share = as.numeric(mean_share), + n = n_valid, + stringsAsFactors = FALSE + ) + out <- out[order(-out$median), , drop = FALSE] + out$rank <- seq_len(nrow(out)) + rownames(out) <- NULL + out[, c("variable", "median", "mean_share", "rank", "n")] +} diff --git a/README.md b/README.md index 360377d..e508498 100644 --- a/README.md +++ b/README.md @@ -3,6 +3,7 @@ [![R build status](https://github.com/csiro/ClassicHCAS/workflows/R-CMD-check/badge.svg)](https://github.com/csiro/ClassicHCAS/actions) ![maintenance-status](https://img.shields.io/badge/maintenance-active-brightgreen.svg) +[![GitHub](https://img.shields.io/github/r-package/v/csiro/ClassicHCAS/master?label=GitHub)](https://github.com/csiro/ClassicHCAS) ## What is ClassicHCAS? diff --git a/man/ClassicHCAS.Rd b/man/ClassicHCAS.Rd index 5549ee8..94467b5 100644 --- a/man/ClassicHCAS.Rd +++ b/man/ClassicHCAS.Rd @@ -4,17 +4,55 @@ \alias{ClassicHCAS} \title{ClassicHCAS: The Classic Habitat Condition Assessment System (HCAS)} \description{ -The HCAS evaluates habitat condition by comparing observed and predicted -remote sensing (RS) variables using reference ecosystem samples. -It integrates multiple RS data layers to provide a comprehensive assessment of -habitat quality. +ClassicHCAS implements the core Habitat Condition Assessment System workflow +for estimating habitat condition from Earth observation and environmental +data. HCAS compares observed remote-sensing (RS) variables with predicted +reference-condition RS variables. Locations whose observed signal is close to +the expected reference signal, relative to high-integrity reference samples, +receive higher condition scores. +} +\details{ +The package is data-agnostic: users supply their own observed RS variables, +predicted reference-condition RS variables, and reference or benchmark samples. +The expected RS variables are usually produced outside this package by +modelling high-integrity reference ecosystems as a function of abiotic +environmental covariates such as climate, soils, water availability, and +landform. + +The main ClassicHCAS workflow is: +\enumerate{ + \item Use \code{\link{ref_density}} to build a reference density surface + from pairwise predicted and observed RS distances among reference samples. + \item Use \code{\link{normalise}} to trim and normalise that surface so it + can be used as a probability surface during benchmarking. + \item Use \code{\link{benchmark}} to estimate unscaled condition for target + locations or rasters by comparing them with nearby, environmentally similar + reference samples. + \item Use \code{\link{calibrate}} to transform unscaled condition values to + an interpretable 0-1 condition scale. +} + +Operational helpers include \code{\link{radial_count}}, for mapping local +reference-sample support, \code{\link{tiling}}, for splitting large raster +jobs into balanced processing tiles, and \code{\link{palettes}}, for package +plotting colours. } \references{ -The Habitat Condition Assessment System (HCAS)... +Harwood, T. D., Donohue, R. J., Williams, K. J., Ferrier, S., +McVicar, T. R., Newell, G., and White, M. (2016). Habitat Condition +Assessment System: A new way to assess the condition of natural habitats for +terrestrial biodiversity across whole regions using remote sensing data. +\emph{Methods in Ecology and Evolution}, 7(9), 1050-1059. + +Williams, K. J., Harwood, T. D., Lehmann, E. A., Ware, C., Lyon, P., +Bakar, S., Schmidt, R. K., Mokany, K., Van Niel, T. G., Richards, A. E., +Dickson, F., McVicar, R., and Ferrier, S. (2021). Habitat Condition +Assessment System (HCAS version 2.1). CSIRO Publishing. } \seealso{ -\code{\link{benchmark}} and \code{\link{ref_density}}. +\code{\link{ref_density}}, \code{\link{normalise}}, +\code{\link{benchmark}}, and \code{\link{calibrate}}. } \author{ -Roozbeh Valavi, Chris Ware, Eric Lehmann, Kristen Williams, Mike Birchall, Simon Collings, Simon Ferrier, and Tom Harwood +Roozbeh Valavi, Kristen Williams, Eric Lehmann, Simon Collings, Tom Harwood, Mike Birchall, and Simon Ferrier } diff --git a/man/aggregate_importance.Rd b/man/aggregate_importance.Rd new file mode 100644 index 0000000..cc22c6f --- /dev/null +++ b/man/aggregate_importance.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/variable_importance.R +\name{aggregate_importance} +\alias{aggregate_importance} +\title{Summarise per-variable importance across the landscape} +\usage{ +aggregate_importance(x) +} +\arguments{ +\item{x}{A numeric matrix (one row per cell, one column per variable) as +returned by \code{\link{variable_importance}} for matrix input, or a +\pkg{terra} \code{SpatRaster} as returned for raster input. Raster values are +read into memory, so summarise per tile for very large analyses.} +} +\value{ +A data.frame with one row per variable, ordered by descending +\code{median}, containing: +\itemize{ + \item \code{variable}: variable name. + \item \code{median}: median per-cell importance (robust ranking). + \item \code{mean_share}: mean per-cell relative share (average attribution). + \item \code{rank}: 1-based rank by \code{median}. + \item \code{n}: number of cells contributing to \code{mean_share}. +} +} +\description{ +Aggregates the per-cell output of \code{\link{variable_importance}} into a +landscape-level characterisation of which RS variables most drive habitat +condition variation. +} +\details{ +Two complementary summaries are returned for each variable. The +\code{median} importance gives a robust ranking that is insensitive to a +minority of cells with extreme ratios. The \code{mean_share} is the mean over +cells of the variable's relative share of importance, +\eqn{importance_v / \sum_u importance_u}, expressed as a proportion; multiply +by 100 for an average percent attribution. The two can disagree when a +variable is usually modest but occasionally dominant, so reporting both is +recommended. + +Shares are computed only over cells where every variable's importance is +finite and the row sum is positive. Because importances are conditional on +overlapping local reference sets, nearby cells are not independent draws; +treat the aggregate as a description of the landscape rather than a basis for +naive inferential standard errors. Where the premise that importance is local +matters, aggregate within ecologically meaningful strata (for example region +or vegetation class) instead of a single global summary. +} +\examples{ +imp <- matrix( + c( + 0.8, 0.2, 0.1, + 0.6, 0.3, 0.1, + 0.7, 0.2, 0.2 + ), + ncol = 3, + byrow = TRUE, + dimnames = list(NULL, c("a", "b", "c")) +) +aggregate_importance(imp) +} +\seealso{ +\code{\link{variable_importance}} +} diff --git a/man/benchmark.Rd b/man/benchmark.Rd index f0e556a..71ab5b9 100644 --- a/man/benchmark.Rd +++ b/man/benchmark.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/benchmark.R \name{benchmark} \alias{benchmark} -\title{Condition benchmarking of target points} +\title{Benchmark target locations against HCAS reference condition} \usage{ benchmark( data, @@ -11,128 +11,252 @@ benchmark( xy_stats = c(0, 0, 1, 1), xy_penalty = 0, radius_km = 200, - k_pred = 50, - k_obs = 20, + k1 = 70, + k2 = 10, bin_width = NULL, interpolate = TRUE, offset = 0, + kernel = c("Gaussian", "Cauchy"), + lambda = 1, confidence = 0.5, - lambda = 2, exclude_slef = TRUE, drop_features = NULL, + assessment_year = NULL, + temporal_sigma = NULL, make_su = FALSE, num_threads = -1, + boost = k2, ... ) } \arguments{ -\item{data}{A matrix, SpatRaster (from the \pkg{terra} package), or data.frame containing the input data. -The data \strong{must} be organised in the following order: \strong{x}, \strong{y}, \strong{predicted-RS}, -\strong{observed-RS} variables. If using a SpatRaster, the \strong{x} and \strong{y} are not required. -If using a matrix or data.frame, ensure that the variables are in the -correct order. For more see the details section.} +\item{data}{A matrix, data.frame, or \pkg{terra} \code{SpatRaster} containing +input RS data. Matrix and data.frame inputs must be organised as \code{x}, +\code{y}, predicted RS variables, then observed RS variables. Raster inputs +must contain predicted RS layers followed by observed RS layers in the same +variable order;} -\item{samples}{A matrix or data.frame containing x, y, predicted-RS, and observed-RS values -(in that specific order) for benchmark samples (also known as reference sites). If the -\code{data} argument is a SpatRaster, you can provide only the x and y coordinates of the -benchmark samples. In this case, the corresponding values will be extracted from the raster -layers. Consider extra time for sample value extraction in this case.} +\item{samples}{Benchmark/reference sample data. Normally this is a matrix or +data.frame containing \code{x}, \code{y}, predicted RS variables, then +observed RS variables in the same order as \code{data}. For raster +\code{data}, it can instead contain only two coordinate columns, in which +case raster values are extracted. When \code{temporal_sigma} is specified, +supply a named list of full sample matrices, one per year, with numeric year names. +All matrices must contain the same sites, row order, XY coordinates, +predicted values, and feature order; only observed values may vary.} -\item{ref_density}{A matrix or \strong{reference_density} object of normalised HCAS -reference density (see \code{\link{ref_density}} and \code{\link{normalise}}).} +\item{ref_density}{A normalised \code{reference_density} object or matrix +produced by \code{\link{normalise}}.} -\item{xy_stats}{A vector, mean and standard deviation of coordinates for centre and -scaling the coordinate to use as a penalty. The order should be: mean(x), mean(y), sd(x), sd(y). -This argument helps achieving consistent results when running benchmarking over multiple tiles.} +\item{xy_stats}{Numeric vector of length four used to scale coordinates when +\code{xy_penalty > 0}: \code{mean(x)}, \code{mean(y)}, \code{sd(x)}, +\code{sd(y)}. Use the same values across tiles to keep tiled benchmarking +consistent.} -\item{xy_penalty}{Numeric. The spatial distance penalty value for selecting benchmark points. -The higher the value the more penalise the distant location will be. The value 0 means no penalty.} +\item{xy_penalty}{Numeric. Weight applied to scaled coordinates when selecting +the \code{k1} most similar benchmark samples. \code{0} disables the +spatial penalty.} -\item{radius_km}{Numeric. Search radius in kilometers for considering benchmark samples. -See details section for more information on distance calculation.} +\item{radius_km}{Numeric. Search radius, in kilometres, for candidate +benchmark samples.} -\item{k_pred}{Integer. Number of nearest predicted RS samples to take.} +\item{k1}{Integer. First-stage filter size: the number of nearest samples to +retain after the predicted RS distance search.} -\item{k_obs}{Integer. Number of nearest observed RS sample to takes.} +\item{k2}{Integer. Second-stage filter size: the number of high-probability +samples to retain from the reference density query. Must be less than or +equal to \code{k1}.} -\item{bin_width}{Numeric. Specifies the bin width of the reference density. If \code{ref_density} is -a \strong{reference_density} object, this value can be read from its attributes and may be left \code{NULL}. -The bin width must be consistent between the reference density creation and the benchmarking step to -ensure condition is accurately calculated.} +\item{bin_width}{Numeric. Bin width used to create and normalise +\code{ref_density}. If \code{ref_density} is a \code{reference_density} +object, this value is read from its \code{bin.width} attribute when +\code{bin_width = NULL}.} -\item{interpolate}{Logical. Whether to interpolate the reference density for a smoother result.} +\item{interpolate}{Logical. If \code{TRUE}, bilinearly interpolates the +reference density surface before benchmarking for smoother lookup.} -\item{offset}{Integer. Specifies the number of reference density bins that were ignored during -normalisation (see \code{\link{normalise}}). If \code{ref_density} is a \strong{reference_density} object, -this value can be read from its attributes and may be set \code{NULL}. Similar to bin-width, -the \code{offset} must be consistent between the reference density normalisation and the benchmarking -step to ensure condition is accurately calculated.} +\item{offset}{Integer. Number of reference-density bins ignored during +normalisation. If \code{ref_density} is a \code{reference_density} object, +this value is read from its \code{offset} attribute when \code{offset = NULL}.} -\item{confidence}{Numeric. The confidence value for LDC methods. See details below..} +\item{kernel}{Character. Distance kernel applied to retained-reference +predicted RS L1 distances: \code{"Gaussian"} (default) or \code{"Cauchy"}. +Lower-case \code{"gaussian"} and \code{"cauchy"} are also accepted.} -\item{lambda}{Numeric. The lambda param for LDC Cauchy weighting...} +\item{lambda}{Positive numeric. Distance-scale bandwidth for the selected +\code{kernel}. Both kernels treat \code{lambda} in predicted RS L1 distance +units: the Gaussian kernel uses \code{exp(-(distance / lambda)^2)} and the +Cauchy kernel uses \code{1 / (1 + (distance / lambda)^2)}.} -\item{exclude_slef}{Logical. To exclude a benchmark point from assessing itself.} +\item{confidence}{Numeric between 0 and 1. Weight given to the selected +maximum probability component relative to the distance-weighted mean +probability when computing raw condition. Ignored when \code{boost} is not +\code{NULL} or \code{NA}; the default is \code{boost = k2}.} -\item{drop_features}{Integer vector. Completely remove RS variables from the benchmarking process. -Positions are 1-based within the RS feature set, not the full input column order. For -consistency, it is recommended to exclude the same variables used in the reference density step; unless -you have a specific reason not to.} +\item{exclude_slef}{Logical. If \code{TRUE}, exclude samples whose predicted +RS distance is less than one bin width, preventing a benchmark point from +assessing itself. The argument name preserves the existing API spelling.} -\item{make_su}{Logical. To make the uncertainty map or not.} +\item{drop_features}{Optional integer vector of RS variable positions to +exclude from benchmarking. Positions are 1-based within the RS feature set, +not within the full input column order. Use the same exclusion used in +\code{\link{ref_density}} unless there is a deliberate reason not to.} -\item{num_threads}{Integer. Specifies the number of CPU threads to be used for processing. A value -below 1 indicates that all available threads will be utilized (default). Refer to the details section for -more information.} +\item{assessment_year}{Numeric. Year being assessed and the centre of the +experimental Gaussian temporal kernel. Required when +\code{temporal_sigma} is specified.} -\item{...}{Additional arguments for writing raster outputs e.g. \code{filename}, -\code{overwrite}, and \code{wopt} from terra \code{\link[terra]{predict}}.} +\item{temporal_sigma}{Positive numeric or \code{NULL}. Standard deviation of +the experimental Gaussian temporal kernel, in the same units as the +temporal sample names. Supplying a value enables an exploratory temporal +mode that has not been validated as a drop-in replacement for standard +non-temporal benchmarking; \code{NULL} or \code{NA} disables it. When +enabled, the selected reference-density probability is multiplied by the +selected year's temporal weight before \code{k2} selection and condition +estimation.} + +\item{make_su}{Logical. If \code{TRUE}, return both raw condition and +\code{su}, the log of the total distance-weight sum.} + +\item{num_threads}{Integer. Number of CPU threads to use. Values below 1 use +all available OpenMP threads.} + +\item{boost}{\code{NULL}, \code{NA}, or one positive finite numeric factor. +The default \code{k2} multiplies the kernel weight of the +highest-probability retained site by \code{k2} and returns the resulting weighted +mean instead of the LDC blend. \code{confidence} is ignored in this mode. +Use \code{NULL} or \code{NA} for the unboosted LDC blend.} + +\item{...}{Additional arguments passed to \code{\link[terra]{interpolate}} +when benchmarking raster outputs, such as \code{filename}, \code{overwrite}, +or \code{wopt}.} } \value{ -A matrix or SpatRaster, depending on the inputs. +A matrix or \pkg{terra} \code{SpatRaster}, depending on the inputs. } \description{ -The HCAS (Habitat Condition Assessment System) benchmarking function evaluates habitat -condition by comparing observed and predicted remote sensing (RS) variables. It integrates -multiple RS data layers to provide a comprehensive assessment of habitat quality and changes -over time. This function is designed to help researchers and conservationists quantify the -impacts of environmental changes and management interventions on habitat condition. +Estimates raw HCAS habitat condition by comparing target locations with +nearby, environmentally similar reference samples and a normalised reference +density surface. } \details{ -Ensure that the order of remote sensing variables is consistent between predicted and observed inputs -(for both raster and matrix formats). The RS variable values must be centered and scaled -prior to prediction. Failure to do so may result in variables with larger ranges having -disproportionate influence in the multi-dimensional distance calculations. +In HCAS, predicted RS variables represent the expected signal under reference +condition and observed RS variables represent the actual Earth observation +signal. \code{benchmark()} asks whether the observed departure from expected +reference condition is typical of high-integrity reference ecosystems. The +output is an unscaled relative condition value; use \code{\link{calibrate}} to +map it to a 0-1 condition scale. + +\strong{Experimental temporal mode:} the mechanism controlled by +\code{temporal_sigma} is exploratory, is off by default, and should not be +treated as equivalent to the standard non-temporal benchmark without +independent validation. Standard benchmarking remains non-temporal unless a +finite \code{temporal_sigma} is supplied. + +The function uses a two-stage reference-sample selection process for each +target location: +\enumerate{ + \item Candidate benchmark samples are restricted to those within + \code{radius_km}. + \item From those candidates, up to \code{k1} samples with the smallest + predicted RS distance are retained. If \code{xy_penalty > 0}, scaled + geographic coordinates are included in this distance so distant samples are + penalised even when they are spectrally similar. + \item The target and retained samples are queried against + \code{ref_density} using predicted-distance and observed-distance bins. + If the experimental temporal mode is enabled, each retained site is queried + once per reference year, and a Gaussian year weight selects and weights the + site's most relevant year. + \item Up to \code{k2} samples with the highest reference-density + probability are retained for condition estimation. +} -This function uses an integer-based distance checks for fast radius searches on either -geographic or projected coordinates. In geographic mode, coordinates are -stored in micro-degrees (degree * 1000_000) and the distance is approximated by: +The retained probability values are combined using the distance kernel +selected by \code{kernel}. The default Gaussian kernel is +\code{exp(-(distance / lambda)^2)}. The optional Cauchy kernel is +\code{1 / (1 + (distance / lambda)^2)}, the standard Cauchy shape +normalised to weight one at zero. - distance² ≈ (dlat)² + (dlon × cos(lat₁))² +By default, \code{boost = k2} replaces the LDC blend with a boosted weighted +mean. The kernel weight of the retained site with the highest unweighted +probability is multiplied by \code{boost}, and condition is the weighted mean +using that adjusted weight. In this mode, \code{confidence} does not affect +condition. Set \code{boost = NULL} or \code{boost = NA} to use the original +LDC blend, where \code{confidence} controls how strongly the raw condition +value relies on the maximum unweighted probability contribution compared +with the distance-weighted mean probability. A value of \code{boost = 1} +gives the ordinary kernel-weighted mean. If +\code{make_su = TRUE}, the result also includes \code{su}, the log of the +original, unboosted total distance-weight sum, which is a support diagnostic +rather than a calibrated confidence interval. -where cos(lat₁) is derived from the query latitude. This avoids floating- -point overhead and provides substantial performance gains but introduces -distortion at larger distances. For applications requiring higher accuracy, -especially beyond regional scales (more than several 100s of kilometers in \code{radius_km}), -use a projected coordinate system so distances in meters can be evaluated directly. +Matrix and data.frame inputs must be ordered as \code{x}, \code{y}, predicted +RS variables, then observed RS variables. Raster inputs must contain predicted +RS layers followed by observed RS layers in the same variable order. The +sample matrix can either contain only \code{x} and \code{y} coordinates, in +which case values are extracted from a raster \code{data} object, or the full +\code{x}, \code{y}, predicted RS, observed RS table. Predicted and observed +variables should be centred and scaled consistently before benchmarking. -Ensure that \href{https://en.wikipedia.org/wiki/OpenMP}{OpenMP} is installed on your system -to take advantage of parallel processing and accelerate computations. While most systems -include OpenMP by default, you may need to load the appropriate module if you're using an HPC -system. +The most influential tuning parameters are usually \code{radius_km}, +\code{xy_penalty}, \code{k1}, \code{k2}, \code{lambda}, and +\code{boost}. Defaults were chosen for Australian HCAS applications and +should be assessed before use in other regions, data products, or ecological +contexts. When field condition data are unavailable, tuning can be guided by +whether scores discriminate among independent land-use or disturbance classes +in the expected order. -\strong{Note for macOS users:} Install OpenMP via Homebrew with \code{brew install libomp} -before installing this package. +In geographic coordinates, radius searches use a fast integer approximation. +Coordinates are stored in micro-degrees (\code{degree * 1000000}) and distance +is approximated by: -Note that the default parameters are tailored for Australia and may not be suitable for other -regions. +\deqn{distance^2 \approx (\Delta \mathrm{lat})^2 + (\Delta \mathrm{lon} \times \cos(\mathrm{lat}_1))^2}{distance^2 ~= (Delta lat)^2 + ((Delta lon) * cos(lat_1))^2} + +where \eqn{\Delta \mathrm{lat}}{Delta lat} and \eqn{\Delta \mathrm{lon}}{Delta lon} +are coordinate differences, and \eqn{\cos(\mathrm{lat}_1)}{cos(lat_1)} is +derived from the query latitude. This is efficient for large analyses but +introduces distortion over large areas. For high accuracy at broad regional +or continental radii, use a projected coordinate reference system so +distances can be evaluated in metres. + +\code{num_threads} uses OpenMP when available. On macOS, installing OpenMP +support with \code{brew install libomp} before installing the package may be +required for multi-threaded execution. } \examples{ \donttest{ library(ClassicHCAS) +target_data <- cbind( + x = c(0.1, 0.9), + y = c(0.1, 0.9), + rs1 = c(0.12, 0.42), + rs1 = c(0.13, 0.50) +) +sample_data <- cbind( + x = c(0.0, 0.4, 0.8, 1.2), + y = c(0.0, 0.3, 0.8, 1.1), + rs1 = c(0.10, 0.20, 0.40, 0.55), + rs1 = c(0.11, 0.18, 0.43, 0.58) +) +ref <- matrix(1, nrow = 20, ncol = 20) +class(ref) <- c("reference_density", "matrix", "array") +attr(ref, "bin.width") <- 0.1 +attr(ref, "offset") <- 0 + +benchmark( + target_data, + samples = sample_data, + ref_density = ref, + radius_km = 200, + k1 = 3, + k2 = 2, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 +) } } \seealso{ diff --git a/man/calibrate.Rd b/man/calibrate.Rd index 50a639a..2d0b3e3 100644 --- a/man/calibrate.Rd +++ b/man/calibrate.Rd @@ -2,42 +2,69 @@ % Please edit documentation in R/calibrate.R \name{calibrate} \alias{calibrate} -\title{Calibrate habitat condition output} +\title{Calibrate HCAS condition values} \usage{ -calibrate( - x, - x_values, - y_values = c(0, 0.101, 0.944, 1), - ... -) +calibrate(x, x_values, y_values = c(0, 0.101, 0.944, 1), ...) } \arguments{ -\item{x}{A SpatRaster, matrix, data.frame, or vector containing HCAS habitat condition values from -the benchmarking function (see \code{\link{benchmark}}). If \code{x} is a matrix or data.frame, -the calibration will be applied to all columns.} +\item{x}{A \pkg{terra} \code{SpatRaster}, matrix, data.frame, or vector +containing raw HCAS condition values returned by \code{\link{benchmark}}. For +matrix and data.frame inputs, calibration is applied column-wise.} -\item{x_values}{Numeric vector of un-calibrated condition values. It is recommended that \code{x_values} -cover the full range of values, including the minimum and maximum of the raw condition data.} +\item{x_values}{Numeric vector of raw, uncalibrated condition values used as +calibration knots.} -\item{y_values}{Numeric vector of calibrated target condition value corresponding to \code{x_values}.} +\item{y_values}{Numeric vector of calibrated target values corresponding to +\code{x_values}. Values should usually be between 0 and 1.} -\item{...}{Additional arguments for writing raster outputs e.g. \code{filename}, -\code{overwrite}, and \code{wopt} from terra \code{\link[terra]{predict}}.} +\item{...}{Additional arguments passed to \code{\link[terra]{app}} when +calibrating raster outputs, such as \code{filename}, \code{overwrite}, or +\code{wopt}.} } \value{ -A matrix, SpatRaster or vector, depending on the inputs. +A vector, matrix, or \pkg{terra} \code{SpatRaster}, depending on the +input. } \description{ -This function calibrates the HCAS habitat condition values and scales them between 0 and 1 -using a monotonically increasing Spline function. +Transforms raw, unscaled HCAS benchmarking values to a standard 0-1 habitat +condition scale using a monotonic spline. +} +\details{ +\code{\link{benchmark}} returns an unscaled relative condition value. The +range and distribution of that value can differ among regions, data sources, +remote-sensing summaries, and model settings. \code{calibrate()} maps those +raw values to an interpretable 0-1 scale, where 0 represents a completely +degraded or removed state and 1 represents reference or near-natural +condition. + +Calibration uses paired \code{x_values} and \code{y_values}. The +\code{x_values} are raw condition values from the benchmark output, often +including the minimum, the median of highly modified sites, the median of +reference sites, and the maximum. The \code{y_values} are the desired +calibrated condition values for those knots, supplied from empirical evidence, +expert judgement, or another accepted condition scale. A monotonic spline is +fitted through the pairs, preserving the rank order of raw condition while +enforcing a smooth increasing transformation. Values outside the 0-1 range +after transformation are clipped to 0 or 1. + +\code{x_values} and \code{y_values} must have the same length. For a stable +calibration curve, \code{x_values} should be sorted from low to high and +should span the raw condition values in \code{x}. The default +\code{y_values} assumes four calibration knots and should be replaced when a +different number of \code{x_values} is supplied. } \examples{ -\donttest{ library(ClassicHCAS) +raw_condition <- c(0.000, 0.005, 0.020, 0.035, 0.050) +calibrated <- calibrate( + raw_condition, + x_values = c(0.000, 0.005, 0.035, 0.050), + y_values = c(0.0, 0.1, 0.9, 1.0) +) -} +calibrated } \seealso{ \code{\link{benchmark}} diff --git a/man/hcas_inspection.Rd b/man/hcas_inspection.Rd new file mode 100644 index 0000000..983d1fe --- /dev/null +++ b/man/hcas_inspection.Rd @@ -0,0 +1,193 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hcas_inspection.R +\name{hcas_inspection} +\alias{hcas_inspection} +\title{Launch an interactive HCAS point-inspection tool} +\usage{ +hcas_inspection( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + confidence = 0.5, + lambda = 1, + exclude_slef = FALSE, + drop_features = NULL, + num_threads = -1, + crs = NULL, + background = NULL, + background_colors = NULL, + launch = interactive(), + kernel = c("Gaussian", "Cauchy"), + boost = k2, + ... +) +} +\arguments{ +\item{data}{A matrix, data.frame, or \pkg{terra} \code{SpatRaster} of target +locations. Matrix and data.frame inputs use a row-ID selector. Raster inputs +use coordinate inputs and extract the selected cell values.} + +\item{samples}{A matrix or data.frame of reference locations in the same +column order as \code{data}. For raster \code{data}, this may contain only +\code{x} and \code{y} coordinates, in which case raster values are extracted. +Temporal sample lists are not supported.} + +\item{ref_density}{A normalised \code{reference_density} object or matrix +produced by \code{\link{normalise}}.} + +\item{xy_stats}{Numeric vector of length four used to scale coordinates when +\code{xy_penalty > 0}: \code{mean(x)}, \code{mean(y)}, \code{sd(x)}, +\code{sd(y)}. Use the same values across tiles to keep tiled benchmarking +consistent.} + +\item{xy_penalty}{Numeric. Weight applied to scaled coordinates when selecting +the \code{k1} most similar benchmark samples. \code{0} disables the +spatial penalty.} + +\item{radius_km}{Numeric. Search radius, in kilometres, for candidate +benchmark samples.} + +\item{k1}{Integer. First-stage filter size: the number of nearest samples to +retain after the predicted RS distance search.} + +\item{k2}{Integer. Second-stage filter size: the number of high-probability +samples to retain from the reference density query. Must be less than or +equal to \code{k1}.} + +\item{bin_width}{Numeric. Bin width used to create and normalise +\code{ref_density}. If \code{ref_density} is a \code{reference_density} +object, this value is read from its \code{bin.width} attribute when +\code{bin_width = NULL}.} + +\item{interpolate}{Logical. If \code{TRUE}, bilinearly interpolates the +reference density surface before benchmarking for smoother lookup.} + +\item{offset}{Integer. Number of reference-density bins ignored during +normalisation. If \code{ref_density} is a \code{reference_density} object, +this value is read from its \code{offset} attribute when \code{offset = NULL}.} + +\item{confidence}{Numeric between 0 and 1. Weight given to the selected +maximum probability component relative to the distance-weighted mean +probability when computing raw condition. Ignored when \code{boost} is not +\code{NULL} or \code{NA}; the inspection app default is \code{boost = k2}.} + +\item{lambda}{Positive numeric. Distance-scale bandwidth for the selected +\code{kernel}. Both kernels treat \code{lambda} in predicted RS L1 distance +units: the Gaussian kernel uses \code{exp(-(distance / lambda)^2)} and the +Cauchy kernel uses \code{1 / (1 + (distance / lambda)^2)}.} + +\item{exclude_slef}{Logical. If \code{TRUE}, exclude samples whose predicted +RS distance is less than one bin width, preventing a benchmark point from +assessing itself. The argument name preserves the existing API spelling.} + +\item{drop_features}{Optional integer vector of RS variable positions to +exclude from benchmarking. Positions are 1-based within the RS feature set, +not within the full input column order. Use the same exclusion used in +\code{\link{ref_density}} unless there is a deliberate reason not to.} + +\item{num_threads}{Integer. Number of CPU threads to use. Values below 1 use +all available OpenMP threads.} + +\item{crs}{Optional coordinate reference system understood by +\code{\link[terra]{vect}}, such as \code{"EPSG:3577"}. Required for the map +when matrix/data.frame coordinates are projected or when raster coordinates +are projected and the raster has no CRS.} + +\item{background}{Optional background raster drawn beneath the sample +markers, given as a file path to a GeoTIFF or a \pkg{terra} +\code{SpatRaster}. The map renderer reads web mercator directly, so a +single-band Cloud-Optimized GeoTIFF (COG) already in \code{"EPSG:3857"} or +\code{"EPSG:4326"} is served unchanged and its internal overviews stream for +fast, overview-accelerated rendering. Any other input is reduced to its +first layer, reprojected to \code{"EPSG:3857"} when needed, and written to a +temporary COG with overviews. Requires the suggested package \pkg{leafem}.} + +\item{background_colors}{Optional character vector of colours (for example +hexadecimal codes such as \code{c("#430E59", "#CCCC66", "#184F0F")}) used as +the continuous colour ramp for \code{background}. Defaults to the +\code{"hcas"} palette from \code{\link{palettes}}. Ignored when +\code{background} is \code{NULL}.} + +\item{launch}{Logical. If \code{TRUE}, run the application with +\code{\link[shiny]{runApp}}. If \code{FALSE}, return the application object +without running it, which is useful for testing or custom deployment.} + +\item{kernel}{Character. Distance kernel applied to retained-reference +predicted RS L1 distances: \code{"Gaussian"} (default) or \code{"Cauchy"}. +Lower-case \code{"gaussian"} and \code{"cauchy"} are also accepted.} + +\item{boost}{\code{NULL}, \code{NA}, or one positive finite numeric factor. +The inspection app default \code{k2} multiplies the kernel weight of the +highest-probability retained site by \code{k2} and returns the resulting +weighted mean instead of the LDC blend. \code{confidence} is ignored in this +mode. Use \code{NULL} or \code{NA} for the unboosted LDC blend.} + +\item{...}{Additional arguments passed to \code{\link[shiny]{runApp}} when +\code{launch = TRUE}, such as \code{host}, \code{port}, or +\code{launch.browser}.} +} +\value{ +A Shiny application object when \code{launch = FALSE}. When +\code{launch = TRUE}, the return value from \code{\link[shiny]{runApp}} is +returned invisibly after the application stops. +} +\description{ +Builds a Shiny application for inspecting how individual target locations +are benchmarked against reference samples. The application shows the raw +condition estimate, the reference samples inside the geographic search +radius, the samples retained by the two-stage HCAS selection, and their +predicted and observed distances on the reference-density surface. +} +\details{ +The inspection tool uses the current \code{\link{benchmark}} and +\code{\link{reference_use}} implementations. Consequently, its controls map +directly to the current benchmarking arguments: \code{k1} is the first-stage +predicted-distance filter, \code{k2} is the reference-density filter, and +\code{xy_penalty} applies the optional scaled-coordinate penalty. Feature +counts, geographic distance handling, density dimensions, and density +metadata are inferred by ClassicHCAS rather than supplied as legacy fixed +values. + +The user interface intentionally retains the standalone inspection tool's +default Shiny theme, \pkg{shinyWidgets} controls, layout, labels, map styling, +and reference-density plot styling. + +Matrix and data.frame inputs must be ordered as \code{x}, \code{y}, predicted +RS variables, then observed RS variables. Raster inputs must contain +predicted RS layers followed by observed RS layers in the same variable +order. For raster inputs, the target selector uses \code{x} and \code{y} +coordinates in the raster coordinate reference system. Map clicks are +projected back to that coordinate system and snapped to the containing raster +cell centre before values are extracted. Temporal reference-sample lists are +not supported because \code{\link{reference_use}} currently supports only a +single reference year. + +The map requires longitude/latitude coordinates. If the input coordinates +are projected, supply their coordinate reference system through \code{crs}; +the display coordinates are then transformed to EPSG:4326. The CRS affects +map display only. Benchmarking uses the coordinate handling implemented by +\code{\link{benchmark}}. +} +\examples{ +\dontrun{ +app <- hcas_inspection( + data = reference_samples, + samples = reference_samples, + ref_density = normalised_density, + crs = "EPSG:3577", + launch = FALSE +) +shiny::runApp(app) +} +} +\seealso{ +\code{\link{benchmark}}, \code{\link{reference_use}} +} diff --git a/man/normalise.Rd b/man/normalise.Rd index 36df8e3..0006cac 100644 --- a/man/normalise.Rd +++ b/man/normalise.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/normalise.R \name{normalise} \alias{normalise} -\title{Clean and normalise HCAS reference density} +\title{Clean and normalise an HCAS reference density surface} \usage{ normalise( x, @@ -15,39 +15,63 @@ normalise( } \arguments{ \item{x}{An HCAS \code{reference_density} object or a matrix representing the -reference density surface (see \code{\link{ref_density}}).} +raw reference density surface created by \code{\link{ref_density}}.} -\item{bin_width}{Numeric. Specifies the bin width of the reference density. If -\code{x} is a \strong{reference_density} object, this value can be read from -its attributes and may be left \code{NULL}. The bin width must be consistent -between the reference density creation and the benchmarking step to ensure -condition is accurately calculated.} +\item{bin_width}{Numeric. Bin width used to create the reference density. If +\code{x} is a \code{reference_density} object, the value is read from its +\code{bin.width} attribute when \code{bin_width = NULL}. The value must match +the density surface used during benchmarking.} -\item{trim_size}{Integer. Defines the number of rows and columns in the trimmed reference density. The default -is 400, and it is generally advisable to retain this default setting.} +\item{trim_size}{Integer. Number of rows and columns to keep in the trimmed +reference density surface.} -\item{offset}{Integer. Specifies the number of reference density bins to ignore during normalization. This value -will be stored as an attribute in the output object.} +\item{offset}{Integer. Number of near-origin bins to ignore during +normalisation. Stored as an attribute on the output.} -\item{legacy}{Logical. Whether to use the legacy C++ code for normalisation (for backward -compatibility) or the modern R version (default). The modern version solves the edge effect -issue without any speed compromise.} +\item{legacy}{Logical. If \code{TRUE}, use the legacy C++ normalisation code +for backward compatibility. The default R implementation avoids the previous +edge effect while retaining similar speed for typical use.} -\item{filename}{Char (optional). The output file name for the .text file.} +\item{filename}{Optional character. File path for writing the normalised +surface as a tab-delimited \file{.txt} file.} } \value{ -A \code{reference_density} object (also matrix, array) +A \code{reference_density} object, which is also a matrix/array. } \description{ -This process includes trimming the reference density surface to remove noise and -normalising its values. +Trims and normalises the raw reference density surface returned by +\code{\link{ref_density}} so it can be used as a probability surface in +\code{\link{benchmark}}. +} +\details{ +The raw reference density surface is a two-dimensional surface of predicted +and observed RS distances among reference samples. Before benchmarking, the +surface is smoothed, trimmed to remove noisy outer bins, and normalised with +respect to predicted-distance bins. This makes each predicted-distance slice +comparable when \code{\link{benchmark}} asks how probable an observed +departure is for a target location. + +\code{trim_size} controls the dimensions of the retained square surface. It +should be smaller than the number of bins used in +\code{\link{ref_density}}. The default is chosen for the standard HCAS +workflow; smaller examples or exploratory analyses can use smaller values. + +\code{offset} removes bins nearest the origin before normalisation. It is +useful when the near-zero distance cells contain self-overlap or other +artefacts. The value is stored on the returned \code{reference_density} +object and must be kept consistent in \code{\link{benchmark}}. } \examples{ \donttest{ library(ClassicHCAS) +raw <- matrix(rexp(30 * 30), nrow = 30) +class(raw) <- c("reference_density", "matrix", "array") +attr(raw, "bin.width") <- 0.1 - +norm <- normalise(raw, trim_size = 15) +attr(norm, "bin.width") +attr(norm, "offset") } } \seealso{ diff --git a/man/palettes.Rd b/man/palettes.Rd index 56c6d6d..bd7555c 100644 --- a/man/palettes.Rd +++ b/man/palettes.Rd @@ -2,18 +2,29 @@ % Please edit documentation in R/colours.R \name{palettes} \alias{palettes} -\title{ClassicHCAS palettes} +\title{ClassicHCAS colour palettes} \usage{ palettes(n = 10, name = c("hcas", "ref_density")) } \arguments{ -\item{n}{Integer. Number of color codes to return.} +\item{n}{Integer. Number of colour codes to return.} -\item{name}{Character. Palette name. One of `"hcas"` or `"ref_density"`.} +\item{name}{Character. Palette name. One of \code{"hcas"} or +\code{"ref_density"}.} } \value{ -A character vector of color codes. +A character vector of hexadecimal colour codes. } \description{ -ClassicHCAS palettes +Returns colour palettes used by ClassicHCAS plots. +} +\details{ +The \code{"hcas"} palette is intended for habitat condition maps, with low +condition shown in purple, intermediate values in yellow, and high condition +in green. The \code{"ref_density"} palette is intended for raw or normalised +reference density surfaces. +} +\examples{ +palettes(5) +palettes(5, "ref_density") } diff --git a/man/radial_count.Rd b/man/radial_count.Rd index d7c9dba..f95b800 100644 --- a/man/radial_count.Rd +++ b/man/radial_count.Rd @@ -2,61 +2,72 @@ % Please edit documentation in R/radial_count.R \name{radial_count} \alias{radial_count} -\title{Number of samples within a radius} +\title{Count samples within a radius around each raster cell} \usage{ radial_count(x, samples_xy, radius_km = 200, num_threads = -1, ...) } \arguments{ -\item{x}{A SpatRaster representing the study area over which sample density will be calculated.} +\item{x}{A \pkg{terra} \code{SpatRaster} whose cells define the locations +where sample counts are calculated. Only the first layer is used.} -\item{samples_xy}{A matrix or data.frame containing x and y coordinates (longitude and latitude) -of the reference points used for density calculation.} +\item{samples_xy}{A two-column matrix or data.frame containing sample +coordinates in the same coordinate reference system as \code{x}.} -\item{radius_km}{Numeric. Specifies the search radius (buffer) in kilometers.} +\item{radius_km}{Numeric. Search radius, in kilometres.} -\item{num_threads}{Integer. Specifies the number of CPU threads to be used for processing. A value -below 1 indicates that all available threads will be utilized. Refer to the details section for -more information.} +\item{num_threads}{Integer. Number of CPU threads to use. Values below 1 use +all available OpenMP threads.} -\item{...}{Additional arguments for writing raster outputs e.g. \code{filename}, -\code{overwrite}, and \code{wopt} from terra \code{\link[terra]{predict}}.} +\item{...}{Additional arguments passed to \code{\link[terra]{interpolate}}, +such as \code{filename}, \code{overwrite}, or \code{wopt}.} } \value{ -A SpatRaster +A \pkg{terra} \code{SpatRaster} containing sample counts. } \description{ -This function calculates the number of samples (x, y coordinates) within a specified radius -for each pixel in a raster map. +Counts how many sample points fall within a specified radius of each cell in a +raster. In HCAS workflows this is mainly an operational helper for mapping +local reference-sample support and for creating workload weights before +tiling large benchmarking jobs. } \details{ -This function uses an integer-based distance checks for fast radius searches on either -geographic or projected coordinates. In geographic mode, coordinates are -stored in micro-degrees (degree * 1000_000) and the distance is approximated by: +\code{radial_count()} does not calculate habitat condition. It produces a +sample-density raster that can help diagnose sparse reference coverage or +guide \code{\link{tiling}} so densely sampled areas with heavy computation +are balanced across tiles. - distance² ≈ (dlat)² + (dlon × cos(lat₁))² +In geographic coordinates, radius searches use a fast integer approximation. +Coordinates are stored in micro-degrees (\code{degree * 1000000}) and distance +is approximated by: -where cos(lat₁) is derived from the query latitude. This avoids floating- -point overhead and provides substantial performance gains but introduces -distortion at larger distances. For applications requiring higher accuracy, -especially beyond regional scales (more than several 100s of kilometers in \code{radius_km}), -use a projected coordinate system so distances in meters can be evaluated directly. +\deqn{distance^2 \approx (\Delta \mathrm{lat})^2 + (\Delta \mathrm{lon} \times \cos(\mathrm{lat}_1))^2}{distance^2 ~= (Delta lat)^2 + ((Delta lon) * cos(lat_1))^2} -Ensure that \href{https://en.wikipedia.org/wiki/OpenMP}{OpenMP} is installed on your system -to take advantage of parallel processing and accelerate computations. While most systems -include OpenMP by default, you may need to load the appropriate module if you're using an HPC -system. +where \eqn{\Delta \mathrm{lat}}{Delta lat} and \eqn{\Delta \mathrm{lon}}{Delta lon} +are coordinate differences, and \eqn{\cos(\mathrm{lat}_1)}{cos(lat_1)} is +derived from the query latitude. This is efficient for large analyses but +introduces distortion over large areas. For high accuracy at broad regional +or continental radii, use a projected coordinate reference system so +distances can be evaluated in metres. -\strong{Note for macOS users:} Install OpenMP via Homebrew with \code{brew install libomp} -before installing this package. +\code{num_threads} uses OpenMP when available. On macOS, installing OpenMP +support with \code{brew install libomp} before installing the package may be +required for multi-threaded execution. } \examples{ \donttest{ library(ClassicHCAS) +r <- terra::rast( + nrows = 10, ncols = 10, + xmin = 0, xmax = 1, ymin = 0, ymax = 1, + crs = "EPSG:4326" +) - +samples <- cbind(x = c(0.2, 0.8), y = c(0.2, 0.8)) +counts <- radial_count(r, samples, radius_km = 50, num_threads = 1) +counts } } \seealso{ -\code{\link{benchmark}} +\code{\link{benchmark}}, \code{\link{tiling}} } diff --git a/man/ref_density.Rd b/man/ref_density.Rd index 943b584..f9f9444 100644 --- a/man/ref_density.Rd +++ b/man/ref_density.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/ref_density.R \name{ref_density} \alias{ref_density} -\title{Reference density surface} +\title{Build an HCAS reference density surface} \usage{ ref_density( data, @@ -16,81 +16,118 @@ ref_density( ) } \arguments{ -\item{data}{A matrix, SpatRaster (from the \pkg{terra} package), or data.frame containing the input data. -The data \strong{must} be organised in the following order: \strong{x}, \strong{y}, \strong{predicted-RS}, -\strong{observed-RS} variables. If using a SpatRaster, the \strong{x} and \strong{y} are not required. -If using a matrix or data.frame, ensure that the variables are in the -correct order. For more see the details section.} +\item{data}{A matrix, data.frame, or \pkg{terra} \code{SpatRaster} containing +input RS data. Matrix and data.frame inputs must be organised as \code{x}, +\code{y}, predicted RS variables, then observed RS variables. Raster inputs +must contain predicted RS layers followed by observed RS layers in the same +variable order;} -\item{samples}{A matrix or data.frame containing the x and y coordinates (longitude and latitude) -of the reference points used for the observed and predicted RS value extraction if \code{data} is a -raster object. If \code{data} argument is matrix, this will be ignored.} +\item{samples}{A two-column matrix or data.frame of sample coordinates used +to extract predicted and observed RS values when \code{data} is a raster. +Ignored for matrix or data.frame inputs.} -\item{radius_km}{Numeric. Specifies the search radius in kilometers for considering reference samples -when creating the reference density surface. See details section for more information on distance calculation.} +\item{radius_km}{Numeric. Search radius, in kilometres, for deciding which +reference-sample pairs contribute to the density surface.} -\item{bin_width}{Numeric. Specifies the bin width of the reference density surface. Finding the optimal bin width -may require some experimentation to achieve the best results. The bin width is added as an attribute -to the output object, ensuring consistency and accuracy in subsequent benchmarking steps.} +\item{bin_width}{Numeric. Width of each predicted-distance and +observed-distance bin. Smaller values increase resolution but can produce a +sparse surface; larger values smooth more aggressively. The value is stored +as a \code{bin.width} attribute on the output.} -\item{bin_num}{Integer. Specifies the number of bins for the reference density surface. It is generally recommended -to use the default value of 650. Adjusting \code{bin_width} is often more effective than changing -\code{bin_num}.} +\item{bin_num}{Integer. Number of bins along each axis of the density surface. +The default is usually adequate; tuning \code{bin_width} is generally more +useful than changing \code{bin_num}.} -\item{drop_features}{Integer vector. Completely remove RS variables from the reference density calculation. -Positions are 1-based within the RS feature set, not the full input column order. For -consistency, it is recommended to exclude the same variables later in the benchmarking step; unless -you have a specific reason not to.} +\item{drop_features}{Optional integer vector of RS variable positions to +exclude from the density calculation. Positions are 1-based within the RS +feature set, not within the full input column order. Use the same exclusion +in \code{\link{benchmark}} unless there is a deliberate reason not to.} -\item{num_threads}{Integer. Specifies the number of CPU threads to be used for processing. A value -below 1 indicates that all available threads will be utilized (default). Refer to the details section for -more information.} +\item{num_threads}{Integer. Number of CPU threads to use. Values below 1 use +all available OpenMP threads.} -\item{filename}{Character (optional). The name of the output file for saving the results as a .txt file.} +\item{filename}{Optional character. File path for writing the raw density +surface as a tab-delimited \file{.txt} file.} } \value{ -A \code{reference_density} object (also matrix, array) +A \code{reference_density} object, which is also a matrix/array. } \description{ -The HCAS reference density surface calculation is based on pair-point densities. -It is an integral part of HCAS, designed to -learn the expected observed remote sensing (RS) values from the predicted RS -values across a wide range of reference sites. Note that the reference sites -used for \code{ref_density} do not need to be the same as those used in the -\code{\link{benchmark}} function. See more in details. +Builds the raw reference density, or probability, surface used by HCAS to +describe natural variation between predicted and observed remote-sensing (RS) +variables at reference sites. } \details{ -Ensure that the order of remote sensing variables is consistent between predicted and observed inputs -(for both raster and matrix formats). The RS variable values must be centered and scaled -prior to prediction. Failure to do so may result in variables with larger ranges having -disproportionate influence in the multi-dimensional distance calculations. - -This function uses an integer-based distance checks for fast radius searches on either -geographic or projected coordinates. In geographic mode, coordinates are -stored in micro-degrees (degree * 1000_000) and the distance is approximated by: - - distance² ≈ (dlat)² + (dlon × cos(lat₁))² - -where cos(lat₁) is derived from the query latitude. This avoids floating- -point overhead and provides substantial performance gains but introduces -distortion at larger distances. For applications requiring higher accuracy, -especially beyond regional scales (more than several 100s of kilometers in \code{radius_km}), -use a projected coordinate system so distances in meters can be evaluated directly. - -Ensure that \href{https://en.wikipedia.org/wiki/OpenMP}{OpenMP} is installed on your system -to take advantage of parallel processing and accelerate computations. While most systems -include OpenMP by default, you may need to load the appropriate module if you're using an HPC -system. - -\strong{Note for macOS users:} Install OpenMP via Homebrew with \code{brew install libomp} -before installing this package. +In HCAS, predicted RS values represent the expected reference-condition signal +for a site, usually estimated from environmental covariates using +high-integrity reference ecosystems. Observed RS values are the actual Earth +observation summaries for the same sites. \code{ref_density()} compares +reference samples with one another and records how predicted-distance and +observed-distance co-vary under reference condition. + +For each pair of reference samples within \code{radius_km}, the function +calculates L1 (Manhattan) distances across all retained RS variables: + +\deqn{d(x, y) = \sum_{j = 1}^{m} |x_j - y_j|} + +where \eqn{m} is the number of RS variables. The predicted-distance and +observed-distance values are then added to a two-dimensional surface with +resolution controlled by \code{bin_width} and \code{bin_num}. The resulting +surface is a compact empirical summary of how much observed RS variation is +expected for a given predicted RS distance among intact or near-intact +reference samples. + +The output of this function is raw and should normally be passed to +\code{\link{normalise}} before use in \code{\link{benchmark}}. The +\code{bin.width} attribute is stored on the returned object so that the same +bin width can be reused during normalisation and benchmarking. + +Matrix and data.frame inputs must be ordered as \code{x}, \code{y}, predicted +RS variables, then observed RS variables. Raster inputs should contain the +predicted RS layers followed by the observed RS layers in the same variable +order; the reference coordinates are supplied separately through +\code{samples}. Predicted and observed variables should be centred and scaled +consistently before running this function so that no variable dominates the +multidimensional distance calculation because of its units or numeric range. + +In geographic coordinates, radius searches use a fast integer approximation. +Coordinates are stored in micro-degrees (\code{degree * 1000000}) and distance +is approximated by: + +\deqn{distance^2 \approx (\Delta \mathrm{lat})^2 + (\Delta \mathrm{lon} \times \cos(\mathrm{lat}_1))^2}{distance^2 ~= (Delta lat)^2 + ((Delta lon) * cos(lat_1))^2} + +where \eqn{\Delta \mathrm{lat}}{Delta lat} and \eqn{\Delta \mathrm{lon}}{Delta lon} +are coordinate differences, and \eqn{\cos(\mathrm{lat}_1)}{cos(lat_1)} is +derived from the query latitude. This is efficient for large analyses but +introduces distortion over large areas. For high accuracy at broad regional +or continental radii, use a projected coordinate reference system so +distances can be evaluated in metres. + +\code{num_threads} uses OpenMP when available. On macOS, installing OpenMP +support with \code{brew install libomp} before installing the package may be +required for multi-threaded execution. } \examples{ \donttest{ library(ClassicHCAS) +# Matrix inputs are x, y, predicted RS variables, then observed RS variables. +reference_data <- cbind( + x = c(0, 0.4, 0.8, 1.2, 1.6, 2.0), + y = c(0, 0.2, 0.8, 1.0, 1.4, 1.8), + rs1 = c(0.10, 0.12, 0.25, 0.30, 0.42, 0.50), + rs1 = c(0.11, 0.14, 0.22, 0.33, 0.40, 0.52) +) +rd <- ref_density( + reference_data, + radius_km = 250, + bin_width = 0.1, + bin_num = 20, + num_threads = 1 +) +rd_norm <- normalise(rd, trim_size = 10) } } \seealso{ diff --git a/man/reference_use.Rd b/man/reference_use.Rd new file mode 100644 index 0000000..adec4fd --- /dev/null +++ b/man/reference_use.Rd @@ -0,0 +1,193 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/reference_use.R +\name{reference_use} +\alias{reference_use} +\title{Assess reference-site use during HCAS benchmarking} +\usage{ +reference_use( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + confidence = 0.5, + lambda = 1, + exclude_slef = TRUE, + drop_features = NULL, + num_threads = -1, + weighted_max = FALSE, + kernel = c("Gaussian", "Cauchy"), + boost = k2 +) +} +\arguments{ +\item{data}{A matrix, data.frame, or \pkg{terra} \code{SpatRaster} +containing target RS data. Matrix and data.frame inputs must be organised as +\code{x}, \code{y}, predicted RS variables, then observed RS variables. +Raster inputs must contain predicted RS layers followed by observed RS +layers in the same variable order.} + +\item{samples}{A matrix or data.frame containing reference sites as +\code{x}, \code{y}, predicted RS variables, then observed RS variables in +the same order as \code{data}. For raster \code{data}, this can instead be a +two-column coordinate table, in which case values are extracted from the +raster. Temporal sample lists are not supported.} + +\item{ref_density}{A normalised \code{reference_density} object or matrix +produced by \code{\link{normalise}}.} + +\item{xy_stats}{Numeric vector of length four used to scale coordinates when +\code{xy_penalty > 0}: \code{mean(x)}, \code{mean(y)}, \code{sd(x)}, +\code{sd(y)}. Use the same values across tiles to keep tiled benchmarking +consistent.} + +\item{xy_penalty}{Numeric. Weight applied to scaled coordinates when selecting +the \code{k1} most similar benchmark samples. \code{0} disables the +spatial penalty.} + +\item{radius_km}{Numeric. Search radius, in kilometres, for candidate +benchmark samples.} + +\item{k1}{Integer. First-stage filter size: the number of nearest samples to +retain after the predicted RS distance search.} + +\item{k2}{Integer. Second-stage filter size: the number of high-probability +samples to retain from the reference density query. Must be less than or +equal to \code{k1}.} + +\item{bin_width}{Numeric. Bin width used to create and normalise +\code{ref_density}. If \code{ref_density} is a \code{reference_density} +object, this value is read from its \code{bin.width} attribute when +\code{bin_width = NULL}.} + +\item{interpolate}{Logical. If \code{TRUE}, bilinearly interpolates the +reference density surface before benchmarking for smoother lookup.} + +\item{offset}{Integer. Number of reference-density bins ignored during +normalisation. If \code{ref_density} is a \code{reference_density} object, +this value is read from its \code{offset} attribute when \code{offset = NULL}.} + +\item{confidence}{Numeric between 0 and 1. Weight given to the selected +maximum probability component relative to the distance-weighted mean +probability when computing raw condition. Ignored when \code{boost} is not +\code{NULL} or \code{NA}; the default is \code{boost = k2}.} + +\item{lambda}{Positive numeric. Distance-scale bandwidth for the selected +\code{kernel}. Both kernels treat \code{lambda} in predicted RS L1 distance +units: the Gaussian kernel uses \code{exp(-(distance / lambda)^2)} and the +Cauchy kernel uses \code{1 / (1 + (distance / lambda)^2)}.} + +\item{exclude_slef}{Logical. If \code{TRUE}, exclude samples whose predicted +RS distance is less than one bin width, preventing a benchmark point from +assessing itself. The argument name preserves the existing API spelling.} + +\item{drop_features}{Optional integer vector of RS variable positions to +exclude from benchmarking. Positions are 1-based within the RS feature set, +not within the full input column order. Use the same exclusion used in +\code{\link{ref_density}} unless there is a deliberate reason not to.} + +\item{num_threads}{Integer. Number of CPU threads to use. Values below 1 use +all available OpenMP threads.} + +\item{weighted_max}{Logical. If \code{FALSE} (the default), the LDC +attribution component uses the maximum unweighted probability. If +\code{TRUE}, it uses the maximum probability-times-distance-weight +contribution. This option affects attribution only when \code{boost = NULL} +or \code{boost = NA}.} + +\item{kernel}{Character. Distance kernel applied to retained-reference +predicted RS L1 distances: \code{"Gaussian"} (default) or \code{"Cauchy"}. +Lower-case \code{"gaussian"} and \code{"cauchy"} are also accepted.} + +\item{boost}{\code{NULL}, \code{NA}, or one positive finite numeric factor. +The default \code{k2} multiplies the kernel weight of the +highest-probability retained site by \code{k2} and returns the resulting weighted +mean instead of the LDC blend. \code{confidence} is ignored in this mode. +Use \code{NULL} or \code{NA} for the unboosted LDC blend.} +} +\value{ +A data.frame with one row per reference site and four columns: +\itemize{ + \item \code{id}: 1-based row index in \code{samples}. + \item \code{predicted}: number of selections among \code{k1}. + \item \code{density}: number of retentions among \code{k2}. + \item \code{condition}: summed distance-kernel/LDC attribution weight. +} +} +\description{ +Records how often and how strongly each reference site is used across the +three stages of the HCAS benchmarking selection process. +} +\details{ +\code{reference_use()} runs the same non-temporal reference-site selection +stages used by \code{\link{benchmark}}, but returns one row per reference +site instead of habitat-condition values. It is implemented separately from +the benchmarking routine so normal benchmarking does not incur diagnostic +bookkeeping costs. + +The returned columns represent: +\describe{ + \item{\code{"predicted"}}{Count selection among the \code{k1} nearest + reference sites in predicted feature space after the radius restriction + and optional XY penalty.} + \item{\code{"density"}}{Count retention among the \code{k2} sites with + the highest reference-density probability.} + \item{\code{"condition"}}{Attribute each retained site's use according to + its contribution to the condition estimator. The + distance-weighted mean component uses normalised weights from the selected + \code{kernel}. With \code{boost} (the default is \code{k2}), attribution + uses boosted normalised kernel weights. Set \code{boost = NULL} or + \code{boost = NA} to use the LDC attribution, where the LDC component is + assigned to the site with the selected maximum probability contribution, + controlled by \code{weighted_max}; ties split that component equally. + Attribution weights sum to one for each evaluated target location.} +} + +The experimental temporal mode is not currently supported. Supply a single +reference sample matrix containing \code{x}, \code{y}, predicted RS +variables, then observed RS variables. + +Raster inputs are processed in blocks and accumulated into the reference-site +table, so the complete raster is not loaded into memory. +} +\examples{ +target <- matrix( + c( + 0, 0, 0.1, 0.1, + 1, 1, 0.8, 0.8 + ), + ncol = 4, + byrow = TRUE +) +samples <- matrix( + c( + 0, 0, 0.1, 0.1, + 1, 1, 0.8, 0.8 + ), + ncol = 4, + byrow = TRUE +) +ref <- matrix(1, nrow = 20, ncol = 20) + +reference_use( + target, + samples, + ref, + radius_km = 1000, + k1 = 2, + k2 = 1, + bin_width = 0.1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 +) +} +\seealso{ +\code{\link{benchmark}} +} diff --git a/man/tiling.Rd b/man/tiling.Rd index 9a69de2..7aed9fb 100644 --- a/man/tiling.Rd +++ b/man/tiling.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tiling.R \name{tiling} \alias{tiling} -\title{Generate raster tiles using raster or matrix data} +\title{Create raster processing tiles} \usage{ tiling( data, @@ -16,74 +16,84 @@ tiling( ) } \arguments{ -\item{data}{A `SpatRaster` object or a numeric matrix. For balanced tiling, either a matrix -or raster can be used. For rectangular tiling, a raster is required.} +\item{data}{A \pkg{terra} \code{SpatRaster} or numeric matrix. Balanced tiling +accepts either form; rectangular tiling requires a raster.} \item{n_tiles}{Integer. Number of tiles to generate.} -\item{balanced}{Logical. If `TRUE` (default), tiles are created to balance the sum of values within each tile. -If `FALSE`, rectangular tiles of equal size are generated.} +\item{balanced}{Logical. If \code{TRUE}, create tiles with approximately +balanced total weights. If \code{FALSE}, create rectangular tiles of similar +size.} -\item{method}{Character. One of `"best"`, `"row"`, `"col"`, or `"both"` (default `"best"`). -Specifies how the balanced tiles should be split: +\item{method}{Character. Splitting strategy for balanced tiles. One of +\code{"best"}, \code{"row"}, \code{"col"}, or \code{"both"}: \describe{ - \item{"best"}{Automatically chooses the split direction that balances node weights and avoids overly skinny tiles.} - \item{"row"}{Always splits by rows.} - \item{"col"}{Always splits by columns.} - \item{"both"}{Splits along both dimensions, favoring the longer dimension.} + \item{\code{"best"}}{Automatically chooses a split direction that balances + weights while avoiding very narrow tiles.} + \item{\code{"row"}}{Always splits by rows.} + \item{\code{"col"}}{Always splits by columns.} + \item{\code{"both"}}{Splits along both dimensions, favouring the longer + dimension.} }} -\item{exact}{Logical. If `TRUE` (default), ensures exactly `n_tiles` are produced in balanced mode.} +\item{exact}{Logical. If \code{TRUE}, force exactly \code{n_tiles} in balanced +mode.} -\item{weighted}{Logical. If `TRUE` (default), tile weights are based on the scaled data values. -If `FALSE`, all non-zero values are treated equally.} +\item{weighted}{Logical. If \code{TRUE}, tile weights are based on the scaled +data values. If \code{FALSE}, all non-zero cells receive equal weight.} -\item{spatial}{Logical. If `TRUE`, returns a `SpatVector` polygon of tiles. -If `FALSE` (default), returns a matrix or data frame with tile extents.} +\item{spatial}{Logical. If \code{TRUE}, return a \pkg{terra} +\code{SpatVector} polygon layer. If \code{FALSE}, return tile extents.} -\item{extent}{Optional. A `terra::ext` object specifying the raster extent. Required when `data` is a matrix.} +\item{extent}{Optional \code{\link[terra]{ext}} object specifying the raster +extent. Required when \code{data} is a matrix.} } \value{ -Either: -\itemize{ - \item A `SpatVector` of polygons representing tiles (if `spatial = TRUE`), or - \item A matrix/data.frame with columns `"xmin"`, `"xmax"`, `"ymin"`, `"ymax"` for each tile (if `spatial = FALSE`). -} +If \code{spatial = TRUE}, a \pkg{terra} \code{SpatVector} of tile +polygons. Otherwise, a matrix with columns \code{xmin}, \code{xmax}, +\code{ymin}, and \code{ymax}. } \description{ -Creates either rectangular or balanced tiles for raster or matrix data. Balanced tiles -attempt to distribute the data values evenly across tiles, while rectangular tiles simply -divide the raster into equal-sized grids. This function helps creating tiles for running -\code{benchmark} function over multiple tiles or systems (e.g. in a cluster). The output -of the \code{\link{radial_count}} function can be used to balance the run time over each tile. +Creates rectangular or value-balanced tiles for splitting large raster +processing jobs, especially HCAS benchmarking runs, into smaller spatial +chunks. } \details{ -- Rectangular tiling divides the raster into equal-sized tiles regardless of data values. -- Balanced tiling attempts to split the data such that the sum of the cell values in each tile is roughly equal. -- The splitting process recursively divides the matrix/raster along rows or columns, according to the `method`. -- NA values are treated as zero for the purpose of balanced tiling. +Large HCAS benchmarking jobs can be uneven because areas with many nearby +reference samples require more work than sparse areas. \code{tiling()} can +split a raster or matrix into tiles whose total cell weights are roughly +balanced, making distributed or multi-node processing more even. A common +workflow is to run \code{\link{radial_count}} first, then use the resulting +count raster as the \code{data} argument for balanced tiling. + +If \code{balanced = FALSE}, the function creates simple rectangular tiles of +similar size and ignores cell values. Rectangular tiling requires a +\pkg{terra} \code{SpatRaster}. If \code{balanced = TRUE}, the function treats +\code{NA} as zero, rescales non-missing values to positive weights, and +recursively splits the raster or matrix so each tile has a similar total +weight. If \code{weighted = FALSE}, all non-zero cells are treated equally. } \examples{ -\dontrun{ +\donttest{ library(ClassicHCAS) -library(terra) -r <- rast(nrows=100, ncols=100) -values(r) <- runif(ncell(r)) +r <- terra::rast(nrows = 20, ncols = 20) +terra::values(r) <- runif(terra::ncell(r)) -# Balanced tiles -tiles_poly <- ClassicHCAS::tiling(r, n_tiles = 4, balanced = TRUE, spatial = TRUE) +# Balanced tiles from raster weights. +balanced_tiles <- tiling(r, n_tiles = 4, balanced = TRUE) -# Rectangular tiles -tiles_rect <- ClassicHCAS::tiling(r, n_tiles = 4, balanced = FALSE) +# Rectangular tiles. +rectangular_tiles <- tiling(r, n_tiles = 4, balanced = FALSE) -# Balanced tiles from a matrix -mat <- as.matrix(r) -ext <- ext(r) -tiles_from_matrix <- ClassicHCAS::tiling(mat, n_tiles = 4, balanced = TRUE, extent = ext) +# Balanced tiles from a matrix need an explicit extent. +mat <- terra::as.matrix(r, wide = TRUE) +matrix_tiles <- tiling(mat, n_tiles = 4, extent = terra::ext(r)) } } \seealso{ -\code{\link[terra]{rast}}, \code{\link[terra]{as.polygons}}, \code{\link[terra]{ext}} +\code{\link{radial_count}}, \code{\link{benchmark}}, +\code{\link[terra]{rast}}, \code{\link[terra]{as.polygons}}, +\code{\link[terra]{ext}} } diff --git a/man/variable_importance.Rd b/man/variable_importance.Rd new file mode 100644 index 0000000..97b4baa --- /dev/null +++ b/man/variable_importance.Rd @@ -0,0 +1,238 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/variable_importance.R +\name{variable_importance} +\alias{variable_importance} +\title{Per-variable departure attribution for HCAS benchmarking} +\usage{ +variable_importance( + data, + samples, + ref_density, + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0, + radius_km = 200, + k1 = 70, + k2 = 10, + bin_width = NULL, + interpolate = TRUE, + offset = 0, + lambda = 1, + epsilon = 1e-06, + output = c("importance", "signal", "share"), + exclude_slef = TRUE, + drop_features = NULL, + num_threads = -1, + kernel = c("Gaussian", "Cauchy"), + boost = k2, + ... +) +} +\arguments{ +\item{data}{A matrix, data.frame, or \pkg{terra} \code{SpatRaster} of target +RS data. Matrix and data.frame inputs must be organised as \code{x}, +\code{y}, predicted RS variables, then observed RS variables. Raster inputs +must contain predicted RS layers followed by observed RS layers in the same +variable order.} + +\item{samples}{A matrix or data.frame of reference sites as \code{x}, +\code{y}, predicted RS variables, then observed RS variables in the same +order as \code{data}. For raster \code{data} it may instead be a two-column +coordinate table, in which case raster values are extracted. Temporal sample +lists are not supported.} + +\item{ref_density}{A normalised \code{reference_density} object or matrix +produced by \code{\link{normalise}}.} + +\item{xy_stats}{Numeric vector of length four used to scale coordinates when +\code{xy_penalty > 0}: \code{mean(x)}, \code{mean(y)}, \code{sd(x)}, +\code{sd(y)}. Use the same values across tiles to keep tiled benchmarking +consistent.} + +\item{xy_penalty}{Numeric. Weight applied to scaled coordinates when selecting +the \code{k1} most similar benchmark samples. \code{0} disables the +spatial penalty.} + +\item{radius_km}{Numeric. Search radius, in kilometres, for candidate +benchmark samples.} + +\item{k1}{Integer. First-stage filter size: the number of nearest samples to +retain after the predicted RS distance search.} + +\item{k2}{Integer. Second-stage filter size: the number of high-probability +samples to retain from the reference density query. Must be less than or +equal to \code{k1}.} + +\item{bin_width}{Numeric. Bin width used to create and normalise +\code{ref_density}. If \code{ref_density} is a \code{reference_density} +object, this value is read from its \code{bin.width} attribute when +\code{bin_width = NULL}.} + +\item{interpolate}{Logical. If \code{TRUE}, bilinearly interpolates the +reference density surface before benchmarking for smoother lookup.} + +\item{offset}{Integer. Number of reference-density bins ignored during +normalisation. If \code{ref_density} is a \code{reference_density} object, +this value is read from its \code{offset} attribute when \code{offset = NULL}.} + +\item{lambda}{Positive numeric. Distance-scale bandwidth for the selected +\code{kernel} applied to retained-reference predicted RS L1 distances. See +\code{\link{benchmark}} for the kernel-specific parameterisation.} + +\item{epsilon}{Numeric, non-negative. Floor added to the noise term to avoid +division by (near-)zero reference dispersion. Used only when +\code{output = "importance"}.} + +\item{output}{Character. One of \code{"importance"} (default; per-variable +signal-to-noise ratio), \code{"signal"} (raw weighted departure +contribution), or \code{"share"} (per-cell departure partition summing to one +across variables). See Details.} + +\item{exclude_slef}{Logical. If \code{TRUE}, exclude samples whose predicted +RS distance is less than one bin width, preventing a benchmark point from +assessing itself. The argument name preserves the existing API spelling.} + +\item{drop_features}{Optional integer vector of RS variable positions to +exclude from benchmarking. Positions are 1-based within the RS feature set, +not within the full input column order. Use the same exclusion used in +\code{\link{ref_density}} unless there is a deliberate reason not to.} + +\item{num_threads}{Integer. Number of CPU threads to use. Values below 1 use +all available OpenMP threads.} + +\item{kernel}{Character. Distance kernel applied to retained-reference +predicted RS L1 distances: \code{"Gaussian"} (default) or \code{"Cauchy"}. +Lower-case \code{"gaussian"} and \code{"cauchy"} are also accepted.} + +\item{boost}{\code{NULL}, \code{NA}, or one positive finite numeric factor. +The default \code{k2} multiplies the kernel weight of the +highest-probability retained reference by \code{k2} before signal and noise +are computed. Use \code{NULL} or \code{NA} for ordinary unboosted kernel +weights.} + +\item{...}{Additional arguments passed to \code{\link[terra]{interpolate}} +when benchmarking raster outputs, such as \code{filename}, \code{overwrite}, +or \code{wopt}.} +} +\value{ +When \code{data} is a matrix, a numeric matrix with one row per +target cell and one column per RS variable. When \code{data} is a raster, a +\pkg{terra} \code{SpatRaster} with one layer per RS variable. Cells with +missing observed values or no usable references are \code{NaN}; with +\code{output = "share"}, cells with zero total departure are also \code{NaN}. +} +\description{ +Quantifies, for each target location, how much each remote-sensing (RS) +variable contributes to the observed departure from its locally selected +reference sites, standardised by how tightly those references agree among +themselves on that variable. It answers which RS variables drive habitat +condition variation, conditional on the local intact ecological distribution, +rather than treating importance as a global property of a variable. +} +\details{ +\code{variable_importance()} reuses the same non-temporal three-stage +reference selection as \code{\link{benchmark}}: candidates are restricted to +those within \code{radius_km}, the \code{k1} nearest in predicted RS +space (with an optional XY penalty) are retained, and the \code{k2} with +the highest reference-density probability are kept. Each retained reference +is weighted with the same selected distance kernel on predicted RS +distance used by \code{benchmark()}, so the diagnostic reports on the +reference set and weights that benchmarking actually uses. With +\code{boost} (the default is \code{k2}), the kernel weight of the retained +reference with the highest reference-density probability is multiplied by +that factor before signal and noise are computed. Set \code{boost = NULL} or +\code{boost = NA} to use the ordinary unboosted kernel weights. + +For each RS variable \eqn{v} the importance at a target cell is a +signal-to-noise ratio + +\deqn{importance_v = \frac{signal_v}{noise_v + \epsilon}} + +where, with normalised distance-kernel weights \eqn{w_k} that sum to \eqn{W}, + +\deqn{signal_v = \frac{1}{W} \sum_k w_k\, |obs^{target}_v - obs^{ref,k}_v|} +\deqn{noise_v = \frac{1}{W^2} \sum_k \sum_l w_k w_l\, |obs^{ref,k}_v - obs^{ref,l}_v|} + +The signal is the weighted mean absolute departure of the target from its +references on variable \eqn{v}; the noise is the weighted mean absolute +difference among the references themselves (a distance-weighted Gini mean +difference). Both quantities stay in the L1 geometry of the engine, +so the per-variable signals sum to the weighted total observed departure that +the reference-density lookup consumes. + +This is an attribution of the \emph{observed departure} that drives habitat +condition, not a sensitivity decomposition of the condition score itself: the +departure enters condition non-linearly through the reference-density surface. +Importances are univariate and so do not de-correlate variables; collinear RS +variables each receive their marginal share. The local-maximum (LDC) +component of condition is intentionally excluded, so the metric corresponds to +the distance-weighted-mean component of \code{benchmark()}. + +\code{epsilon} guards the denominator against variables on which the +references agree almost perfectly (near-zero noise). Raise it to dampen +unstable ratios for low-dispersion variables. Because the noise estimate uses +only \code{k2} references, it is itself noisy when the distance weights are +concentrated on a single reference; interpret single-reference cells (where +noise is zero) with care. + +Predicted and observed RS variables should be centred and scaled consistently +before use, exactly as for \code{\link{benchmark}}, so that per-variable +departures and dispersions are comparable across variables. + +The \code{output} argument selects what each layer/column holds: +\describe{ + \item{\code{"importance"}}{the signal-to-noise ratio above (default). Best + for ranking and for mapping where a variable is anomalous relative to its + local references. It is open-ended (not normalised) and inherits the + \code{epsilon} sensitivity for low-dispersion variables.} + \item{\code{"signal"}}{the raw weighted absolute departure \eqn{signal_v}. + Per cell these sum to the distance-weighted total observed departure that the + reference-density lookup consumes, so they have a conserved total and are + unaffected by \code{epsilon}.} + \item{\code{"share"}}{the per-cell departure partition + \eqn{signal_v / \sum_u signal_u}. Each cell's variables sum to one (mutually + exclusive), giving "variable \eqn{v} accounts for this fraction of the + observed departure here". Cells whose total departure is zero are + \code{NaN}. This is the most direct percent-attribution map.} +} + +Use \code{\link{aggregate_importance}} to summarise per-cell output across the +landscape into a robust ranking (median) and an average attribution (mean of +per-cell relative shares). +} +\examples{ +target <- matrix( + c( + 0, 0, 0.1, 0.2, 0.1, 0.2, + 1, 1, 0.8, 0.7, 0.9, 0.6 + ), + ncol = 6, + byrow = TRUE +) +samples <- matrix( + c( + 0, 0, 0.1, 0.2, 0.12, 0.18, + 1, 1, 0.8, 0.7, 0.85, 0.72, + 0, 1, 0.4, 0.5, 0.42, 0.55 + ), + ncol = 6, + byrow = TRUE +) +ref <- matrix(1, nrow = 20, ncol = 20) + +variable_importance( + target, + samples, + ref, + radius_km = 1000, + k1 = 3, + k2 = 2, + bin_width = 0.1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 +) +} +\seealso{ +\code{\link{benchmark}}, \code{\link{reference_use}}, and +\code{\link{aggregate_importance}} +} diff --git a/src/Benchmark.cpp b/src/Benchmark.cpp index 2c18428..d118b13 100644 --- a/src/Benchmark.cpp +++ b/src/Benchmark.cpp @@ -33,17 +33,33 @@ Rcpp::NumericMatrix bench_cpp( double xy_penalty = 0.0, // penalising env nearest neighbour searching for geographic distance bool geographic = false, // geographic/unprojected crs? double radius_km = 200, // radius in kilometers to consider ref points - int k_env = 50, // number of ENV nn to select - int k_rs = 20, // number of RS/Prob values to select + int k_env = 70, // number of ENV nn to select + int k_rs = 10, // number of RS/Prob values to select double bin_width = 0.05, // reference density bin width int bin_num = 400, // number of bins in reference density int offset = 0, // offset of reference density double confidence = 0.5, // the LDC confidence index; default 0.5 - double lambda = 2.0, // the lambda of the Cauchy weighting + double lambda = 1.0, // distance-kernel bandwidth bool exclude_slef = true, // whether to exclude a benchmark sample from assessing itself + Rcpp::Nullable temporal_weights = R_NilValue, // Gaussian weights for reference years bool make_su = false, // whether to produce SU map - int num_threads = -1) // -1 or 0 utilises all available threads + int num_threads = -1, // -1 or 0 utilises all available threads + std::string kernel = "gaussian", // distance weighting kernel + Rcpp::Nullable boost = R_NilValue) // optional maximum-probability weight multiplier { + double boost_factor = std::numeric_limits::quiet_NaN(); + if (boost.isNotNull()) { + Rcpp::NumericVector boost_value(boost); + if (boost_value.size() != 1) { + Rcpp::stop("'boost' must be NULL, NA, or one finite number greater than zero."); + } + if (!std::isnan(boost_value[0])) { + if (!std::isfinite(boost_value[0]) || boost_value[0] <= 0.0) { + Rcpp::stop("'boost' must be NULL, NA, or one finite number greater than zero."); + } + boost_factor = boost_value[0]; + } + } if (xy_stats.size() != 4) { Rcpp::stop("'xy_stats' must contain exactly four values: mean(x), mean(y), sd(x), sd(y)."); } @@ -59,6 +75,18 @@ Rcpp::NumericMatrix bench_cpp( if (bin_width <= 0.0) { Rcpp::stop("'bin_width' must be > 0."); } + if (!std::isfinite(confidence) || confidence < 0.0 || confidence > 1.0) { + Rcpp::stop("'confidence' must be a finite number between 0 and 1."); + } + if (!std::isfinite(lambda) || lambda <= 0.0) { + Rcpp::stop("'lambda' must be a finite number greater than zero."); + } + kernel = canonical_distance_kernel(kernel); + if (kernel.empty()) { + Rcpp::stop("'kernel' must be 'Gaussian'/'gaussian' or 'Cauchy'/'cauchy'."); + } + const DistanceKernel kernel_method = + distance_kernel_from_string(kernel); // convert all Rcpp matrices to custom C++ matrix [faster computation and avoids OpenMp conflicts] RowMajorMatrix raster = as_Matrix(raster_vals); @@ -73,9 +101,45 @@ Rcpp::NumericMatrix bench_cpp( const int nr = raster.rows(); const int ns = samples.rows(); - int nvar = (samples.cols() - 2) / 2; // number of RS vars + if (raster.cols() < 4 || (raster.cols() - 2) % 2 != 0) { + Rcpp::stop("'raster_vals' must contain x, y, predicted RS, and observed RS columns."); + } + const int nvar = (raster.cols() - 2) / 2; // number of RS vars int ndim = nvar + 2; // number of multi-variate space REM + XY + const bool temporal = temporal_weights.isNotNull(); + std::vector year_weights(1, 1.0); + if (temporal) { + Rcpp::NumericVector weights(temporal_weights); + if (weights.size() < 1) { + Rcpp::stop("'temporal_weights' must contain at least one value."); + } + + year_weights.resize(weights.size()); + bool any_positive = false; + for (R_xlen_t i = 0; i < weights.size(); ++i) { + if (!std::isfinite(weights[i]) || weights[i] < 0.0) { + Rcpp::stop("'temporal_weights' must contain finite, non-negative values."); + } + year_weights[i] = weights[i]; + any_positive = any_positive || weights[i] > 0.0; + } + if (!any_positive) { + Rcpp::stop("'temporal_weights' must contain at least one positive value."); + } + } + + const int n_years = static_cast(year_weights.size()); + const int obs_start = 2 + nvar; + const int expected_sample_cols = 2 + nvar + nvar * n_years; + if (samples.cols() != expected_sample_cols) { + Rcpp::stop( + temporal + ? "'sample_vals' columns do not match the target features and temporal weights." + : "'sample_vals' must contain x, y, predicted RS, and observed RS columns matching 'raster_vals'." + ); + } + double scale; int64_t r2; const double radius_m = radius_km * 1000.0; @@ -147,7 +211,7 @@ Rcpp::NumericMatrix bench_cpp( int64_t cos_scale = 0; if (geographic) { - // Calcualte only 1 cos() for efficiency + // Calculate only 1 cos() for efficiency cos_scale = static_cast(std::cos(raster_xy(i, 1) * DEG_2_RAD) * 1000000); } @@ -166,11 +230,6 @@ Rcpp::NumericMatrix bench_cpp( // 'j' is the original index into the full 'samples' matrix for (const auto& j : knn_env) { - // Get the OBS part of the sample row for RS distance calculation - const auto sub_obs_row = samples.row(j).rightCols(nvar); - // Vectorised L1 distance over all columns for RS (OBS) - float32_t rsdist = (cell_obs - sub_obs_row).template lpNorm<1>(); - // The xy coordinates should be ignored for REM dist, so only middleCols(2, nvar) const auto sub_rem_row = samples.row(j).middleCols(2, nvar); float32_t prdist = (cell_rem.rightCols(nvar) - sub_rem_row).template lpNorm<1>(); @@ -180,8 +239,34 @@ Rcpp::NumericMatrix bench_cpp( continue; } + double selected_prob = 0.0; + double selected_score = -std::numeric_limits::infinity(); + + for (int year = 0; year < n_years; ++year) + { + const auto sub_obs_row = samples.row(j).segment( + obs_start + year * nvar, + nvar + ); + float32_t rsdist = (cell_obs - sub_obs_row).template lpNorm<1>(); + double raw_prob = get_prob_value( + refdens, + prdist, + rsdist, + binwidth, + bin_num, + offset + ); + double weighted_score = raw_prob * year_weights[year]; + + if (weighted_score > selected_score) { + selected_score = weighted_score; + selected_prob = weighted_score; + } + } + prdist_vect.push_back(static_cast(prdist)); - prob_vect.push_back(get_prob_value(refdens, prdist, rsdist, binwidth, bin_num, offset)); + prob_vect.push_back(selected_prob); } // Not enough candidates for this cell (e.g., sparse/edge tiles). @@ -211,8 +296,15 @@ Rcpp::NumericMatrix bench_cpp( prob_sorted[k] = prob_vect[k]; // prob_vect is already sorted by qsort_index; just get first 20 } - // calculate the Cauchy weighting condition - Condition wcond = get_Condition(prob_sorted, pr_dist, prob_sorted[0], confidence, lambda); + // Calculate the selected distance-kernel-weighted condition. + Condition wcond = get_Condition( + prob_sorted, + pr_dist, + confidence, + lambda, + kernel_method, + boost_factor + ); condition_vect[i] = wcond; } } @@ -229,7 +321,7 @@ Rcpp::NumericMatrix bench_cpp( for (const auto& cval : condition_vect) { out_mat(i, 0) = cval.hc; - out_mat(i, 1) = (cval.su > 0.0) ? std::log(cval.su) : NA_REAL; + out_mat(i, 1) = std::isfinite(cval.log_su) ? cval.log_su : NA_REAL; i++; } } diff --git a/src/Helper.h b/src/Helper.h index 3426ed4..5499531 100644 --- a/src/Helper.h +++ b/src/Helper.h @@ -1,134 +1,93 @@ -#pragma once -#include -#include -#include -#include -#include -#include // for std::pair -#include "Float32_t.h" // importing float32_t - -// a struct to hold both condition and SU values -struct Condition -{ - double hc; - double su; -}; - - -// Combine Radius Search (XY) and KNN Search (ENV) -template -std::vector combined_Search( - const std::vector& sample_x, // Integer and scaled sample coordinates - const std::vector& sample_y, - const RowMajorMatrix& samples, // The full original samples matrix - const Eigen::MatrixBase& cell_rem, // The target REM row of the raster - const int64_t query_x, - const int64_t query_y, - int64_t r2, // Integer and scaled squared radius - int k_env, // K for KNN - int ndim, // Number of REM (Environmental) columns - int64_t cos_scale, - bool is_geo -) { - const int size = sample_x.size(); - // Use pair - std::vector> dist_idx; - // Reserve 10000; it's a heuristic, but better than nothing - dist_idx.reserve(10000); - - // 1. Perform radius check, and calculate ENV distance for KNN later - for (int i = 0; i < size; ++i) { - const int64_t dx = sample_x[i] - query_x; - const int64_t dy = sample_y[i] - query_y; - - const int64_t dy2 = dy * dy; - // Early latitude rejection - if (dy2 > r2) continue; - - int64_t dist2; - if (is_geo) { - const int64_t dx_scaled = (dx * cos_scale) / 1000000; - dist2 = dy2 + dx_scaled * dx_scaled; - } else { - dist2 = dy2 + dx * dx; - } - - // 2. If within radius, calculate ENV L1 Distance - if (dist2 <= r2) { - // Get the REM part of the sample row (first ndim columns) - // This is for KNN and contain both XY and REM - const auto sample_rem = samples.row(i).leftCols(ndim); - - // Calculate L1 distance (Minkowski p-norm with p=1) - float env_dist = (sample_rem - cell_rem).template lpNorm<1>(); - - // Store the ENV distance and the *original* sample index (i) - dist_idx.emplace_back(env_dist, i); - } - } - - // 3. Find the K nearest using std::nth_element - const int n_found = dist_idx.size(); - // If we found more than k_env samples, use nth_element to find the k smallest - if (k_env < n_found) { - // Find the k_env'th smallest element (0-indexed) - std::nth_element(dist_idx.begin(), dist_idx.begin() + k_env, dist_idx.end()); - dist_idx.resize(k_env); - } - - // 4. Extract final indices - std::vector result(dist_idx.size()); - // result[i] is the original index 'i' into the full 'samples' matrix - for (size_t i = 0; i < dist_idx.size(); ++i) { - result[i] = dist_idx[i].second; - } - - return result; -} - - -// HCAS Cauchy weighted condition calculation using reference density values and env distances -inline Condition get_Condition( - const std::vector &prob_values, // reference density probability values - const std::vector &pred_dists, // the predicted/modelled distance - double prob_max, // max probability value of the 20 records - const double confidence, // the confidence value - const double lambda) // the lambda of the Cauchy weighting -{ - const int n = prob_values.size(); - - const double PI_SQ = 9.869604401089358; - const double DEFAULT_HC = -2.0; - double lambda_sq = lambda * lambda; - double w_sum = 0.0; - double p_sum = 0.0; - - // calculate weights - for (int i = 0; i < n; ++i) - { - double p_dist = pred_dists[i]; - - double weight = 1.0; - if (p_dist > 0) { - weight = 1.0 / (PI_SQ * p_dist * lambda * (1.0 + (p_dist * p_dist) / lambda_sq)); - } - - p_sum += prob_values[i] * weight; - w_sum += weight; - } - - // calculate hc - double hc = DEFAULT_HC; - if (w_sum > 0) { - double p_mean = p_sum / w_sum; - prob_max = std::max(prob_max, p_mean); - hc = (prob_max * confidence) + (p_mean * (1.0 - confidence)); - } - - return {hc, w_sum}; -} - - +#pragma once +#include +#include +#include +#include +#include +#include // for std::pair +#include "Float32_t.h" // importing float32_t +#include "Kernel.h" + +// a struct to hold both condition and SU values +struct Condition +{ + double hc; + double log_su; +}; + + +// Combine Radius Search (XY) and KNN Search (ENV) +template +std::vector combined_Search( + const std::vector& sample_x, // Integer and scaled sample coordinates + const std::vector& sample_y, + const RowMajorMatrix& samples, // The full original samples matrix + const Eigen::MatrixBase& cell_rem, // The target REM row of the raster + const int64_t query_x, + const int64_t query_y, + int64_t r2, // Integer and scaled squared radius + int k_env, // K for KNN + int ndim, // Number of REM (Environmental) columns + int64_t cos_scale, + bool is_geo +) { + const int size = sample_x.size(); + // Use pair + std::vector> dist_idx; + // Reserve 10000; it's a heuristic, but better than nothing + dist_idx.reserve(10000); + + // 1. Perform radius check, and calculate ENV distance for KNN later + for (int i = 0; i < size; ++i) { + const int64_t dx = sample_x[i] - query_x; + const int64_t dy = sample_y[i] - query_y; + + const int64_t dy2 = dy * dy; + // Early latitude rejection + if (dy2 > r2) continue; + + int64_t dist2; + if (is_geo) { + const int64_t dx_scaled = (dx * cos_scale) / 1000000; + dist2 = dy2 + dx_scaled * dx_scaled; + } else { + dist2 = dy2 + dx * dx; + } + + // 2. If within radius, calculate ENV L1 Distance + if (dist2 <= r2) { + // Get the REM part of the sample row (first ndim columns) + // This is for KNN and contain both XY and REM + const auto sample_rem = samples.row(i).leftCols(ndim); + + // Calculate L1 distance (Minkowski p-norm with p=1) + float env_dist = (sample_rem - cell_rem).template lpNorm<1>(); + + // Store the ENV distance and the *original* sample index (i) + dist_idx.emplace_back(env_dist, i); + } + } + + // 3. Find the K nearest using std::nth_element + const int n_found = dist_idx.size(); + // If we found more than k_env samples, use nth_element to find the k smallest + if (k_env < n_found) { + // Find the k_env'th smallest element (0-indexed) + std::nth_element(dist_idx.begin(), dist_idx.begin() + k_env, dist_idx.end()); + dist_idx.resize(k_env); + } + + // 4. Extract final indices + std::vector result(dist_idx.size()); + // result[i] is the original index 'i' into the full 'samples' matrix + for (size_t i = 0; i < dist_idx.size(); ++i) { + result[i] = dist_idx[i].second; + } + + return result; +} + + // get the probability value from the reference density table inline double get_prob_value(const RowMajorMatrix& ref_density, const float dist_pre, @@ -151,7 +110,208 @@ inline double get_prob_value(const RowMajorMatrix& ref_density, // make sure there won't be negative values of i and j ii = std::max(ii - offset, 0); jj = std::max(jj - offset, 0); - + return ref_density(ii, jj); } - + + +// HCAS distance-weighted condition calculation using reference density values +// and predicted environmental distances. +inline Condition get_Condition( + const std::vector &prob_values, // reference density probability values + const std::vector &pred_dists, // predicted/modelled distances + const double confidence, // LDC maximum-probability blend + const double lambda, // distance-kernel bandwidth + const DistanceKernel kernel, // selected distance kernel + const double boost) // optional maximum-probability weight multiplier +{ + const int n = static_cast(prob_values.size()); + const double DEFAULT_HC = -2.0; + const double NO_SUPPORT = std::numeric_limits::quiet_NaN(); + + if (n == 0 || + pred_dists.size() != prob_values.size() || + !std::isfinite(lambda) || + !(lambda > 0.0) || + (!std::isnan(boost) && (!std::isfinite(boost) || !(boost > 0.0)))) { + return {DEFAULT_HC, NO_SUPPORT}; + } + + // Shift all log weights by their maximum. At least one relative weight is + // then exactly one, so the weighted mean cannot fail solely because every + // absolute kernel weight underflowed to zero. + double max_log_weight = -std::numeric_limits::infinity(); + for (int i = 0; i < n; ++i) + { + if (!std::isfinite(pred_dists[i]) || + !std::isfinite(prob_values[i])) { + continue; + } + + const double log_weight = log_distance_weight( + pred_dists[i], + lambda, + kernel + ); + if (std::isfinite(log_weight)) { + max_log_weight = std::max(max_log_weight, log_weight); + } + } + + if (!std::isfinite(max_log_weight)) { + return {DEFAULT_HC, NO_SUPPORT}; + } + + double relative_w_sum = 0.0; + double relative_p_sum = 0.0; + double prob_max = -std::numeric_limits::infinity(); + int prob_max_index = -1; + + for (int i = 0; i < n; ++i) + { + if (!std::isfinite(pred_dists[i]) || + !std::isfinite(prob_values[i])) { + continue; + } + + const double log_weight = log_distance_weight( + pred_dists[i], + lambda, + kernel + ); + if (!std::isfinite(log_weight)) { + continue; + } + + const double relative_exponent = + std::min(0.0, log_weight - max_log_weight); + const double relative_weight = std::exp(relative_exponent); + const double relative_weighted_prob = + prob_values[i] * relative_weight; + + relative_p_sum += relative_weighted_prob; + relative_w_sum += relative_weight; + if (prob_values[i] > prob_max) { + prob_max = prob_values[i]; + prob_max_index = i; + } + } + + if (!(relative_w_sum > 0.0)) { + return {DEFAULT_HC, NO_SUPPORT}; + } + + // The common absolute scale cancels from the weighted mean. + const double p_mean = relative_p_sum / relative_w_sum; + const double log_raw_scale = max_log_weight; + double hc = + (prob_max * confidence) + (p_mean * (1.0 - confidence)); + + if (!std::isnan(boost)) { + // Apply the boost in log space so large factors cannot overflow and can + // still revive a very small kernel weight that underflowed previously. + const double log_boost = std::log(boost); + double max_boosted_log_weight = + -std::numeric_limits::infinity(); + for (int i = 0; i < n; ++i) { + if (!std::isfinite(pred_dists[i]) || + !std::isfinite(prob_values[i])) { + continue; + } + const double log_weight = log_distance_weight( + pred_dists[i], + lambda, + kernel + ); + if (!std::isfinite(log_weight)) { + continue; + } + const double boosted_log_weight = log_weight + + (i == prob_max_index ? log_boost : 0.0); + max_boosted_log_weight = std::max( + max_boosted_log_weight, + boosted_log_weight + ); + } + + double boosted_p_sum = 0.0; + double boosted_w_sum = 0.0; + for (int i = 0; i < n; ++i) { + if (!std::isfinite(pred_dists[i]) || + !std::isfinite(prob_values[i])) { + continue; + } + const double log_weight = log_distance_weight( + pred_dists[i], + lambda, + kernel + ); + if (!std::isfinite(log_weight)) { + continue; + } + const double boosted_log_weight = log_weight + + (i == prob_max_index ? log_boost : 0.0); + const double boosted_weight = std::exp(std::min( + 0.0, + boosted_log_weight - max_boosted_log_weight + )); + boosted_p_sum += prob_values[i] * boosted_weight; + boosted_w_sum += boosted_weight; + } + if (!(boosted_w_sum > 0.0) || !std::isfinite(boosted_w_sum)) { + return {DEFAULT_HC, NO_SUPPORT}; + } + hc = boosted_p_sum / boosted_w_sum; + } + + // Store support in log space so even extremely small absolute support + // remains representable. + const double log_support = + log_raw_scale + std::log(relative_w_sum); + + return {hc, log_support}; +} + + +/* +// HCAS Cauchy weighted condition calculation using reference density values and env distances +inline Condition get_Condition( + const std::vector &prob_values, // reference density probability values + const std::vector &pred_dists, // the predicted/modelled distance + double prob_max, // max probability value of the 20 records + const double confidence, // the confidence value + const double lambda) // the lambda of the Cauchy weighting +{ + const int n = prob_values.size(); + + const double PI_SQ = 9.869604401089358; + const double DEFAULT_HC = -2.0; + double lambda_sq = lambda * lambda; + double w_sum = 0.0; + double p_sum = 0.0; + + // calculate weights + for (int i = 0; i < n; ++i) + { + double p_dist = pred_dists[i]; + + double weight = 1.0; + if (p_dist > 0) { + weight = 1.0 / (PI_SQ * p_dist * lambda * (1.0 + (p_dist * p_dist) / lambda_sq)); + } + + p_sum += prob_values[i] * weight; + w_sum += weight; + } + + // calculate hc + double hc = DEFAULT_HC; + if (w_sum > 0) { + double p_mean = p_sum / w_sum; + prob_max = std::max(prob_max, p_mean); + hc = (prob_max * confidence) + (p_mean * (1.0 - confidence)); + } + + return {hc, w_sum}; +} +*/ diff --git a/src/Kernel.h b/src/Kernel.h new file mode 100644 index 0000000..bced4e3 --- /dev/null +++ b/src/Kernel.h @@ -0,0 +1,85 @@ +#pragma once + +#include +#include +#include +#include + + +enum class DistanceKernel +{ + Gaussian, + Cauchy +}; + + +inline std::string canonical_distance_kernel(std::string kernel) +{ + std::transform( + kernel.begin(), + kernel.end(), + kernel.begin(), + [](unsigned char c) { + return static_cast(std::tolower(c)); + } + ); + + return (kernel == "gaussian" || kernel == "cauchy") + ? kernel + : ""; +} + + +inline DistanceKernel distance_kernel_from_string( + const std::string& kernel) +{ + return canonical_distance_kernel(kernel) == "cauchy" + ? DistanceKernel::Cauchy + : DistanceKernel::Gaussian; +} + + +// Log kernel weight for predicted RS L1 distance. Gaussian is +// exp(-(distance / lambda)^2). Cauchy uses the standard Cauchy shape, +// normalised to weight one at zero: +// +// 1 / (1 + (distance / lambda)^2) +inline double log_distance_weight( + const double predicted_distance, + const double lambda, + const DistanceKernel kernel) +{ + const double distance = std::max(predicted_distance, 0.0); + + if (kernel == DistanceKernel::Gaussian) { + const double distance_scale = distance / lambda; + return -(distance_scale * distance_scale); + } + + if (distance == 0.0) { + return 0.0; + } + + const double log_distance = std::log(distance); + const double log_lambda = std::log(lambda); + const double twice_log_ratio = + 2.0 * (log_distance - log_lambda); + const double log_one_plus_ratio_sq = twice_log_ratio > 0.0 + ? twice_log_ratio + std::log1p(std::exp(-twice_log_ratio)) + : std::log1p(std::exp(twice_log_ratio)); + + return -log_one_plus_ratio_sq; +} + + +inline double distance_weight( + const double predicted_distance, + const double lambda, + const DistanceKernel kernel) +{ + return std::exp(log_distance_weight( + predicted_distance, + lambda, + kernel + )); +} diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 1664ad6..0cad45d 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -12,8 +12,8 @@ Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // bench_cpp -Rcpp::NumericMatrix bench_cpp(const Rcpp::NumericMatrix& raster_vals, const Rcpp::NumericMatrix& sample_vals, const Rcpp::NumericMatrix& ref_density, const Rcpp::NumericVector& xy_stats, double xy_penalty, bool geographic, double radius_km, int k_env, int k_rs, double bin_width, int bin_num, int offset, double confidence, double lambda, bool exclude_slef, bool make_su, int num_threads); -RcppExport SEXP _ClassicHCAS_bench_cpp(SEXP raster_valsSEXP, SEXP sample_valsSEXP, SEXP ref_densitySEXP, SEXP xy_statsSEXP, SEXP xy_penaltySEXP, SEXP geographicSEXP, SEXP radius_kmSEXP, SEXP k_envSEXP, SEXP k_rsSEXP, SEXP bin_widthSEXP, SEXP bin_numSEXP, SEXP offsetSEXP, SEXP confidenceSEXP, SEXP lambdaSEXP, SEXP exclude_slefSEXP, SEXP make_suSEXP, SEXP num_threadsSEXP) { +Rcpp::NumericMatrix bench_cpp(const Rcpp::NumericMatrix& raster_vals, const Rcpp::NumericMatrix& sample_vals, const Rcpp::NumericMatrix& ref_density, const Rcpp::NumericVector& xy_stats, double xy_penalty, bool geographic, double radius_km, int k_env, int k_rs, double bin_width, int bin_num, int offset, double confidence, double lambda, bool exclude_slef, Rcpp::Nullable temporal_weights, bool make_su, int num_threads, std::string kernel, Rcpp::Nullable boost); +RcppExport SEXP _ClassicHCAS_bench_cpp(SEXP raster_valsSEXP, SEXP sample_valsSEXP, SEXP ref_densitySEXP, SEXP xy_statsSEXP, SEXP xy_penaltySEXP, SEXP geographicSEXP, SEXP radius_kmSEXP, SEXP k_envSEXP, SEXP k_rsSEXP, SEXP bin_widthSEXP, SEXP bin_numSEXP, SEXP offsetSEXP, SEXP confidenceSEXP, SEXP lambdaSEXP, SEXP exclude_slefSEXP, SEXP temporal_weightsSEXP, SEXP make_suSEXP, SEXP num_threadsSEXP, SEXP kernelSEXP, SEXP boostSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -32,9 +32,12 @@ BEGIN_RCPP Rcpp::traits::input_parameter< double >::type confidence(confidenceSEXP); Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP); Rcpp::traits::input_parameter< bool >::type exclude_slef(exclude_slefSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type temporal_weights(temporal_weightsSEXP); Rcpp::traits::input_parameter< bool >::type make_su(make_suSEXP); Rcpp::traits::input_parameter< int >::type num_threads(num_threadsSEXP); - rcpp_result_gen = Rcpp::wrap(bench_cpp(raster_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, confidence, lambda, exclude_slef, make_su, num_threads)); + Rcpp::traits::input_parameter< std::string >::type kernel(kernelSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type boost(boostSEXP); + rcpp_result_gen = Rcpp::wrap(bench_cpp(raster_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, confidence, lambda, exclude_slef, temporal_weights, make_su, num_threads, kernel, boost)); return rcpp_result_gen; END_RCPP } @@ -84,6 +87,35 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// reference_use_cpp +Rcpp::List reference_use_cpp(const Rcpp::NumericMatrix& target_vals, const Rcpp::NumericMatrix& sample_vals, const Rcpp::NumericMatrix& ref_density, const Rcpp::NumericVector& xy_stats, double xy_penalty, bool geographic, double radius_km, int k_env, int k_rs, double bin_width, int bin_num, int offset, double confidence, double lambda, bool exclude_slef, int num_threads, bool weighted_max, std::string kernel, Rcpp::Nullable boost); +RcppExport SEXP _ClassicHCAS_reference_use_cpp(SEXP target_valsSEXP, SEXP sample_valsSEXP, SEXP ref_densitySEXP, SEXP xy_statsSEXP, SEXP xy_penaltySEXP, SEXP geographicSEXP, SEXP radius_kmSEXP, SEXP k_envSEXP, SEXP k_rsSEXP, SEXP bin_widthSEXP, SEXP bin_numSEXP, SEXP offsetSEXP, SEXP confidenceSEXP, SEXP lambdaSEXP, SEXP exclude_slefSEXP, SEXP num_threadsSEXP, SEXP weighted_maxSEXP, SEXP kernelSEXP, SEXP boostSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type target_vals(target_valsSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type sample_vals(sample_valsSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type ref_density(ref_densitySEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type xy_stats(xy_statsSEXP); + Rcpp::traits::input_parameter< double >::type xy_penalty(xy_penaltySEXP); + Rcpp::traits::input_parameter< bool >::type geographic(geographicSEXP); + Rcpp::traits::input_parameter< double >::type radius_km(radius_kmSEXP); + Rcpp::traits::input_parameter< int >::type k_env(k_envSEXP); + Rcpp::traits::input_parameter< int >::type k_rs(k_rsSEXP); + Rcpp::traits::input_parameter< double >::type bin_width(bin_widthSEXP); + Rcpp::traits::input_parameter< int >::type bin_num(bin_numSEXP); + Rcpp::traits::input_parameter< int >::type offset(offsetSEXP); + Rcpp::traits::input_parameter< double >::type confidence(confidenceSEXP); + Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP); + Rcpp::traits::input_parameter< bool >::type exclude_slef(exclude_slefSEXP); + Rcpp::traits::input_parameter< int >::type num_threads(num_threadsSEXP); + Rcpp::traits::input_parameter< bool >::type weighted_max(weighted_maxSEXP); + Rcpp::traits::input_parameter< std::string >::type kernel(kernelSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type boost(boostSEXP); + rcpp_result_gen = Rcpp::wrap(reference_use_cpp(target_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, confidence, lambda, exclude_slef, num_threads, weighted_max, kernel, boost)); + return rcpp_result_gen; +END_RCPP +} // tiling_cpp IntegerMatrix tiling_cpp(const NumericMatrix& x, const int n_tiles, const std::string method, const bool exact); RcppExport SEXP _ClassicHCAS_tiling_cpp(SEXP xSEXP, SEXP n_tilesSEXP, SEXP methodSEXP, SEXP exactSEXP) { @@ -98,13 +130,44 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// variable_importance_cpp +Rcpp::NumericMatrix variable_importance_cpp(const Rcpp::NumericMatrix& target_vals, const Rcpp::NumericMatrix& sample_vals, const Rcpp::NumericMatrix& ref_density, const Rcpp::NumericVector& xy_stats, double xy_penalty, bool geographic, double radius_km, int k_env, int k_rs, double bin_width, int bin_num, int offset, double lambda, double epsilon, std::string output, bool exclude_slef, int num_threads, std::string kernel, Rcpp::Nullable boost); +RcppExport SEXP _ClassicHCAS_variable_importance_cpp(SEXP target_valsSEXP, SEXP sample_valsSEXP, SEXP ref_densitySEXP, SEXP xy_statsSEXP, SEXP xy_penaltySEXP, SEXP geographicSEXP, SEXP radius_kmSEXP, SEXP k_envSEXP, SEXP k_rsSEXP, SEXP bin_widthSEXP, SEXP bin_numSEXP, SEXP offsetSEXP, SEXP lambdaSEXP, SEXP epsilonSEXP, SEXP outputSEXP, SEXP exclude_slefSEXP, SEXP num_threadsSEXP, SEXP kernelSEXP, SEXP boostSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type target_vals(target_valsSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type sample_vals(sample_valsSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericMatrix& >::type ref_density(ref_densitySEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type xy_stats(xy_statsSEXP); + Rcpp::traits::input_parameter< double >::type xy_penalty(xy_penaltySEXP); + Rcpp::traits::input_parameter< bool >::type geographic(geographicSEXP); + Rcpp::traits::input_parameter< double >::type radius_km(radius_kmSEXP); + Rcpp::traits::input_parameter< int >::type k_env(k_envSEXP); + Rcpp::traits::input_parameter< int >::type k_rs(k_rsSEXP); + Rcpp::traits::input_parameter< double >::type bin_width(bin_widthSEXP); + Rcpp::traits::input_parameter< int >::type bin_num(bin_numSEXP); + Rcpp::traits::input_parameter< int >::type offset(offsetSEXP); + Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP); + Rcpp::traits::input_parameter< double >::type epsilon(epsilonSEXP); + Rcpp::traits::input_parameter< std::string >::type output(outputSEXP); + Rcpp::traits::input_parameter< bool >::type exclude_slef(exclude_slefSEXP); + Rcpp::traits::input_parameter< int >::type num_threads(num_threadsSEXP); + Rcpp::traits::input_parameter< std::string >::type kernel(kernelSEXP); + Rcpp::traits::input_parameter< Rcpp::Nullable >::type boost(boostSEXP); + rcpp_result_gen = Rcpp::wrap(variable_importance_cpp(target_vals, sample_vals, ref_density, xy_stats, xy_penalty, geographic, radius_km, k_env, k_rs, bin_width, bin_num, offset, lambda, epsilon, output, exclude_slef, num_threads, kernel, boost)); + return rcpp_result_gen; +END_RCPP +} static const R_CallMethodDef CallEntries[] = { - {"_ClassicHCAS_bench_cpp", (DL_FUNC) &_ClassicHCAS_bench_cpp, 17}, + {"_ClassicHCAS_bench_cpp", (DL_FUNC) &_ClassicHCAS_bench_cpp, 20}, {"_ClassicHCAS_norm_cpp", (DL_FUNC) &_ClassicHCAS_norm_cpp, 3}, {"_ClassicHCAS_radial_count_cpp", (DL_FUNC) &_ClassicHCAS_radial_count_cpp, 5}, {"_ClassicHCAS_ref_density_cpp", (DL_FUNC) &_ClassicHCAS_ref_density_cpp, 8}, + {"_ClassicHCAS_reference_use_cpp", (DL_FUNC) &_ClassicHCAS_reference_use_cpp, 19}, {"_ClassicHCAS_tiling_cpp", (DL_FUNC) &_ClassicHCAS_tiling_cpp, 4}, + {"_ClassicHCAS_variable_importance_cpp", (DL_FUNC) &_ClassicHCAS_variable_importance_cpp, 19}, {NULL, NULL, 0} }; diff --git a/src/ReferenceUse.cpp b/src/ReferenceUse.cpp new file mode 100644 index 0000000..31d268b --- /dev/null +++ b/src/ReferenceUse.cpp @@ -0,0 +1,402 @@ +// [[Rcpp::plugins(openmp)]] +// [[Rcpp::plugins("cpp11")]] +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wignored-attributes" +#endif +#include +#include +#include +#include +#include +#include +#ifdef _OPENMP +#include +#endif +#include "Float32_t.h" +#include "Matrix.h" +#include "Helper.h" + +using namespace Rcpp; + +namespace { + +static constexpr double DEG_2_RAD = M_PI / 180.0; + +int probability_partition( + std::vector& values, + std::vector& order, + int low, + int high) +{ + const double pivot = values[high]; + int i = low - 1; + for (int j = low; j < high; ++j) { + if (values[j] >= pivot) { + i += 1; + std::swap(values[i], values[j]); + std::swap(order[i], order[j]); + } + } + std::swap(values[i + 1], values[high]); + std::swap(order[i + 1], order[high]); + return i + 1; +} + +void probability_quicksort( + std::vector& values, + std::vector& order, + int low, + int high) +{ + if (low >= high) { + return; + } + + const int pivot = probability_partition(values, order, low, high); + probability_quicksort(values, order, low, pivot - 1); + probability_quicksort(values, order, pivot + 1, high); +} + +std::vector descending_probability_order(std::vector& values) +{ + std::vector order(values.size()); + for (size_t i = 0; i < order.size(); ++i) { + order[i] = static_cast(i); + } + if (!values.empty()) { + probability_quicksort( + values, + order, + 0, + static_cast(values.size()) - 1 + ); + } + return order; +} + +} // namespace + + +// [[Rcpp::export]] +Rcpp::List reference_use_cpp( + const Rcpp::NumericMatrix &target_vals, + const Rcpp::NumericMatrix &sample_vals, + const Rcpp::NumericMatrix &ref_density, + const Rcpp::NumericVector &xy_stats, + double xy_penalty = 0.0, + bool geographic = false, + double radius_km = 200, + int k_env = 70, + int k_rs = 10, + double bin_width = 0.05, + int bin_num = 400, + int offset = 0, + double confidence = 0.5, + double lambda = 1.0, + bool exclude_slef = true, + int num_threads = -1, + bool weighted_max = false, + std::string kernel = "gaussian", + Rcpp::Nullable boost = R_NilValue) +{ + double boost_factor = std::numeric_limits::quiet_NaN(); + if (boost.isNotNull()) { + Rcpp::NumericVector boost_value(boost); + if (boost_value.size() != 1) { + Rcpp::stop("'boost' must be NULL, NA, or one finite number greater than zero."); + } + if (!std::isnan(boost_value[0])) { + if (!std::isfinite(boost_value[0]) || boost_value[0] <= 0.0) { + Rcpp::stop("'boost' must be NULL, NA, or one finite number greater than zero."); + } + boost_factor = boost_value[0]; + } + } + if (xy_stats.size() != 4) { + Rcpp::stop("'xy_stats' must contain exactly four values: mean(x), mean(y), sd(x), sd(y)."); + } + if (k_env < 1) { + Rcpp::stop("'k_env' must be >= 1."); + } + if (k_rs < 1 || k_rs > k_env) { + Rcpp::stop("'k_rs' must be between 1 and 'k_env'."); + } + if (bin_num < 2) { + Rcpp::stop("'bin_num' must be >= 2."); + } + if (bin_width <= 0.0) { + Rcpp::stop("'bin_width' must be > 0."); + } + if (confidence < 0.0 || confidence > 1.0) { + Rcpp::stop("'confidence' must be between 0 and 1."); + } + if (!std::isfinite(lambda) || lambda <= 0.0) { + Rcpp::stop("'lambda' must be finite and > 0."); + } + kernel = canonical_distance_kernel(kernel); + if (kernel.empty()) { + Rcpp::stop("'kernel' must be 'Gaussian'/'gaussian' or 'Cauchy'/'cauchy'."); + } + const DistanceKernel kernel_method = + distance_kernel_from_string(kernel); + RowMajorMatrix targets = as_Matrix(target_vals); + RowMajorMatrix samples = as_Matrix(sample_vals); + RowMajorMatrix refdens = as_Matrix(ref_density); + RowMajorMatrix target_xy = get_XY(target_vals); + + const int nr = targets.rows(); + const int ns = samples.rows(); + if (targets.cols() < 4 || (targets.cols() - 2) % 2 != 0) { + Rcpp::stop("'target_vals' must contain x, y, predicted RS, and observed RS columns."); + } + if (samples.cols() != targets.cols()) { + Rcpp::stop("'sample_vals' must have the same columns as 'target_vals'."); + } + + const int nvar = (targets.cols() - 2) / 2; + const int ndim = nvar + 2; + const float32_t binwidth = static_cast(bin_width); + + double scale; + int64_t r2; + const double radius_m = radius_km * 1000.0; + if (geographic) { + scale = 1000000.0; + const double r_deg = radius_m / 111320.0; + const int64_t r_micro = static_cast(r_deg * scale); + r2 = r_micro * r_micro; + } else { + scale = 100.0; + const int64_t r_scaled = static_cast(radius_m * scale); + r2 = r_scaled * r_scaled; + } + + std::vector sample_x(ns), sample_y(ns); + for (int i = 0; i < ns; ++i) { + sample_x[i] = static_cast(samples(i, 0) * scale); + sample_y[i] = static_cast(samples(i, 1) * scale); + } + + const float32_t xypenalty = static_cast(xy_penalty); + std::vector xystats(xy_stats.begin(), xy_stats.end()); + if (xystats[2] == 0.0f || xystats[3] == 0.0f) { + Rcpp::stop("'xy_stats' standard deviations (3rd and 4th elements) must be non-zero."); + } + + samples.col(0) = ((samples.col(0).array() - xystats[0]) / xystats[2]) * xypenalty; + samples.col(1) = ((samples.col(1).array() - xystats[1]) / xystats[3]) * xypenalty; + targets.col(0) = ((targets.col(0).array() - xystats[0]) / xystats[2]) * xypenalty; + targets.col(1) = ((targets.col(1).array() - xystats[1]) / xystats[3]) * xypenalty; + + std::vector predicted_use(ns, 0.0); + std::vector density_use(ns, 0.0); + std::vector condition_use(ns, 0.0); + + #ifdef _OPENMP + if (num_threads < 1) num_threads = omp_get_max_threads(); + omp_set_num_threads(num_threads); + #endif + + #pragma omp parallel for schedule(dynamic) + for (int i = 0; i < nr; ++i) + { + const auto cell_rem = targets.row(i).leftCols(ndim); + const auto cell_obs = targets.row(i).rightCols(nvar); + + if ((cell_obs.array().isNaN()).any()) { + continue; + } + + const int64_t x = static_cast(target_xy(i, 0) * scale); + const int64_t y = static_cast(target_xy(i, 1) * scale); + int64_t cos_scale = 0; + if (geographic) { + cos_scale = static_cast( + std::cos(target_xy(i, 1) * DEG_2_RAD) * 1000000 + ); + } + + std::vector knn_env = combined_Search( + sample_x, sample_y, samples, cell_rem, + x, y, r2, k_env, ndim, cos_scale, geographic + ); + + for (const int site : knn_env) { + #pragma omp atomic update + predicted_use[site] += 1.0; + } + + std::vector candidate_sites; + std::vector predicted_distances; + std::vector probabilities; + candidate_sites.reserve(knn_env.size()); + predicted_distances.reserve(knn_env.size()); + probabilities.reserve(knn_env.size()); + + for (const int site : knn_env) + { + const auto sample_pred = samples.row(site).middleCols(2, nvar); + const float32_t predicted_distance = + (cell_rem.rightCols(nvar) - sample_pred).template lpNorm<1>(); + + if (exclude_slef && predicted_distance < binwidth) { + continue; + } + + const auto sample_obs = samples.row(site).rightCols(nvar); + const float32_t observed_distance = + (cell_obs - sample_obs).template lpNorm<1>(); + const double probability = get_prob_value( + refdens, + predicted_distance, + observed_distance, + binwidth, + bin_num, + offset + ); + + candidate_sites.push_back(site); + predicted_distances.push_back(static_cast(predicted_distance)); + probabilities.push_back(probability); + } + + if (probabilities.empty()) { + continue; + } + + const std::vector order = descending_probability_order(probabilities); + const int n_keep = std::min(k_rs, static_cast(order.size())); + std::vector selected_sites(n_keep); + std::vector selected_distances(n_keep); + std::vector selected_probabilities(n_keep); + + for (int k = 0; k < n_keep; ++k) { + const int candidate = order[k]; + selected_sites[k] = candidate_sites[candidate]; + selected_distances[k] = predicted_distances[candidate]; + selected_probabilities[k] = probabilities[k]; + } + + for (const int site : selected_sites) { + #pragma omp atomic update + density_use[site] += 1.0; + } + + double max_log_weight = -std::numeric_limits::infinity(); + for (const double distance : selected_distances) { + const double log_weight = log_distance_weight( + distance, + lambda, + kernel_method + ); + if (std::isfinite(log_weight)) { + max_log_weight = std::max(max_log_weight, log_weight); + } + } + if (!std::isfinite(max_log_weight)) { + continue; + } + + std::vector distance_weights(n_keep); + std::vector maximum_scores(n_keep); + double weight_sum = 0.0; + double maximum_score = -std::numeric_limits::infinity(); + for (int k = 0; k < n_keep; ++k) { + const double log_weight = log_distance_weight( + selected_distances[k], + lambda, + kernel_method + ); + const double relative_exponent = std::min( + 0.0, + log_weight - max_log_weight + ); + distance_weights[k] = std::exp(relative_exponent); + maximum_scores[k] = weighted_max + ? selected_probabilities[k] * distance_weights[k] + : selected_probabilities[k]; + weight_sum += distance_weights[k]; + maximum_score = std::max(maximum_score, maximum_scores[k]); + } + if (!(weight_sum > 0.0) || !std::isfinite(weight_sum)) { + continue; + } + + if (!std::isnan(boost_factor)) { + const double log_boost = std::log(boost_factor); + double max_boosted_log_weight = + -std::numeric_limits::infinity(); + for (int k = 0; k < n_keep; ++k) { + const double log_weight = log_distance_weight( + selected_distances[k], + lambda, + kernel_method + ); + const double boosted_log_weight = log_weight + + (k == 0 ? log_boost : 0.0); + max_boosted_log_weight = std::max( + max_boosted_log_weight, + boosted_log_weight + ); + } + + double boosted_weight_sum = 0.0; + for (int k = 0; k < n_keep; ++k) { + const double log_weight = log_distance_weight( + selected_distances[k], + lambda, + kernel_method + ); + const double boosted_log_weight = log_weight + + (k == 0 ? log_boost : 0.0); + distance_weights[k] = std::exp(std::min( + 0.0, + boosted_log_weight - max_boosted_log_weight + )); + boosted_weight_sum += distance_weights[k]; + } + if (!(boosted_weight_sum > 0.0) || + !std::isfinite(boosted_weight_sum)) { + continue; + } + + for (int k = 0; k < n_keep; ++k) { + const int site = selected_sites[k]; + const double attribution = + distance_weights[k] / boosted_weight_sum; + #pragma omp atomic update + condition_use[site] += attribution; + } + } else { + int maximum_ties = 0; + for (const double score : maximum_scores) { + if (score == maximum_score) { + maximum_ties += 1; + } + } + + for (int k = 0; k < n_keep; ++k) { + double attribution = + (1.0 - confidence) * distance_weights[k] / weight_sum; + if (maximum_scores[k] == maximum_score) { + attribution += confidence / maximum_ties; + } + + const int site = selected_sites[k]; + #pragma omp atomic update + condition_use[site] += attribution; + } + } + } + + return Rcpp::List::create( + Rcpp::Named("predicted") = Rcpp::wrap(predicted_use), + Rcpp::Named("density") = Rcpp::wrap(density_use), + Rcpp::Named("condition") = Rcpp::wrap(condition_use) + ); +} + +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic pop +#endif diff --git a/src/VariableImportance.cpp b/src/VariableImportance.cpp new file mode 100644 index 0000000..708c1d4 --- /dev/null +++ b/src/VariableImportance.cpp @@ -0,0 +1,397 @@ +// [[Rcpp::plugins(openmp)]] +// [[Rcpp::plugins("cpp11")]] +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wignored-attributes" +#endif +#include +#include +#include +#include +#include +#include +#include +#ifdef _OPENMP +#include +#endif +#include "Float32_t.h" +#include "Matrix.h" +#include "Helper.h" + +using namespace Rcpp; + +namespace { + +static constexpr double DEG_2_RAD = M_PI / 180.0; + +// Descending-probability ordering, identical to the selection used by +// benchmark() and reference_use() so the retained reference set matches. +int probability_partition( + std::vector& values, + std::vector& order, + int low, + int high) +{ + const double pivot = values[high]; + int i = low - 1; + for (int j = low; j < high; ++j) { + if (values[j] >= pivot) { + i += 1; + std::swap(values[i], values[j]); + std::swap(order[i], order[j]); + } + } + std::swap(values[i + 1], values[high]); + std::swap(order[i + 1], order[high]); + return i + 1; +} + +void probability_quicksort( + std::vector& values, + std::vector& order, + int low, + int high) +{ + if (low >= high) { + return; + } + + const int pivot = probability_partition(values, order, low, high); + probability_quicksort(values, order, low, pivot - 1); + probability_quicksort(values, order, pivot + 1, high); +} + +std::vector descending_probability_order(std::vector& values) +{ + std::vector order(values.size()); + for (size_t i = 0; i < order.size(); ++i) { + order[i] = static_cast(i); + } + if (!values.empty()) { + probability_quicksort( + values, + order, + 0, + static_cast(values.size()) - 1 + ); + } + return order; +} + +} // namespace + + +// Per-variable, locally standardised departure attribution. +// +// For each target cell the same three-stage reference selection used by +// benchmark() is run (radius -> k_env nearest in predicted RS + optional XY +// penalty -> k_rs highest reference-density probability). For each retained +// reference site a selected-kernel weight is derived from predicted RS distance, +// exactly as in get_Condition(); when boost is supplied, the maximum-probability +// retained reference's weight is multiplied before normalisation. For every RS +// variable the importance is the signal-to-noise ratio +// +// importance_v = signal_v / (noise_v + epsilon) +// +// where, with normalised distance weights w_k summing to W, +// +// signal_v = sum_k w_k |obs_target,v - obs_ref,k,v| / W +// noise_v = sum_k sum_l w_k w_l |obs_ref,k,v - obs_ref,l,v| / W^2 +// +// i.e. signal is the weighted mean absolute departure of the target from its +// references on variable v, and noise is the weighted mean absolute difference +// among the references themselves on the same variable (a distance-weighted +// Gini mean difference). Both stay in the L1 geometry of the engine, so the +// per-variable signals sum to the weighted total observed departure that the +// reference-density lookup consumes. The output has one row per target cell and +// one column per RS variable; NaN rows mark cells with missing observed values +// or with no usable references. +// [[Rcpp::export]] +Rcpp::NumericMatrix variable_importance_cpp( + const Rcpp::NumericMatrix &target_vals, + const Rcpp::NumericMatrix &sample_vals, + const Rcpp::NumericMatrix &ref_density, + const Rcpp::NumericVector &xy_stats, + double xy_penalty = 0.0, + bool geographic = false, + double radius_km = 200, + int k_env = 70, + int k_rs = 10, + double bin_width = 0.05, + int bin_num = 400, + int offset = 0, + double lambda = 1.0, + double epsilon = 1e-6, + std::string output = "importance", + bool exclude_slef = true, + int num_threads = -1, + std::string kernel = "gaussian", + Rcpp::Nullable boost = R_NilValue) +{ + double boost_factor = std::numeric_limits::quiet_NaN(); + if (boost.isNotNull()) { + Rcpp::NumericVector boost_value(boost); + if (boost_value.size() != 1) { + Rcpp::stop("'boost' must be NULL, NA, or one finite number greater than zero."); + } + if (!std::isnan(boost_value[0])) { + if (!std::isfinite(boost_value[0]) || boost_value[0] <= 0.0) { + Rcpp::stop("'boost' must be NULL, NA, or one finite number greater than zero."); + } + boost_factor = boost_value[0]; + } + } + if (output != "importance" && output != "signal") { + Rcpp::stop("'output' must be 'importance' or 'signal'."); + } + const bool want_signal = (output == "signal"); + if (xy_stats.size() != 4) { + Rcpp::stop("'xy_stats' must contain exactly four values: mean(x), mean(y), sd(x), sd(y)."); + } + if (k_env < 1) { + Rcpp::stop("'k_env' must be >= 1."); + } + if (k_rs < 1 || k_rs > k_env) { + Rcpp::stop("'k_rs' must be between 1 and 'k_env'."); + } + if (bin_num < 2) { + Rcpp::stop("'bin_num' must be >= 2."); + } + if (bin_width <= 0.0) { + Rcpp::stop("'bin_width' must be > 0."); + } + if (!std::isfinite(lambda) || lambda <= 0.0) { + Rcpp::stop("'lambda' must be finite and > 0."); + } + kernel = canonical_distance_kernel(kernel); + if (kernel.empty()) { + Rcpp::stop("'kernel' must be 'Gaussian'/'gaussian' or 'Cauchy'/'cauchy'."); + } + const DistanceKernel kernel_method = + distance_kernel_from_string(kernel); + if (!(epsilon >= 0.0) || !std::isfinite(epsilon)) { + Rcpp::stop("'epsilon' must be a finite, non-negative number."); + } + + RowMajorMatrix targets = as_Matrix(target_vals); + RowMajorMatrix samples = as_Matrix(sample_vals); + RowMajorMatrix refdens = as_Matrix(ref_density); + RowMajorMatrix target_xy = get_XY(target_vals); + + const int nr = targets.rows(); + const int ns = samples.rows(); + if (targets.cols() < 4 || (targets.cols() - 2) % 2 != 0) { + Rcpp::stop("'target_vals' must contain x, y, predicted RS, and observed RS columns."); + } + if (samples.cols() != targets.cols()) { + Rcpp::stop("'sample_vals' must have the same columns as 'target_vals'."); + } + + const int nvar = (targets.cols() - 2) / 2; + const int ndim = nvar + 2; + const int obs_start = 2 + nvar; + const float32_t binwidth = static_cast(bin_width); + + double scale; + int64_t r2; + const double radius_m = radius_km * 1000.0; + if (geographic) { + scale = 1000000.0; + const double r_deg = radius_m / 111320.0; + const int64_t r_micro = static_cast(r_deg * scale); + r2 = r_micro * r_micro; + } else { + scale = 100.0; + const int64_t r_scaled = static_cast(radius_m * scale); + r2 = r_scaled * r_scaled; + } + + std::vector sample_x(ns), sample_y(ns); + for (int i = 0; i < ns; ++i) { + sample_x[i] = static_cast(samples(i, 0) * scale); + sample_y[i] = static_cast(samples(i, 1) * scale); + } + + const float32_t xypenalty = static_cast(xy_penalty); + std::vector xystats(xy_stats.begin(), xy_stats.end()); + if (xystats[2] == 0.0f || xystats[3] == 0.0f) { + Rcpp::stop("'xy_stats' standard deviations (3rd and 4th elements) must be non-zero."); + } + + samples.col(0) = ((samples.col(0).array() - xystats[0]) / xystats[2]) * xypenalty; + samples.col(1) = ((samples.col(1).array() - xystats[1]) / xystats[3]) * xypenalty; + targets.col(0) = ((targets.col(0).array() - xystats[0]) / xystats[2]) * xypenalty; + targets.col(1) = ((targets.col(1).array() - xystats[1]) / xystats[3]) * xypenalty; + + // One row per target cell, one column per RS variable. Filled in parallel + // (each thread owns its own rows) then copied into the R matrix afterwards. + const double NA_VAL = std::numeric_limits::quiet_NaN(); + std::vector importance(static_cast(nr) * nvar, NA_VAL); + + #ifdef _OPENMP + if (num_threads < 1) num_threads = omp_get_max_threads(); + omp_set_num_threads(num_threads); + #endif + + #pragma omp parallel for schedule(dynamic) + for (int i = 0; i < nr; ++i) + { + const auto cell_rem = targets.row(i).leftCols(ndim); + const auto cell_obs = targets.row(i).rightCols(nvar); + + if ((cell_obs.array().isNaN()).any()) { + continue; + } + + const int64_t x = static_cast(target_xy(i, 0) * scale); + const int64_t y = static_cast(target_xy(i, 1) * scale); + int64_t cos_scale = 0; + if (geographic) { + cos_scale = static_cast( + std::cos(target_xy(i, 1) * DEG_2_RAD) * 1000000 + ); + } + + std::vector knn_env = combined_Search( + sample_x, sample_y, samples, cell_rem, + x, y, r2, k_env, ndim, cos_scale, geographic + ); + + std::vector candidate_sites; + std::vector predicted_distances; + std::vector probabilities; + candidate_sites.reserve(knn_env.size()); + predicted_distances.reserve(knn_env.size()); + probabilities.reserve(knn_env.size()); + + for (const int site : knn_env) + { + const auto sample_pred = samples.row(site).middleCols(2, nvar); + const float32_t predicted_distance = + (cell_rem.rightCols(nvar) - sample_pred).template lpNorm<1>(); + + if (exclude_slef && predicted_distance < binwidth) { + continue; + } + + const auto sample_obs = samples.row(site).rightCols(nvar); + const float32_t observed_distance = + (cell_obs - sample_obs).template lpNorm<1>(); + const double probability = get_prob_value( + refdens, + predicted_distance, + observed_distance, + binwidth, + bin_num, + offset + ); + + candidate_sites.push_back(site); + predicted_distances.push_back(static_cast(predicted_distance)); + probabilities.push_back(probability); + } + + if (probabilities.empty()) { + continue; + } + + const std::vector order = descending_probability_order(probabilities); + const int n_keep = std::min(k_rs, static_cast(order.size())); + + // Gather the retained references' distance weights and observed values. + std::vector weights(n_keep); + std::vector ref_obs(static_cast(n_keep) * nvar); + double max_log_weight = -std::numeric_limits::infinity(); + const double log_boost = std::isnan(boost_factor) + ? 0.0 + : std::log(boost_factor); + for (int k = 0; k < n_keep; ++k) { + const int candidate = order[k]; + const double log_weight = log_distance_weight( + predicted_distances[candidate], + lambda, + kernel_method + ) + (k == 0 ? log_boost : 0.0); + if (std::isfinite(log_weight)) { + max_log_weight = std::max(max_log_weight, log_weight); + } + } + if (!std::isfinite(max_log_weight)) { + continue; + } + + double weight_sum = 0.0; + for (int k = 0; k < n_keep; ++k) { + const int candidate = order[k]; + const int site = candidate_sites[candidate]; + const double log_weight = log_distance_weight( + predicted_distances[candidate], + lambda, + kernel_method + ) + (k == 0 ? log_boost : 0.0); + weights[k] = std::exp(std::min( + 0.0, + log_weight - max_log_weight + )); + weight_sum += weights[k]; + for (int v = 0; v < nvar; ++v) { + ref_obs[static_cast(k) * nvar + v] = + static_cast(samples(site, obs_start + v)); + } + } + if (!(weight_sum > 0.0) || !std::isfinite(weight_sum)) { + continue; + } + + const double inv_w = 1.0 / weight_sum; + const double inv_w2 = inv_w * inv_w; + const size_t base = static_cast(i) * nvar; + + for (int v = 0; v < nvar; ++v) { + const double target_v = static_cast(cell_obs(v)); + + // signal: weighted mean absolute departure of target from references + double signal = 0.0; + for (int k = 0; k < n_keep; ++k) { + signal += weights[k] * + std::abs(target_v - ref_obs[static_cast(k) * nvar + v]); + } + signal *= inv_w; + + if (want_signal) { + // raw per-variable departure contribution; per cell these sum + // to the weighted total observed departure feeding the lookup. + importance[base + v] = signal; + continue; + } + + // noise: weighted mean absolute difference among the references + // (distance-weighted Gini mean difference); zero when n_keep == 1. + double noise = 0.0; + for (int k = 0; k < n_keep; ++k) { + const double rkv = ref_obs[static_cast(k) * nvar + v]; + const double wk = weights[k]; + for (int l = k + 1; l < n_keep; ++l) { + noise += wk * weights[l] * + std::abs(rkv - ref_obs[static_cast(l) * nvar + v]); + } + } + noise *= 2.0 * inv_w2; // count ordered pairs (k,l) and (l,k) + + importance[base + v] = signal / (noise + epsilon); + } + } + + Rcpp::NumericMatrix out(nr, nvar); + for (int i = 0; i < nr; ++i) { + const size_t base = static_cast(i) * nvar; + for (int v = 0; v < nvar; ++v) { + out(i, v) = importance[base + v]; + } + } + return out; +} + +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic pop +#endif diff --git a/tests/testthat/test-benchmark-cpp-edgecases.R b/tests/testthat/test-benchmark-cpp-edgecases.R index 126621d..c6d763b 100644 --- a/tests/testthat/test-benchmark-cpp-edgecases.R +++ b/tests/testthat/test-benchmark-cpp-edgecases.R @@ -79,3 +79,210 @@ test_that("bench_cpp supports different reference density bin settings across ca expect_equal(out_1[1, 1], 0.7) expect_equal(out_2[1, 1], 0.2) }) + +test_that("temporal weighting selects a year and retains its weighted probability", { + raster <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix(c(0, 0, 0.25, 0.15, 0.25), nrow = 1) + ref_density <- matrix(0, nrow = 10, ncol = 10) + ref_density[3, 2] <- 0.4 + ref_density[3, 3] <- 0.9 + + output <- ClassicHCAS:::bench_cpp( + raster_vals = raster, + sample_vals = samples, + ref_density = ref_density, + xy_stats = c(0, 0, 1, 1), + radius_km = 1000, + k_env = 1L, + k_rs = 1L, + bin_width = 0.1, + bin_num = 10L, + offset = 0L, + confidence = 0.5, + exclude_slef = FALSE, + temporal_weights = c(1, exp(-4.5)), + make_su = FALSE, + num_threads = 1L + ) + + expected <- 0.4 + expect_equal(output[1, 1], expected) + + weighted_output <- ClassicHCAS:::bench_cpp( + raster_vals = raster, + sample_vals = samples, + ref_density = ref_density, + xy_stats = c(0, 0, 1, 1), + radius_km = 1000, + k_env = 1L, + k_rs = 1L, + bin_width = 0.1, + bin_num = 10L, + offset = 0L, + confidence = 0.5, + exclude_slef = FALSE, + temporal_weights = c(exp(-0.5), exp(-2)), + make_su = FALSE, + num_threads = 1L + ) + + expect_equal(weighted_output[1, 1], expected * exp(-0.5)) +}) + +test_that("bench_cpp blends the unweighted maximum probability", { + raster <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 0, + 0, 0, 2, 0 + ), + ncol = 4, + byrow = TRUE + ) + ref_density <- matrix(0, nrow = 10, ncol = 10) + ref_density[2, 1] <- 0.8 + ref_density[3, 1] <- 1.0 + + output <- ClassicHCAS:::bench_cpp( + raster_vals = raster, + sample_vals = samples, + ref_density = ref_density, + xy_stats = c(0, 0, 1, 1), + radius_km = 1000, + k_env = 2L, + k_rs = 2L, + bin_width = 1, + bin_num = 10L, + offset = 0L, + confidence = 0.5, + lambda = 2, + exclude_slef = FALSE, + make_su = TRUE, + num_threads = 1L, + boost = NULL + ) + + weights <- exp(-(c(1, 2) / 2)^2) + probabilities <- c(0.8, 1.0) + expected_mean <- sum(probabilities * weights) / sum(weights) + expected_condition <- + 0.5 * max(probabilities) + 0.5 * expected_mean + + expect_equal(output[1, 1], expected_condition, tolerance = 1e-12) + expect_equal(output[1, 2], log(sum(weights)), tolerance = 1e-12) +}) + +test_that("bench_cpp boosts the maximum-probability site's kernel weight", { + raster <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 0, + 0, 0, 2, 0 + ), + ncol = 4, + byrow = TRUE + ) + ref_density <- matrix(0, nrow = 10, ncol = 10) + ref_density[2, 1] <- 0.8 + ref_density[3, 1] <- 1.0 + + output <- ClassicHCAS:::bench_cpp( + raster_vals = raster, + sample_vals = samples, + ref_density = ref_density, + xy_stats = c(0, 0, 1, 1), + radius_km = 1000, + k_env = 2L, + k_rs = 2L, + bin_width = 1, + bin_num = 10L, + offset = 0L, + confidence = 0.9, + lambda = 2, + exclude_slef = FALSE, + make_su = TRUE, + num_threads = 1L, + boost = 4 + ) + + weights <- exp(-(c(1, 2) / 2)^2) + probabilities <- c(0.8, 1.0) + expected <- ( + weights[1] * probabilities[1] + + 4 * weights[2] * probabilities[2] + ) / (weights[1] + 4 * weights[2]) + + expect_equal(output[1, 1], expected, tolerance = 1e-12) + expect_equal(output[1, 2], log(sum(weights)), tolerance = 1e-12) +}) + +test_that("bench_cpp stabilises weights and returns support in log space", { + raster <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix(c(0, 0, 100, 0), nrow = 1) + ref_density <- matrix(0.4, nrow = 10, ncol = 10) + + output <- ClassicHCAS:::bench_cpp( + raster_vals = raster, + sample_vals = samples, + ref_density = ref_density, + xy_stats = c(0, 0, 1, 1), + radius_km = 1000, + k_env = 1L, + k_rs = 1L, + bin_width = 100, + bin_num = 10L, + offset = 0L, + confidence = 0.5, + lambda = 1, + exclude_slef = FALSE, + make_su = TRUE, + num_threads = 1L + ) + + expect_equal(output[1, 1], 0.4, tolerance = 1e-12) + expect_equal(output[1, 2], -10000, tolerance = 1e-12) +}) + +test_that("bench_cpp supports Cauchy weighting", { + raster <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 0, + 0, 0, 2, 0 + ), + ncol = 4, + byrow = TRUE + ) + ref_density <- matrix(0, nrow = 10, ncol = 10) + ref_density[2, 1] <- 0.8 + ref_density[3, 1] <- 1.0 + + output <- ClassicHCAS:::bench_cpp( + raster_vals = raster, + sample_vals = samples, + ref_density = ref_density, + xy_stats = c(0, 0, 1, 1), + radius_km = 1000, + k_env = 2L, + k_rs = 2L, + bin_width = 1, + bin_num = 10L, + offset = 0L, + confidence = 0.5, + lambda = 1, + exclude_slef = FALSE, + make_su = TRUE, + num_threads = 1L, + kernel = "cauchy", + boost = NULL + ) + + distances <- c(1, 2) + probabilities <- c(0.8, 1.0) + weights <- 1 / (1 + distances^2 / 1^2) + expected_mean <- sum(probabilities * weights) / sum(weights) + expected_condition <- 0.5 * max(probabilities) + 0.5 * expected_mean + + expect_equal(output[1, 1], expected_condition, tolerance = 1e-12) + expect_equal(output[1, 2], log(sum(weights)), tolerance = 1e-12) +}) diff --git a/tests/testthat/test-benchmark-wrapper.R b/tests/testthat/test-benchmark-wrapper.R index a4a4d69..cc3822e 100644 --- a/tests/testthat/test-benchmark-wrapper.R +++ b/tests/testthat/test-benchmark-wrapper.R @@ -31,8 +31,8 @@ test_that("benchmark uses reference density attributes when they are not supplie samples = samples, ref_density = ref_norm, radius_km = 1000, - k_pred = 2, - k_obs = 1, + k1 = 2, + k2 = 1, bin_width = NULL, offset = NULL, interpolate = FALSE, @@ -44,6 +44,73 @@ test_that("benchmark uses reference density attributes when they are not supplie expect_true(all(is.finite(out[, 1]))) }) +test_that("benchmark accepts named temporal sample matrices", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + sample_2000 <- matrix(c(0, 0, 0.25, 0.15), nrow = 1) + sample_2003 <- matrix(c(0, 0, 0.25, 0.25), nrow = 1) + samples <- list(`2003` = sample_2003, `2000` = sample_2000) + + ref_density <- matrix(0, nrow = 10, ncol = 10) + ref_density[3, 2] <- 0.4 + ref_density[3, 3] <- 0.9 + + output <- benchmark( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 1, + k2 = 1, + bin_width = 0.1, + interpolate = FALSE, + exclude_slef = FALSE, + assessment_year = 2000, + temporal_sigma = 1, + num_threads = 1 + ) + + expected <- 0.4 + expect_equal(unname(output[1, 1]), expected) + + weighted_output <- benchmark( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 1, + k2 = 1, + bin_width = 0.1, + interpolate = FALSE, + exclude_slef = FALSE, + assessment_year = 2001, + temporal_sigma = 1, + num_threads = 1 + ) + + expect_equal(unname(weighted_output[1, 1]), expected * exp(-0.5)) +}) + +test_that("temporal samples require constant predicted values", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- list( + `2000` = matrix(c(0, 0, 0.25, 0.15), nrow = 1), + `2001` = matrix(c(0, 0, 0.30, 0.15), nrow = 1) + ) + + expect_error( + benchmark( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 10, ncol = 10), + bin_width = 0.1, + interpolate = FALSE, + assessment_year = 2000, + temporal_sigma = 1 + ), + "Predicted RS values must be constant" + ) +}) + test_that("benchmark interpolates reference_density objects", { skip_if_not_installed("terra") @@ -77,8 +144,8 @@ test_that("benchmark interpolates reference_density objects", { samples = samples, ref_density = ref_norm, radius_km = 1000, - k_pred = 2, - k_obs = 1, + k1 = 2, + k2 = 1, bin_width = NULL, offset = NULL, interpolate = TRUE, @@ -89,3 +156,178 @@ test_that("benchmark interpolates reference_density objects", { expect_equal(dim(out), c(2, 1)) expect_true(all(is.finite(out[, 1]))) }) +test_that("public filter arguments are named k1 and k2", { + public_functions <- list(benchmark, reference_use, variable_importance) + + for (fun in public_functions) { + arguments <- names(formals(fun)) + expect_true(all(c("k1", "k2") %in% arguments)) + expect_false(any(c("k_pred", "k_obs") %in% arguments)) + } + + expect_error( + benchmark(NULL, NULL, NULL, k_pred = 1), + "were renamed to 'k1' and 'k2'", + fixed = TRUE + ) + expect_error( + variable_importance(NULL, NULL, NULL, k_obs = 1), + "were renamed to 'k1' and 'k2'", + fixed = TRUE + ) +}) + +test_that("kernel bandwidth defaults to lambda one", { + public_functions <- list( + benchmark, + reference_use, + variable_importance, + hcas_inspection + ) + + for (fun in public_functions) { + expect_identical(formals(fun)$lambda, 1.0) + } + + expect_identical(formals(ClassicHCAS:::bench_cpp)$lambda, 1.0) + expect_identical(formals(ClassicHCAS:::reference_use_cpp)$lambda, 1.0) + expect_identical(formals(ClassicHCAS:::variable_importance_cpp)$lambda, 1.0) +}) + +test_that("benchmark uses the unweighted maximum without a public flag", { + expect_false("weighted_max" %in% names(formals(benchmark))) + expect_false("weighted_max" %in% names(formals(ClassicHCAS:::bench_cpp))) + expect_identical(formals(reference_use)$weighted_max, FALSE) + expect_identical(formals(ClassicHCAS:::reference_use_cpp)$weighted_max, FALSE) + expect_false("weighted_max" %in% names(formals(hcas_inspection))) + + expect_error( + benchmark(NULL, NULL, NULL, weighted_max = NA), + "'weighted_max' is not an argument to benchmark().", + fixed = TRUE + ) +}) + +test_that("public boost defaults require a positive finite factor", { + public_functions <- list( + benchmark, + reference_use, + variable_importance, + hcas_inspection + ) + for (fun in public_functions) { + expect_identical(formals(fun)$k1, 70) + expect_identical(formals(fun)$k2, 10) + expect_identical(formals(fun)$boost, quote(k2)) + } + expect_identical(formals(ClassicHCAS:::bench_cpp)$k_env, 70L) + expect_identical(formals(ClassicHCAS:::bench_cpp)$k_rs, 10L) + expect_identical(formals(ClassicHCAS:::reference_use_cpp)$k_env, 70L) + expect_identical(formals(ClassicHCAS:::reference_use_cpp)$k_rs, 10L) + expect_identical(formals(ClassicHCAS:::variable_importance_cpp)$k_env, 70L) + expect_identical(formals(ClassicHCAS:::variable_importance_cpp)$k_rs, 10L) + expect_true("boost" %in% names(formals(ClassicHCAS:::bench_cpp))) + expect_true("boost" %in% names(formals(ClassicHCAS:::reference_use_cpp))) + expect_true("boost" %in% names(formals(ClassicHCAS:::variable_importance_cpp))) + expect_null(ClassicHCAS:::.check_boost(NULL)) + expect_null(ClassicHCAS:::.check_boost(NA_real_)) + + expect_error( + benchmark(NULL, NULL, NULL, boost = 0), + "'boost' must be NULL, NA, or one finite number greater than zero.", + fixed = TRUE + ) + expect_error( + reference_use(NULL, NULL, NULL, boost = Inf), + "'boost' must be NULL, NA, or one finite number greater than zero.", + fixed = TRUE + ) + expect_error( + variable_importance(NULL, NULL, NULL, boost = 0), + "'boost' must be NULL, NA, or one finite number greater than zero.", + fixed = TRUE + ) +}) + +test_that("Gaussian kernel is the default", { + public_functions <- list( + benchmark, + reference_use, + variable_importance, + hcas_inspection + ) + for (fun in public_functions) { + expect_identical( + eval(formals(fun)$kernel), + c("Gaussian", "Cauchy") + ) + } + + expect_identical(formals(ClassicHCAS:::bench_cpp)$kernel, "gaussian") + expect_identical( + formals(ClassicHCAS:::reference_use_cpp)$kernel, + "gaussian" + ) + expect_identical( + formals(ClassicHCAS:::variable_importance_cpp)$kernel, + "gaussian" + ) + expect_identical(ClassicHCAS:::.check_kernel("Gaussian"), "gaussian") + expect_identical(ClassicHCAS:::.check_kernel("cauchy"), "cauchy") + + expect_error( + benchmark(NULL, NULL, NULL, kernel = "invalid"), + "'kernel' must be 'Gaussian'/'gaussian' or 'Cauchy'/'cauchy'.", + fixed = TRUE + ) +}) + +test_that("temporal_sigma controls the experimental temporal mode", { + arguments <- formals(benchmark) + expect_false("temporal_correct" %in% names(arguments)) + expect_null(arguments$temporal_sigma) + expect_false("temporal_weighted" %in% names(arguments)) + expect_false("temporal_weighted" %in% names(formals(ClassicHCAS:::bench_cpp))) + + target <- matrix(c(0, 0, 0.25, 0.15), nrow = 1) + samples <- matrix(c(0, 0, 0.25, 0.15), nrow = 1) + ref_density <- matrix(1, nrow = 10, ncol = 10) + + default_output <- benchmark( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 1, + k2 = 1, + bin_width = 0.1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + na_output <- benchmark( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 1, + k2 = 1, + bin_width = 0.1, + interpolate = FALSE, + exclude_slef = FALSE, + temporal_sigma = NA, + num_threads = 1 + ) + + expect_equal(na_output, default_output) + expect_error( + benchmark(NULL, NULL, NULL, temporal_correct = TRUE), + "'temporal_correct' has been removed", + fixed = TRUE + ) + expect_error( + benchmark(NULL, NULL, NULL, temporal_weighted = NA), + "'temporal_weighted' has been removed", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-drop-features.R b/tests/testthat/test-drop-features.R index 8f1eb2b..cc63551 100644 --- a/tests/testthat/test-drop-features.R +++ b/tests/testthat/test-drop-features.R @@ -67,8 +67,8 @@ test_that("benchmark drop_features matches manual feature removal", { samples = samples_full, ref_density = unclass(ref_drop), radius_km = 1000, - k_pred = 2, - k_obs = 1, + k1 = 2, + k2 = 1, bin_width = 0.1, offset = 0, interpolate = FALSE, @@ -80,8 +80,8 @@ test_that("benchmark drop_features matches manual feature removal", { samples = samples_reduced, ref_density = unclass(ref_reduced), radius_km = 1000, - k_pred = 2, - k_obs = 1, + k1 = 2, + k2 = 1, bin_width = 0.1, offset = 0, interpolate = FALSE, diff --git a/tests/testthat/test-hcas-inspection.R b/tests/testthat/test-hcas-inspection.R new file mode 100644 index 0000000..69b04ab --- /dev/null +++ b/tests/testthat/test-hcas-inspection.R @@ -0,0 +1,240 @@ +test_that("hcas_inspection builds a Shiny application", { + skip_if_not_installed("shiny") + skip_if_not_installed("shinyWidgets") + skip_if_not_installed("leaflet") + skip_if_not_installed("ggplot2") + + samples <- matrix( + c( + 150.0, -35.0, 0.1, 0.1, + 150.1, -35.0, 0.2, 0.2, + 150.2, -35.0, 0.3, 0.3 + ), + ncol = 4, + byrow = TRUE + ) + density <- matrix(1, nrow = 10, ncol = 10) + class(density) <- c("reference_density", "matrix", "array") + attr(density, "bin.width") <- 0.1 + attr(density, "offset") <- 0L + + app <- hcas_inspection( + data = samples, + samples = samples, + ref_density = density, + radius_km = 100, + k1 = 2, + k2 = 1, + interpolate = FALSE, + launch = FALSE + ) + + expect_s3_class(app, "shiny.appobj") +}) + +test_that("hcas_inspection builds with raster data and xy-only samples", { + skip_if_not_installed("terra") + skip_if_not_installed("shiny") + skip_if_not_installed("shinyWidgets") + skip_if_not_installed("leaflet") + skip_if_not_installed("ggplot2") + + raster <- terra::rast( + nrows = 1, + ncols = 3, + xmin = 150, + xmax = 150.3, + ymin = -35.1, + ymax = -35.0, + nlyrs = 2, + crs = "EPSG:4326" + ) + terra::values(raster) <- cbind(c(0.1, 0.2, 0.3), c(0.1, 0.2, 0.3)) + samples_xy <- terra::xyFromCell(raster, 1:3) + density <- matrix(1, nrow = 10, ncol = 10) + class(density) <- c("reference_density", "matrix", "array") + attr(density, "bin.width") <- 0.1 + attr(density, "offset") <- 0L + + app <- hcas_inspection( + data = raster, + samples = samples_xy, + ref_density = density, + radius_km = 100, + k1 = 2, + k2 = 1, + interpolate = FALSE, + launch = FALSE + ) + + expect_s3_class(app, "shiny.appobj") +}) + +test_that("hcas_inspection uses explicit CRS over non-transformable raster CRS", { + skip_if_not_installed("terra") + skip_if_not_installed("shiny") + skip_if_not_installed("shinyWidgets") + skip_if_not_installed("leaflet") + skip_if_not_installed("ggplot2") + + raster <- terra::rast( + nrows = 1, + ncols = 1, + xmin = -1920015, + xmax = -1919565, + ymin = -4896135, + ymax = -4895685, + nlyrs = 2 + ) + terra::values(raster) <- matrix(c(0.1, 0.1), nrow = 1) + terra::crs(raster) <- paste0( + "ENGCRS[\"GDA94 / Australian Albers\",", + "EDATUM[\"Unknown engineering datum\"],", + "CS[Cartesian,2],", + "AXIS[\"Easting (E)\",east,ORDER[1],LENGTHUNIT[\"metre\",1]],", + "AXIS[\"Northing (N)\",north,ORDER[2],LENGTHUNIT[\"metre\",1]]]" + ) + samples <- cbind( + terra::xyFromCell(raster, 1), + matrix(c(0.1, 0.1), nrow = 1) + ) + density <- matrix(1, nrow = 10, ncol = 10) + class(density) <- c("reference_density", "matrix", "array") + attr(density, "bin.width") <- 0.1 + attr(density, "offset") <- 0L + + app <- hcas_inspection( + data = raster, + samples = samples, + ref_density = density, + radius_km = 100, + k1 = 1, + k2 = 1, + interpolate = FALSE, + crs = "EPSG:3577", + launch = FALSE + ) + + expect_s3_class(app, "shiny.appobj") +}) + +test_that("inspection raster target snaps coordinates to cell centre", { + skip_if_not_installed("terra") + + raster <- terra::rast( + nrows = 2, + ncols = 2, + xmin = 0, + xmax = 2, + ymin = 0, + ymax = 2, + nlyrs = 2, + crs = "EPSG:4326" + ) + terra::values(raster) <- cbind(1:4, 5:8) + + target <- ClassicHCAS:::.inspection_raster_target(raster, 1.8, 0.2) + + expect_equal( + unname(target[1, 1:2]), + unname(as.numeric(terra::xyFromCell(raster, 4))) + ) + expect_equal(unname(target[1, 3:4]), c(4, 8)) +}) + +test_that("inspection raster default target is the extent centre", { + skip_if_not_installed("terra") + + raster <- terra::rast( + nrows = 2, + ncols = 2, + xmin = 0, + xmax = 2, + ymin = 0, + ymax = 2, + nlyrs = 2, + crs = "EPSG:4326" + ) + # The centre need not fall on a populated cell; every cell here is empty. + terra::values(raster) <- NA + + xy <- ClassicHCAS:::.inspection_raster_default_xy(raster) + + expect_equal(unname(xy), c(1, 1)) +}) + +test_that("inspection point evaluates an extracted raster target", { + skip_if_not_installed("terra") + + raster <- terra::rast( + nrows = 1, + ncols = 3, + xmin = 150, + xmax = 150.3, + ymin = -35.1, + ymax = -35.0, + nlyrs = 2, + crs = "EPSG:4326" + ) + terra::values(raster) <- cbind(c(0.1, 0.2, 0.3), c(0.1, 0.2, 0.3)) + samples <- cbind( + terra::xyFromCell(raster, 1:3), + terra::values(raster, mat = TRUE) + ) + target <- ClassicHCAS:::.inspection_raster_target(raster, 150.21, -35.05) + + result <- ClassicHCAS:::.inspection_point( + target = target, + samples = samples, + ref_density = matrix(1, nrow = 10, ncol = 10), + xy_stats = c(0, 0, 1, 1), + xy_penalty = 0, + radius_km = 100, + k1 = 2, + k2 = 1, + bin_width = 0.1, + offset = 0L, + confidence = 0.5, + boost = 10, + lambda = 1, + exclude_slef = FALSE, + drop_features = NULL, + num_threads = 1, + kernel = "gaussian", + geographic = TRUE, + crs = NULL + ) + + expect_true(is.finite(result$condition)) + expect_s3_class(result$nearby, "data.frame") + expect_s3_class(result$selected, "data.frame") + expect_equal( + unname(unlist(result$target[1, c("x", "y")])), + unname(target[1, 1:2]) + ) +}) + +test_that("inspection raster click coordinates snap to raster cell centre", { + skip_if_not_installed("terra") + + raster <- terra::rast( + nrows = 2, + ncols = 2, + xmin = 145, + xmax = 147, + ymin = -40, + ymax = -38, + nlyrs = 2, + crs = "EPSG:4326" + ) + terra::values(raster) <- 1 + + xy <- ClassicHCAS:::.inspection_raster_click_xy( + raster, + lng = 146.8, + lat = -39.8, + crs = terra::crs(raster) + ) + + expect_equal(unname(xy), unname(as.numeric(terra::xyFromCell(raster, 4)))) +}) diff --git a/tests/testthat/test-reference-use.R b/tests/testthat/test-reference-use.R new file mode 100644 index 0000000..62f4ce2 --- /dev/null +++ b/tests/testthat/test-reference-use.R @@ -0,0 +1,247 @@ +test_that("reference_use returns all stages in sample-row order", { + target <- matrix( + c( + 0, 0, 0, 0, + 0, 0, 10, 0 + ), + ncol = 4, + byrow = TRUE + ) + samples <- matrix( + c( + 0, 0, 1, 0, + 0, 0, 2, 0, + 0, 0, 9, 0 + ), + ncol = 4, + byrow = TRUE + ) + + output <- reference_use( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 1, + bin_width = 1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + + expect_identical(names(output), c("id", "predicted", "density", "condition")) + expect_equal(nrow(output), nrow(samples)) + expect_equal(output$id, 1:3) + expect_equal(output$predicted, c(1, 2, 1)) + expect_equal(sum(output$density), 2) + expect_equal(sum(output$condition), 2) +}) + +test_that("reference_use records reference-density selection", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 1, + 0, 0, 2, 0, + 0, 0, 9, 0 + ), + ncol = 4, + byrow = TRUE + ) + ref_density <- matrix(0, nrow = 20, ncol = 20) + ref_density[2, 2] <- 0.2 + ref_density[3, 1] <- 0.9 + + output <- reference_use( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 2, + k2 = 1, + bin_width = 1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + + expect_equal(output$predicted, c(1, 1, 0)) + expect_equal(output$density, c(0, 1, 0)) + expect_equal(output$condition, c(0, 1, 0)) +}) + +test_that("condition use optionally applies weighted-maximum attribution", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 0, + 0, 0, 2, 0 + ), + ncol = 4, + byrow = TRUE + ) + + output <- reference_use( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + confidence = 0.5, + lambda = 2, + exclude_slef = FALSE, + num_threads = 1, + weighted_max = TRUE, + boost = NULL + ) + + expect_equal(output$predicted, c(1, 1)) + expect_equal(output$density, c(1, 1)) + weights <- exp(-(c(1, 2) / 2)^2) + expected <- c(0.5, 0) + 0.5 * weights / sum(weights) + expect_equal(output$condition, expected, tolerance = 1e-12) + expect_equal(sum(output$condition), 1) +}) + +test_that("condition use attributes boosted kernel weights", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 0, + 0, 0, 2, 0 + ), + ncol = 4, + byrow = TRUE + ) + ref_density <- matrix(0, nrow = 20, ncol = 20) + ref_density[2, 1] <- 0.8 + ref_density[3, 1] <- 1.0 + + output <- reference_use( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + confidence = 0.9, + boost = 4, + lambda = 1, + exclude_slef = FALSE, + num_threads = 1, + weighted_max = TRUE + ) + + weights <- exp(-(c(1, 2)^2)) + expected <- c(weights[1], 4 * weights[2]) + expected <- expected / sum(expected) + + expect_equal(output$condition, expected, tolerance = 1e-12) + expect_equal(sum(output$condition), 1) +}) + +test_that("reference_use raster processing matches matrix processing", { + skip_if_not_installed("terra") + + raster <- terra::rast( + nrows = 1, + ncols = 2, + xmin = 0, + xmax = 2, + ymin = 0, + ymax = 1, + nlyrs = 2 + ) + terra::values(raster) <- cbind(c(0, 10), c(0, 0)) + target <- cbind( + terra::xyFromCell(raster, 1:2), + terra::values(raster, mat = TRUE) + ) + samples <- matrix( + c( + 0.5, 0.5, 1, 0, + 0.5, 0.5, 2, 0, + 0.5, 0.5, 9, 0 + ), + ncol = 4, + byrow = TRUE + ) + args <- list( + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 1, + bin_width = 1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + + matrix_output <- do.call(reference_use, c(list(data = target), args)) + raster_output <- do.call(reference_use, c(list(data = raster), args)) + + expect_equal(raster_output, matrix_output) +}) + +test_that("reference_use rejects temporal sample lists", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- list(`2000` = target, `2001` = target) + + expect_error( + reference_use( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 10, ncol = 10), + bin_width = 0.1, + interpolate = FALSE + ), + "Temporal sample lists are not supported" + ) +}) + +test_that("reference_use aggregation is thread-consistent", { + target <- cbind( + x = rep(0, 20), + y = rep(0, 20), + predicted = seq(0, 1, length.out = 20), + observed = seq(1, 0, length.out = 20) + ) + samples <- cbind( + x = rep(0, 8), + y = rep(0, 8), + predicted = seq(0, 1, length.out = 8), + observed = seq(1, 0, length.out = 8) + ) + args <- list( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 5, + k2 = 3, + bin_width = 0.1, + interpolate = FALSE, + confidence = 0.4, + lambda = 2, + exclude_slef = FALSE + ) + + single_thread <- do.call(reference_use, c(args, list(num_threads = 1))) + two_threads <- do.call(reference_use, c(args, list(num_threads = 2))) + + expect_equal(two_threads$id, single_thread$id) + expect_equal(two_threads$predicted, single_thread$predicted) + expect_equal(two_threads$density, single_thread$density) + expect_equal( + two_threads$condition, + single_thread$condition, + tolerance = 1e-12 + ) +}) diff --git a/tests/testthat/test-variable-importance.R b/tests/testthat/test-variable-importance.R new file mode 100644 index 0000000..15fb342 --- /dev/null +++ b/tests/testthat/test-variable-importance.R @@ -0,0 +1,542 @@ +# Independent R reference implementation of the per-variable metric, evaluated +# over a known selected reference set. Used to check the C++ engine. +.gaussian <- function(d, lambda) { + exp(-(pmax(d, 0) / lambda)^2) +} + +# t_obs: length-nvar observed target vector +# r_obs: n_ref x nvar matrix of observed reference values +# pd: length-n_ref predicted distances of those references to the target +.expected_importance <- function(t_obs, r_obs, pd, lambda = 2, eps = 1e-6, + boost = NULL) { + w <- .gaussian(pd, lambda) + if (!is.null(boost) && !is.na(boost)) { + w[1] <- w[1] * boost + } + W <- sum(w) + vapply( + seq_len(ncol(r_obs)), + function(v) { + r <- r_obs[, v] + signal <- sum(w * abs(t_obs[v] - r)) / W + noise <- sum(outer(w, w) * abs(outer(r, r, "-"))) / W^2 + signal / (noise + eps) + }, + numeric(1) + ) +} + + +test_that("single variable, equal Gaussian weights matches signal/noise", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 2, + 0, 0, 1, 4 + ), + ncol = 4, + byrow = TRUE + ) + + out <- variable_importance( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + lambda = 2, + epsilon = 0, + exclude_slef = FALSE, + num_threads = 1, + boost = NULL + ) + + # signal = (|0-2|+|0-4|)/2 = 3 ; noise = |2-4|/2 = 1 ; importance = 3 + expect_equal(dim(out), c(1L, 1L)) + expect_equal(unname(out[1, 1]), 3, tolerance = 1e-5) +}) + + +test_that("unequal predicted distances apply Gaussian weighting", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 2, + 0, 0, 2, 4 + ), + ncol = 4, + byrow = TRUE + ) + + out <- variable_importance( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + lambda = 2, + epsilon = 0, + exclude_slef = FALSE, + num_threads = 1, + boost = NULL + ) + + expected <- .expected_importance( + t_obs = 0, + r_obs = matrix(c(2, 4), ncol = 1), + pd = c(1, 2), + lambda = 2, + eps = 0 + ) + expect_equal(unname(out[1, 1]), expected, tolerance = 1e-5) +}) + + +test_that("default boost weights the maximum-probability retained reference", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 2, + 0, 0, 2, 4 + ), + ncol = 4, + byrow = TRUE + ) + ref_density <- matrix(0, nrow = 20, ncol = 20) + ref_density[2, 3] <- 0.8 + ref_density[3, 5] <- 1.0 + + out <- variable_importance( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + lambda = 1, + epsilon = 0, + exclude_slef = FALSE, + num_threads = 1 + ) + unboosted <- variable_importance( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + lambda = 1, + epsilon = 0, + exclude_slef = FALSE, + num_threads = 1, + boost = NULL + ) + + expected <- .expected_importance( + t_obs = 0, + r_obs = matrix(c(4, 2), ncol = 1), + pd = c(2, 1), + lambda = 1, + eps = 0, + boost = 2 + ) + + expect_equal(unname(out[1, 1]), expected, tolerance = 1e-5) + expect_false(isTRUE(all.equal(out, unboosted, tolerance = 1e-5))) +}) + + +# weighted absolute departure of target from references (the signal numerator) +.expected_signal <- function(t_obs, r_obs, pd, lambda = 2, boost = NULL) { + w <- .gaussian(pd, lambda) + if (!is.null(boost) && !is.na(boost)) { + w[1] <- w[1] * boost + } + W <- sum(w) + vapply( + seq_len(ncol(r_obs)), + function(v) sum(w * abs(t_obs[v] - r_obs[, v])) / W, + numeric(1) + ) +} + + +test_that("output='signal' returns raw departure contributions and 'share' partitions them", { + target <- matrix(c(0, 0, 0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 0.5, 0.0, 0.2, 1.0, + 0, 0, 0.0, 0.5, 0.4, 2.0, + 0, 0, 0.5, 0.5, 0.6, 5.0 + ), + ncol = 6, + byrow = TRUE + ) + args <- list( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 40, ncol = 40), + radius_km = 1000, + k1 = 3, + k2 = 3, + bin_width = 0.5, + interpolate = FALSE, + lambda = 2, + exclude_slef = FALSE, + num_threads = 1, + boost = NULL + ) + + pd <- rowSums(abs(samples[, 3:4, drop = FALSE])) + obs <- samples[, 5:6, drop = FALSE] + expected_signal <- .expected_signal(c(0, 0), obs, pd, 2) + + sig <- do.call(variable_importance, c(args, list(output = "signal"))) + expect_equal(as.numeric(sig[1, ]), expected_signal, tolerance = 1e-4) + + shr <- do.call(variable_importance, c(args, list(output = "share"))) + expect_equal(sum(shr[1, ]), 1, tolerance = 1e-5) + expect_equal( + as.numeric(shr[1, ]), + expected_signal / sum(expected_signal), + tolerance = 1e-4 + ) +}) + + +test_that("output='share' raster layers sum to one per cell", { + skip_if_not_installed("terra") + + r <- terra::rast(nrows = 5, ncols = 5, nlyrs = 4, xmin = 0, xmax = 5, + ymin = 0, ymax = 5) + set.seed(42) + terra::values(r) <- matrix(runif(terra::ncell(r) * 4), ncol = 4) + s <- cbind(x = runif(30, 0, 5), y = runif(30, 0, 5), + p1 = runif(30), p2 = runif(30), + o1 = runif(30), o2 = runif(30)) + + shr <- variable_importance(r, s, matrix(1, 20, 20), radius_km = 2000, + k1 = 10, k2 = 5, bin_width = 0.1, + interpolate = FALSE, output = "share", + num_threads = 1) + cell_sums <- terra::values(terra::app(shr, "sum")) + cell_sums <- cell_sums[is.finite(cell_sums)] + expect_true(all(abs(cell_sums - 1) < 1e-5)) +}) + + +test_that("multivariable importance matches the reference implementation", { + # columns: x, y, pred1, pred2, obs1, obs2 + target <- matrix(c(0, 0, 0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 0.5, 0.0, 0.2, 1.0, + 0, 0, 0.0, 0.5, 0.4, 2.0, + 0, 0, 0.5, 0.5, 0.6, 5.0 + ), + ncol = 6, + byrow = TRUE + ) + + out <- variable_importance( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 40, ncol = 40), + radius_km = 1000, + k1 = 3, + k2 = 3, + bin_width = 0.5, + interpolate = FALSE, + lambda = 2, + epsilon = 1e-6, + exclude_slef = FALSE, + num_threads = 1, + boost = NULL + ) + + pred <- samples[, 3:4, drop = FALSE] + obs <- samples[, 5:6, drop = FALSE] + pd <- rowSums(abs(pred)) # target predicted is (0, 0) + expected <- .expected_importance( + t_obs = c(0, 0), + r_obs = obs, + pd = pd, + lambda = 2, + eps = 1e-6 + ) + + expect_equal(dim(out), c(1L, 2L)) + expect_equal(as.numeric(out[1, ]), expected, tolerance = 1e-4) +}) + + +test_that("reference-density selection drives which references contribute", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix( + c( + 0, 0, 1, 2, + 0, 0, 1, 4, + 0, 0, 1, 6 + ), + ncol = 4, + byrow = TRUE + ) + # all predicted distances are 1 (row index 2); steer selection by obs bin + ref_density <- matrix(0, nrow = 20, ncol = 20) + ref_density[2, 3] <- 0.9 # obs_dist 2 -> col 3 + ref_density[2, 5] <- 0.5 # obs_dist 4 -> col 5 + ref_density[2, 7] <- 0.1 # obs_dist 6 -> col 7 + + out <- variable_importance( + data = target, + samples = samples, + ref_density = ref_density, + radius_km = 1000, + k1 = 3, + k2 = 2, # keep the two highest-probability references (obs 2 and 4) + bin_width = 1, + interpolate = FALSE, + lambda = 2, + epsilon = 0, + exclude_slef = FALSE, + num_threads = 1, + boost = NULL + ) + + # kept references observed at 2 and 4 (equal weights) -> importance 3, + # not 2.25 that including the third (obs 6) would give + expect_equal(unname(out[1, 1]), 3, tolerance = 1e-5) +}) + + +test_that("missing observations and empty reference sets return NaN", { + target <- matrix( + c( + 0, 0, 0, NA, # missing observed value + 0, 0, 0, 0 # no reference within radius + ), + ncol = 4, + byrow = TRUE + ) + samples <- matrix(c(1000, 1000, 1, 2), nrow = 1) + + out <- variable_importance( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1, # samples are far away -> no candidates + k1 = 1, + k2 = 1, + bin_width = 1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + + expect_true(is.nan(out[1, 1])) + expect_true(is.nan(out[2, 1])) +}) + + +test_that("raster processing matches matrix processing", { + skip_if_not_installed("terra") + + raster <- terra::rast( + nrows = 1, + ncols = 2, + xmin = 0, + xmax = 2, + ymin = 0, + ymax = 1, + nlyrs = 2 + ) + terra::values(raster) <- cbind(c(0, 0), c(0, 0)) + target <- cbind( + terra::xyFromCell(raster, 1:2), + terra::values(raster, mat = TRUE) + ) + samples <- matrix( + c( + 0.5, 0.5, 1, 2, + 0.5, 0.5, 2, 4 + ), + ncol = 4, + byrow = TRUE + ) + args <- list( + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 1, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + + matrix_output <- do.call(variable_importance, c(list(data = target), args)) + raster_output <- do.call(variable_importance, c(list(data = raster), args)) + + expect_equal( + unname(terra::values(raster_output)), + unname(matrix_output), + tolerance = 1e-5 + ) +}) + + +test_that("column names propagate from observed variables", { + target <- matrix( + c(0, 0, 0, 0, 0, 0), + nrow = 1, + dimnames = list(NULL, c("x", "y", "p_ndvi", "p_swir", "ndvi", "swir")) + ) + samples <- matrix( + c( + 0, 0, 0.5, 0.0, 0.2, 1.0, + 0, 0, 0.0, 0.5, 0.4, 2.0 + ), + ncol = 6, + byrow = TRUE, + dimnames = list(NULL, c("x", "y", "p_ndvi", "p_swir", "ndvi", "swir")) + ) + + out <- variable_importance( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 2, + k2 = 2, + bin_width = 0.5, + interpolate = FALSE, + exclude_slef = FALSE, + num_threads = 1 + ) + + expect_equal(colnames(out), c("ndvi", "swir")) +}) + + +test_that("invalid arguments are rejected", { + target <- matrix(c(0, 0, 0, 0), nrow = 1) + samples <- matrix(c(0, 0, 1, 2), nrow = 1) + ref <- matrix(1, nrow = 20, ncol = 20) + + expect_error( + variable_importance(target, samples, ref, k1 = 1, k2 = 2, + bin_width = 1, interpolate = FALSE), + "'k2' must be less than or equal to 'k1'." + ) + expect_error( + variable_importance(target, samples, ref, lambda = 0, + bin_width = 1, interpolate = FALSE), + "'lambda' must be one finite number greater than zero." + ) + expect_error( + variable_importance(target, samples, ref, epsilon = -1, + bin_width = 1, interpolate = FALSE), + "'epsilon' must be one finite, non-negative number." + ) + expect_error( + variable_importance(target, samples = list(`2000` = target), ref, + bin_width = 1, interpolate = FALSE), + "Temporal sample lists are not supported" + ) + # benchmark()-only args must fail loudly, not be forwarded to the C++ engine + expect_error( + variable_importance(target, samples, ref, bin_width = 1, + interpolate = FALSE, confidence = 0.5), + "does not accept benchmark\\(\\) argument" + ) +}) + + +test_that("results are independent of thread count", { + target <- cbind( + x = rep(0, 25), + y = rep(0, 25), + p1 = seq(0, 1, length.out = 25), + p2 = seq(1, 0, length.out = 25), + o1 = seq(0.1, 0.9, length.out = 25), + o2 = seq(0.9, 0.1, length.out = 25) + ) + samples <- cbind( + x = rep(0, 10), + y = rep(0, 10), + p1 = seq(0, 1, length.out = 10), + p2 = seq(1, 0, length.out = 10), + o1 = runif(10), + o2 = runif(10) + ) + args <- list( + data = target, + samples = samples, + ref_density = matrix(1, nrow = 20, ncol = 20), + radius_km = 1000, + k1 = 6, + k2 = 4, + bin_width = 0.1, + interpolate = FALSE, + lambda = 2, + exclude_slef = FALSE + ) + + one <- do.call(variable_importance, c(args, list(num_threads = 1))) + two <- do.call(variable_importance, c(args, list(num_threads = 2))) + expect_equal(one, two, tolerance = 1e-10) +}) + + +test_that("aggregate_importance ranks by median and averages shares", { + imp <- matrix( + c( + 0.8, 0.2, 0.0, + 0.6, 0.3, 0.1, + 0.7, 0.2, 0.1 + ), + ncol = 3, + byrow = TRUE, + dimnames = list(NULL, c("a", "b", "c")) + ) + + agg <- aggregate_importance(imp) + + expect_equal(agg$variable, c("a", "b", "c")) + expect_equal(agg$rank, 1:3) + expect_equal(agg$median, c(0.7, 0.2, 0.1)) + # mean of per-row shares + shares <- imp / rowSums(imp) + expect_equal(agg$mean_share, unname(colMeans(shares))[order(-c(0.7, 0.2, 0.1))], + tolerance = 1e-12) + expect_equal(unique(agg$n), 3L) +}) + + +test_that("aggregate_importance ignores NaN cells", { + imp <- matrix( + c( + 0.8, 0.2, + NaN, NaN, + 0.6, 0.4 + ), + ncol = 2, + byrow = TRUE, + dimnames = list(NULL, c("a", "b")) + ) + + agg <- aggregate_importance(imp) + expect_equal(agg$n[1], 2L) + expect_equal(agg$median, c(0.7, 0.3), tolerance = 1e-12) +})