Skip to content

Commit

Permalink
Further fixes to derivates and scenario variable preparations #106
Browse files Browse the repository at this point in the history
  • Loading branch information
Martin-Jung committed Mar 28, 2024
1 parent 8a67d05 commit a640e40
Show file tree
Hide file tree
Showing 14 changed files with 290 additions and 82 deletions.
2 changes: 1 addition & 1 deletion NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@
* Small fix to parameter in `train()` #102 @jeffreyhanson
* Small helper function for combining 2 different formula objects `combine_formulas()`
* Small bug fixes dealing with `scenario()` projections and limits, plus unit tests #104
* Fixed bug with adding `predictor_derivate()` to scenario predictors and added unit tests #106
* Bug fixes with adding `predictor_derivate()` to scenario predictors and added unit tests #106

# ibis.iSDM 0.1.2

Expand Down
27 changes: 27 additions & 0 deletions R/add_constraint.R
Original file line number Diff line number Diff line change
Expand Up @@ -149,13 +149,27 @@ methods::setMethod(
#' instance \code{`kissmig`}.
#'
#' @details
#' **Dispersal**:
#' Parameters for \code{'method'}:
#' * \code{sdd_fixed} - Applies a fixed uniform dispersal distance per modelling timestep.
#' * \code{sdd_nexpkernel} - Applies a dispersal distance using a negative exponential kernel from its origin.
#' * \code{kissmig} - Applies the kissmig stochastic dispersal model. Requires \code{`kissmig`} package. Applied at each modelling time step.
#' * \code{migclim} - Applies the dispersal algorithm MigClim to the modelled objects. Requires \code{"MigClim"} package.
#'
#' A comprehensive overview of the benefits of including dispersal constrains in
#' species distribution models can be found in Bateman et al. (2013).
#'
#' The following additional parameters can bet set:
#' * \code{pext}: [`numeric`] indicator for \code{`kissmig`} of the probability a
#' colonized cell becomes uncolonised, i.e., the species gets locally extinct
#' (Default: \code{0.1}).
#' * \code{pcor}: [`numeric`] probability that corner cells are considered in the
#' 3x3 neighbourhood (Default: \code{0.2}).
#'
#' @references
#' * Bateman, B. L., Murphy, H. T., Reside, A. E., Mokany, K., & VanDerWal, J. (2013).
#' Appropriateness of full‐, partial‐and no‐dispersal scenarios in climate change impact
#' modelling. Diversity and Distributions, 19(10), 1224-1234.
#' @family constraint
#' @keywords scenario
#'
Expand Down Expand Up @@ -424,6 +438,19 @@ methods::setMethod(
#' @param resistance A [`SpatRaster`] object describing a resistance surface or
#' barrier for use in connectivity constrains (Default: \code{NULL}).
#'
#' @details
#' * \code{hardbarrier} - Defines a hard barrier to any dispersal events. By
#' definition this sets all values larger
#' than \code{0} in the barrier layer to \code{0} in the projection. Barrier has
#' to be provided through the \code{"resistance"} parameter.
#' * \code{resistance} - Allows the provision of a static or dynamic layer that is
#' multiplied with the projection at each time step. Can for example be used to
#' reduce the suitability of any given area (using pressures not included in the model).
#' The respective layer(s) have to be provided through the \code{"resistance"} parameter.
#' Provided layers are incorporated as \code{abs(resistance - 1)} and multiplied with
#' the prediction.
#'
#'
#' @family constraint
#' @keywords scenario
#'
Expand Down
45 changes: 30 additions & 15 deletions R/add_predictors.R
Original file line number Diff line number Diff line change
Expand Up @@ -51,10 +51,10 @@ NULL
#'
#' Available options for creating derivates are:
#' * \code{'none'} - No additional predictor derivates are created.
#' * \code{'quad'} - Adds quadratic transformed predictors.
#' * \code{'quad'} - Adds quadratic derivate predictors.
#' * \code{'interaction'} - Add interacting predictors. Interactions need to be specified (\code{"int_variables"})!
#' * \code{'thresh'} - Add threshold transformed predictors.
#' * \code{'hinge'} - Add hinge transformed predictors.
#' * \code{'thresh'} - Add threshold derivate predictors.
#' * \code{'hinge'} - Add hinge derivate predictors.
#' * \code{'bin'} - Add predictors binned by their percentiles.
#'
#' @note
Expand Down Expand Up @@ -161,6 +161,7 @@ methods::setMethod(
assertthat::assert_that( all( priors$varnames() %in% names(env) ) )
y <- y$set_priors(priors)
}

# Harmonize NA values
if(harmonize_na){
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','green','Harmonizing missing values...')
Expand Down Expand Up @@ -248,6 +249,7 @@ methods::setMethod(
# Finally set the data to the BiodiversityDistribution object
pd <- PredictorDataset$new(id = new_id(),
data = env,
transformed = ifelse('none' %notin% transform, TRUE, FALSE ),
...)
y$set_predictors(pd)
}
Expand Down Expand Up @@ -727,7 +729,7 @@ methods::setMethod(
derivate_knots = 4, int_variables = NULL, harmonize_na = FALSE, ... ) {
# Try and match transform and derivatives arguments
transform <- match.arg(transform, c('none','pca', 'scale', 'norm', 'windsor', 'percentile'), several.ok = TRUE)
derivates <- match.arg(derivates, c('none','thresh', 'hinge', 'quadratic', 'bin'), several.ok = TRUE)
derivates <- match.arg(derivates, c('none','thresh', 'hinge', 'quadratic', 'bin', 'interaction'), several.ok = TRUE)

assertthat::validate_that(inherits(env,'stars'), msg = 'Projection rasters need to be stars stack!')
assertthat::assert_that(inherits(x, "BiodiversityScenario"),
Expand Down Expand Up @@ -762,26 +764,38 @@ methods::setMethod(
if('none' %notin% transform){
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','green','Transforming predictors...')
for(tt in transform) env <- predictor_transform(env, option = tt)
} else {
# Check regardless
try({ test <- obj$model$predictors_object$is_transformed() },silent = TRUE)
if(!inherits(test, 'try-error')){
if(test) if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','red','Option to transform predictors set to None, yet transformed variables were used in trained model?')
}
}

# # Calculate derivates if set
# Calculate derivates if set
if('none' %notin% derivates){
# Get variable names
varn <- obj$get_coefficients()[['Feature']]
varn <- obj$get_coefficients()[,1]
# Are there any derivates present in the coefficients?
if(any( length( grep("hinge__|bin__|quad__|thresh__", varn ) ) > 0 )){
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','green','Creating predictor derivates...')
for(dd in derivates){
if(any(grep(dd, varn))){
env <- predictor_derivate(env, option = dd, nknots = derivate_knots,
deriv = varn, int_variables = int_variables)
} else {
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','red', paste0(derivates,' derivates should be created, but not found among coefficients!'))
}
if(any( length( grep("hinge_|bin_|quadratic_|thresh_|interaction_", varn ) ) > 0 )){
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','green','Creating predictor derivates...')
for(dd in derivates){
if(any(grep(dd, varn))){
env <- predictor_derivate(env, option = dd, nknots = derivate_knots,
deriv = grep(dd,varn, value=TRUE), int_variables = int_variables)
} else {
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','red', paste0(derivates,' derivates should be created, but not found among model coefficients!'))
}
}
} else {
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','red','No derivates found among coefficients. None created for projection!')
}
} else {
# Check regardless as security check
try({ test <- obj$model$predictors_object$has_derivates() },silent = TRUE)
if(!inherits(test, 'try-error')){
if(test) if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','red','Option to create derivates set to None, but likely derivates found among coefficients?')
}
}

# Get, guess and format Time period
Expand All @@ -800,6 +814,7 @@ methods::setMethod(
# Finally set the data to the BiodiversityScenario object
pd <- PredictorDataset$new(id = new_id(),
data = env,
transformed = ifelse('none' %notin% transform, TRUE, FALSE ),
timeperiod = timeperiod
)
# Make a clone copy of the object
Expand Down
22 changes: 19 additions & 3 deletions R/class-distributionmodel.R
Original file line number Diff line number Diff line change
Expand Up @@ -450,8 +450,16 @@ DistributionModel <- R6::R6Class(
#' @param x A [`character`] stating what should be returned.
#' @return A [`SpatRaster`] object with the prediction.
get_data = function(x = "prediction") {
if (!x %in% names(self$fits))
rr <- names(self$fits)
if(!x %in% names(self$fits)){
# Check if x is present in rr, if so print a message
if(length(grep(x,rr))>0){
if(getOption('ibis.setupmessages', default = TRUE)){
myLog('[Estimation]','yellow','Output not found, but found: ', grep(x,rr,value = TRUE)[1])
}
}
return(new_waiver())
}
return(self$fits[[x]])
},

Expand Down Expand Up @@ -678,7 +686,7 @@ DistributionModel <- R6::R6Class(
assertthat::assert_that(
is.character(fname),
type %in% c('gtif','gtiff','tif','nc','ncdf'),
'fits' %in% self$ls(),
'fits' %in% names(self),
dt %in% c('LOG1S','INT1S','INT1U','INT2S','INT2U','INT4S','INT4U','FLT4S','FLT8S')
)
type <- tolower(type)
Expand All @@ -688,10 +696,18 @@ DistributionModel <- R6::R6Class(

# Get raster file in fitted object
cl <- sapply(self$fits, class)
ras <- self$fits[[grep('SpatRaster', cl,ignore.case = T)]]
if(length( grep('SpatRaster', cl,ignore.case = T) )==0){
# Security check in case for some reason there are no predictions
if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Output]','red','No predictions found?')
return(NULL)
}
ras <- self$fits[grep('SpatRaster', cl,ignore.case = T)]
assertthat::assert_that(length(ras)>0,
msg = "No prediction to save found.")

# If is a list (multiple SpatRaster) -> Combine
if(is.list(ras)) ras <- Reduce('c', ras)

# Check that no-data value is not present in ras
assertthat::assert_that(any(!terra::global(ras, "min", na.rm = TRUE)[,1] <= -9999),
msg = 'No data value -9999 is potentially in prediction!')
Expand Down
21 changes: 18 additions & 3 deletions R/class-predictors.R
Original file line number Diff line number Diff line change
Expand Up @@ -21,25 +21,30 @@ PredictorDataset <- R6::R6Class(
#' @field id The id for this collection as [`character`].
#' @field data A predictor dataset usually as [`SpatRaster`].
#' @field name A name for this object.
#' @field transformed Saves whether the predictors have been transformed somehow.
#' @field timeperiod A timeperiod field
id = character(0),
data = new_waiver(),
name = character(0),
transformed = logical(0),
timeperiod = new_waiver(),

#' @description
#' Initializes the object and creates an empty list
#' @param id The id for this collection as [`character`].
#' @param data A predictor dataset usually as [`SpatRaster`].
#' @param transformed A [`logical`] flag if predictors have been transformed. Assume not.
#' @param ... Any other parameters found.
#' @return NULL
initialize = function(id, data, ...){
initialize = function(id, data, transformed = FALSE, ...){
assertthat::assert_that(
is.Id(id) || is.character(id)
is.Id(id) || is.character(id),
is.logical(transformed)
)
self$name <- 'Biodiversity data'
self$id <- id
self$data <- data
self$transformed <- transformed
# Get Dots and save too
dots <- list(...)
for(el in names(dots)){
Expand Down Expand Up @@ -296,7 +301,17 @@ PredictorDataset <- R6::R6Class(
#' @return A [`logical`] flag.
has_derivates = function(){
return(
base::length( grep("hinge__|bin__|quad__|thresh__", self$get_names() ) ) > 0
base::length( grep("hinge_|bin_|quadratic_|thresh_|interaction_", self$get_names() ) ) > 0
)
},

#' @description
#' Predictors have been transformed?
#' @seealso [predictor_transform()]
#' @return A [`logical`] flag.
is_transformed = function(){
return(
self$transformed
)
},

Expand Down
2 changes: 1 addition & 1 deletion R/ibis.iSDM-package.R
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@ globalVariables(c("background", "band", "bi_class", "bias",
#MJ: Added self here hoping that does not crash all methods.
"self",
"id", "included", "i",
"km", "vt",
"km", "vt", "V2",
"limit", "lower", "layer",
"median", "model", "mad",
"name",
Expand Down
Loading

0 comments on commit a640e40

Please sign in to comment.