|
| 1 | +#' @include utils.R bdproto.R bdproto-biodiversitydistribution.R bdproto-predictors.R |
| 2 | +NULL |
| 3 | + |
| 4 | +#' Add predictors from a fitted model to a Biodiversity distribution object |
| 5 | +#' |
| 6 | +#' @description This function is a convenience wrapper to add the output from a |
| 7 | +#' previous fitted [`DistributionModel`] to another [`BiodiversityDistribution-class`] |
| 8 | +#' object. Obviously only works if a prediction was fitted in the model. Options |
| 9 | +#' to instead add thresholds, or to transform / derivate the model outputs are |
| 10 | +#' also supported. |
| 11 | +#' |
| 12 | +#' @details |
| 13 | +#' |
| 14 | +#' A transformation takes the provided rasters and for instance rescales them or |
| 15 | +#' transforms them through a principal component analysis ([prcomp]). In |
| 16 | +#' contrast, derivates leave the original provided predictors alone, but instead |
| 17 | +#' create new ones, for instance by transforming their values through a |
| 18 | +#' quadratic or hinge transformation. Note that this effectively increases the |
| 19 | +#' number of predictors in the object, generally requiring stronger |
| 20 | +#' regularization by the used [`Engine`]. Both transformations and derivates can |
| 21 | +#' also be combined. Available options for transformation are: |
| 22 | +#' * \code{'none'} - Leaves the provided predictors in the original scale. |
| 23 | +#' * \code{'pca'} - Converts the predictors to principal components. Note that this |
| 24 | +#' results in a renaming of the variables to principal component axes! |
| 25 | +#' * \code{'scale'} - Transforms all predictors by applying [scale] on them. |
| 26 | +#' * \code{'norm'} - Normalizes all predictors by transforming them to a scale from 0 to 1. |
| 27 | +#' * \code{'windsor'} - Applies a windsorization to the target predictors. By default |
| 28 | +#' this effectively cuts the predictors to the 0.05 and 0.95, thus helping to |
| 29 | +#' remove extreme outliers. |
| 30 | +#' |
| 31 | +#' Available options for creating derivates are: |
| 32 | +#' * \code{'none'} - No additional predictor derivates are created. |
| 33 | +#' * \code{'quad'} - Adds quadratic transformed predictors. |
| 34 | +#' * \code{'interaction'} - Add interacting predictors. Interactions need to be specified (\code{"int_variables"})! |
| 35 | +#' * \code{'thresh'} - Add threshold transformed predictors. |
| 36 | +#' * \code{'hinge'} - Add hinge transformed predictors. |
| 37 | +#' * \code{'bin'} - Add predictors binned by their percentiles. |
| 38 | +#' |
| 39 | +#' @param x [distribution()] (i.e. [`BiodiversityDistribution-class`]) object. |
| 40 | +#' @param model A [`DistributionModel`] object. |
| 41 | +#' @param transform A [`vector`] stating whether predictors should be |
| 42 | +#' preprocessed in any way (Options: \code{'none'},\code{'pca'}, |
| 43 | +#' \code{'scale'}, \code{'norm'}) |
| 44 | +#' @param derivates A Boolean check whether derivate features should be |
| 45 | +#' considered (Options: \code{'none'}, \code{'thresh'}, \code{'hinge'}, |
| 46 | +#' \code{'quad'}) ) |
| 47 | +#' @param threshold_only A [`logical`] flag indicating whether to add thresholded |
| 48 | +#' layers from the fitted model (if existing) instead (Default: \code{FALSE}). |
| 49 | +#' @param priors A [`PriorList-class`] object. Default is set to \code{NULL} |
| 50 | +#' which uses default prior assumptions. |
| 51 | +#' @param ... Other parameters passed down |
| 52 | +#' @aliases add_predictors_model |
| 53 | +#' @examples |
| 54 | +#' \dontrun{ |
| 55 | +#' # Fit first model |
| 56 | +#' fit <- distribution(background) |> |
| 57 | +#' add_predictors(covariates) |> |
| 58 | +#' add_biodiversity_poipa(species) |> |
| 59 | +#' engine_glmnet() |> |
| 60 | +#' train() |
| 61 | +#' |
| 62 | +#' # New model object |
| 63 | +#' obj <- distribution(background) |> |
| 64 | +#' add_predictors_model(fit) |
| 65 | +#' obj |
| 66 | +#' } |
| 67 | +#' @name add_predictors_model |
| 68 | +NULL |
| 69 | + |
| 70 | +#' @name add_predictors_model |
| 71 | +#' @rdname add_predictors_model |
| 72 | +#' @exportMethod add_predictors_model |
| 73 | +#' @export |
| 74 | +methods::setGeneric( |
| 75 | + "add_predictors_model", |
| 76 | + signature = methods::signature("x", "model"), |
| 77 | + function(x, model, transform = 'scale', derivates = 'none', |
| 78 | + threshold_only = FALSE, priors = NULL, ...) standardGeneric("add_predictors_model")) |
| 79 | + |
| 80 | +#' @name add_predictors_model |
| 81 | +#' @rdname add_predictors_model |
| 82 | +#' @usage |
| 83 | +#' \S4method{add_predictors_model}{BiodiversityDistribution,ANY,character,character,logical,ANY}(x,model,transform,derivates,threshold_only,priors,...) |
| 84 | +methods::setMethod( |
| 85 | + "add_predictors_model", |
| 86 | + methods::signature(x = "BiodiversityDistribution", model = "ANY"), |
| 87 | + function(x, model, transform = 'scale', derivates = 'none', |
| 88 | + threshold_only = FALSE, priors = NULL, ...) { |
| 89 | + # Try and match transform and derivatives arguments |
| 90 | + transform <- match.arg(transform, c('none','pca', 'scale', 'norm', 'windsor') , several.ok = TRUE) |
| 91 | + derivates <- match.arg(derivates, c('none','thresh', 'hinge', 'quadratic', 'bin', 'interaction') , several.ok = TRUE) |
| 92 | + |
| 93 | + assertthat::assert_that(inherits(x, "BiodiversityDistribution"), |
| 94 | + inherits(model, "DistributionModel"), |
| 95 | + is.logical(threshold_only), |
| 96 | + all(transform == 'none') || all( transform %in% c('pca', 'scale', 'norm', 'windsor') ), |
| 97 | + all(derivates == 'none') || all( derivates %in% c('thresh', 'hinge', 'quadratic', 'bin', 'interaction') ), |
| 98 | + is.null(priors) || inherits(priors,'PriorList') |
| 99 | + ) |
| 100 | + # Messenger |
| 101 | + if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Adding predictors from fitted model...') |
| 102 | + |
| 103 | + # If priors have been set, save them in the distribution object |
| 104 | + if(!is.null(priors)) { |
| 105 | + x <- x$set_priors(priors) |
| 106 | + } |
| 107 | + |
| 108 | + # Get prediction from model object |
| 109 | + assertthat::assert_that( |
| 110 | + "prediction" %in% model$show_rasters(), |
| 111 | + msg = "No prediction found in model object!" |
| 112 | + ) |
| 113 | + if(threshold_only){ |
| 114 | + tr <- grep('threshold', model$show_rasters(),ignore.case = TRUE,value = TRUE) |
| 115 | + if(length(tr)==1){ |
| 116 | + prediction <- model$get_data(tr) |
| 117 | + } else { |
| 118 | + if(getOption('ibis.setupmessages')) myLog('[Setup]','yellow','No threshold found in fitted model. Using prediction...') |
| 119 | + prediction <- model$get_data() |
| 120 | + } |
| 121 | + } else { |
| 122 | + prediction <- model$get_data() |
| 123 | + } |
| 124 | + assertthat::assert_that(is.Raster(prediction)) |
| 125 | + # Set names |
| 126 | + names(prediction) <- paste0(make.names(model$model$runname),"__",names(prediction)) |
| 127 | + |
| 128 | + # Standardization and scaling |
| 129 | + if('none' %notin% transform){ |
| 130 | + if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Transforming prediction...') |
| 131 | + for(tt in transform) prediction <- predictor_transform(prediction, option = tt) |
| 132 | + } |
| 133 | + assertthat::assert_that(is.Raster(prediction)) |
| 134 | + |
| 135 | + # Calculate derivates if set |
| 136 | + if('none' %notin% derivates){ |
| 137 | + if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Creating prediction derivates...') |
| 138 | + # Specific condition for interaction |
| 139 | + new_prediction <- terra::rast() |
| 140 | + for(dd in derivates){ |
| 141 | + suppressWarnings( |
| 142 | + new_prediction <- c(new_prediction, predictor_derivate(prediction, |
| 143 | + option = dd) ) |
| 144 | + ) |
| 145 | + } |
| 146 | + # Add |
| 147 | + prediction <- c(prediction, new_prediction) |
| 148 | + rm(new_prediction) |
| 149 | + } |
| 150 | + |
| 151 | + # Assign an attribute to this object to keep track of it |
| 152 | + attr(prediction,'transform') <- transform |
| 153 | + |
| 154 | + # Sanitize names if specified |
| 155 | + if(getOption('ibis.cleannames')) names(prediction) <- sanitize_names(names(prediction)) |
| 156 | + |
| 157 | + # Get existing predictors |
| 158 | + if(!is.Waiver(x$predictors)){ |
| 159 | + env <- x$predictors$get_data() |
| 160 | + env <- c(env, prediction) |
| 161 | + } |
| 162 | + |
| 163 | + # Finally set the data to the BiodiversityDistribution object |
| 164 | + x$set_predictors( |
| 165 | + bdproto(NULL, PredictorDataset, |
| 166 | + id = new_id(), |
| 167 | + data = env, |
| 168 | + ... |
| 169 | + ) |
| 170 | + ) |
| 171 | + } |
| 172 | +) |
0 commit comments