From 8d536e77cddc140c05665fef47c859c188e0940c Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Mon, 5 Aug 2024 14:56:56 +0200 Subject: [PATCH 01/21] Version bump and small zoning-related fixes added #121 --- DESCRIPTION | 2 +- NEWS.md | 9 ++++++++- R/add_constraint.R | 5 ++++- R/project.R | 16 +++++++++++----- 4 files changed, 24 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7de32928..4f950c49 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: ibis.iSDM Type: Package Title: Modelling framework for integrated biodiversity distribution scenarios -Version: 0.1.4 +Version: 0.1.5 Authors@R: c(person(given = "Martin", family = "Jung", diff --git a/NEWS.md b/NEWS.md index 87003716..71aca24b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,11 @@ -# ibis.iSDM 0.1.4 (current dev branch) +# ibis.iSDM 0.1.5 (current dev branch) + +#### New features + +#### Minor improvements and bug fixes +* Minor :bug: fix related to misaligned thresholds and negative expontential kernels. + +# ibis.iSDM 0.1.4 #### New features * Support for carnying over latent spatial effects (`add_latent_spatial()`) to `scenario()` projections. diff --git a/R/add_constraint.R b/R/add_constraint.R index bbde8db9..10073910 100644 --- a/R/add_constraint.R +++ b/R/add_constraint.R @@ -382,8 +382,11 @@ methods::setMethod( # Divide alpha values by 2 alpha <- value/2 + # Scale value for different projections + value_scale <- ifelse(terra::is.lonlat(baseline_threshold), terra::res(baseline_threshold)[1] * 10000, 1) + # Grow baseline raster by using an exponentially weighted kernel - ras_dis <- terra::gridDist(baseline_threshold, target = 1) + ras_dis <- terra::gridDist(baseline_threshold, target = 1, scale = value_scale) # Normalized (with a constant) negative exponential kernel ras_dis <- terra::app(ras_dis, fun = function(x) (1 / (2 * pi * value ^ 2)) * exp(-x / value) ) # Equivalent to alpha = 1/value and diff --git a/R/project.R b/R/project.R index 7b281e4b..7f1f3d38 100644 --- a/R/project.R +++ b/R/project.R @@ -236,6 +236,9 @@ methods::setMethod( msg = "Model predictors are missing from the scenario predictor!") } + # Create a template for use + template <- emptyraster( new_preds$get_data() ) + # Get constraints, threshold values and other parameters scenario_threshold <- mod$get_threshold() if(!is.Waiver(scenario_threshold)){ @@ -264,8 +267,13 @@ methods::setMethod( baseline_threshold <- baseline_threshold[[grep(layer, names(baseline_threshold))]] } - # Set all NA values to 0 (and then mask by background?) - baseline_threshold[is.na(baseline_threshold)]<-0 + # Set all NA values to 0 + baseline_threshold[is.na(baseline_threshold)] <- 0 + # Align with newpreds extend and + if(!terra::compareGeom(baseline_threshold, template, stopOnError = FALSE)){ + baseline_threshold <- terra::extend(baseline_threshold, template) + baseline_threshold <- terra::crop(baseline_threshold, template) + } } else { baseline_threshold <- new_waiver() @@ -275,9 +283,6 @@ methods::setMethod( scenario_constraints <- mod$get_constraints() scenario_simulations <- mod$get_simulation() - # Create a template for use - template <- emptyraster( new_preds$get_data() ) - # --- Check that everything is there --- # Check that thresholds are set for constrains if("dispersal" %in% names(scenario_constraints)){ @@ -455,6 +460,7 @@ methods::setMethod( scenario_threshold <- scenario_threshold[[1]] out_thresh <- out out_thresh[out_thresh < scenario_threshold] <- 0; out_thresh[out_thresh >= scenario_threshold] <- 1 + out_thresh[is.na(out_thresh)] <- 0 # Added to avoid unnecessary clipping names(out_thresh) <- "threshold" # Apply minimum size constraint if set From a39e22aed6bc48d9bd7f100d2155417d69e14100 Mon Sep 17 00:00:00 2001 From: Martin-Jung Date: Mon, 5 Aug 2024 12:58:50 +0000 Subject: [PATCH 02/21] Update CITATION.cff --- CITATION.cff | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/CITATION.cff b/CITATION.cff index a18f98ee..a73746c1 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -8,7 +8,7 @@ message: 'To cite package "ibis.iSDM" in publications use:' type: software license: CC-BY-4.0 title: 'ibis.iSDM: Modelling framework for integrated biodiversity distribution scenarios' -version: 0.1.4 +version: 0.1.5 abstract: Integrated framework of modelling the distribution of species and ecosystems in a suitability framing. This package allows the estimation of integrated species distribution models (iSDM) based on several sources of evidence and provided presence-only @@ -76,6 +76,7 @@ references: given-names: Winston email: winston@stdout.org year: '2024' + doi: 10.32614/CRAN.package.R6 version: '>= 2.5.0' - type: software title: assertthat @@ -87,6 +88,7 @@ references: given-names: Hadley email: hadley@rstudio.com year: '2024' + doi: 10.32614/CRAN.package.assertthat version: '>= 0.2.0' - type: software title: doFuture @@ -100,6 +102,7 @@ references: email: henrikb@braju.com orcid: https://orcid.org/0000-0002-7579-5165 year: '2024' + doi: 10.32614/CRAN.package.doFuture version: '>= 0.12.2' - type: software title: dplyr @@ -125,6 +128,7 @@ references: email: davis@posit.co orcid: https://orcid.org/0000-0003-4777-038X year: '2024' + doi: 10.32614/CRAN.package.dplyr - type: software title: foreach abstract: 'foreach: Provides Foreach Looping Construct' @@ -136,6 +140,7 @@ references: - family-names: Weston given-names: Steve year: '2024' + doi: 10.32614/CRAN.package.foreach - type: software title: future abstract: 'future: Unified Parallel and Distributed Processing in R for Everyone' @@ -148,6 +153,7 @@ references: email: henrikb@braju.com orcid: https://orcid.org/0000-0002-7579-5165 year: '2024' + doi: 10.32614/CRAN.package.future version: '>= 1.23.0' - type: software title: geodist @@ -162,6 +168,7 @@ references: - family-names: Sumner given-names: Michael D. year: '2024' + doi: 10.32614/CRAN.package.geodist - type: software title: ggplot2 abstract: 'ggplot2: Create Elegant Data Visualisations Using the Grammar of Graphics' @@ -201,6 +208,7 @@ references: name-particle: van den orcid: https://orcid.org/0000-0002-9335-7468 year: '2024' + doi: 10.32614/CRAN.package.ggplot2 - type: software title: graphics abstract: 'R: A Language and Environment for Statistical Computing' @@ -211,6 +219,7 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' + doi: 10.32614/CRAN.package.graphics - type: software title: methods abstract: 'R: A Language and Environment for Statistical Computing' @@ -221,6 +230,7 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' + doi: 10.32614/CRAN.package.methods - type: software title: Matrix abstract: 'Matrix: Sparse and Dense Matrix Classes and Methods' @@ -239,6 +249,7 @@ references: given-names: Mikael orcid: https://orcid.org/0000-0002-3542-2938 year: '2024' + doi: 10.32614/CRAN.package.Matrix - type: software title: ncdf4 abstract: 'ncdf4: Interface to Unidata netCDF (Version 4 or Earlier) Format Data @@ -251,6 +262,7 @@ references: given-names: David email: dpierce@ucsd.edu year: '2024' + doi: 10.32614/CRAN.package.ncdf4 - type: software title: parallel abstract: 'R: A Language and Environment for Statistical Computing' @@ -261,6 +273,7 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' + doi: 10.32614/CRAN.package.parallel - type: software title: posterior abstract: 'posterior: Tools for Working with Posterior Distributions' @@ -281,6 +294,7 @@ references: given-names: Aki email: Aki.Vehtari@aalto.fi year: '2024' + doi: 10.32614/CRAN.package.posterior - type: software title: sf abstract: 'sf: Simple Features for R' @@ -293,6 +307,7 @@ references: email: edzer.pebesma@uni-muenster.de orcid: https://orcid.org/0000-0001-8049-7069 year: '2024' + doi: 10.32614/CRAN.package.sf version: '>= 1.0' - type: software title: stars @@ -306,6 +321,7 @@ references: email: edzer.pebesma@uni-muenster.de orcid: https://orcid.org/0000-0001-8049-7069 year: '2024' + doi: 10.32614/CRAN.package.stars version: '>= 0.5' - type: software title: stats @@ -317,6 +333,7 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' + doi: 10.32614/CRAN.package.stats - type: software title: terra abstract: 'terra: Spatial Data Analysis' @@ -329,6 +346,7 @@ references: email: r.hijmans@gmail.com orcid: https://orcid.org/0000-0001-5872-2872 year: '2024' + doi: 10.32614/CRAN.package.terra version: '>= 1.7-10' - type: software title: tibble @@ -345,6 +363,7 @@ references: given-names: Hadley email: hadley@rstudio.com year: '2024' + doi: 10.32614/CRAN.package.tibble version: '>= 2.0.0' - type: software title: uuid @@ -356,10 +375,12 @@ references: - family-names: Urbanek given-names: Simon email: Simon.Urbanek@r-project.org + orcid: https://orcid.org/0000-0003-2297-1732 - family-names: Ts'o given-names: Theodore email: tytso@thunk.org year: '2024' + doi: 10.32614/CRAN.package.uuid - type: software title: utils abstract: 'R: A Language and Environment for Statistical Computing' @@ -370,6 +391,7 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' + doi: 10.32614/CRAN.package.utils - type: software title: 'R: A Language and Environment for Statistical Computing' notes: Depends @@ -393,6 +415,7 @@ references: - family-names: Heiberger given-names: Richard year: '2024' + doi: 10.32614/CRAN.package.abind - type: software title: BoomSpikeSlab abstract: 'BoomSpikeSlab: MCMC for Spike and Slab Regression' @@ -403,6 +426,7 @@ references: given-names: Steven L. email: steve.the.bayesian@gmail.com year: '2024' + doi: 10.32614/CRAN.package.BoomSpikeSlab version: '>= 1.2.4' - type: software title: Boruta @@ -418,6 +442,7 @@ references: - family-names: Rudnicki given-names: Witold Remigiusz year: '2024' + doi: 10.32614/CRAN.package.Boruta - type: software title: covr abstract: 'covr: Test Coverage for Packages' @@ -429,6 +454,7 @@ references: given-names: Jim email: james.f.hester@gmail.com year: '2024' + doi: 10.32614/CRAN.package.covr - type: software title: cubelyr abstract: 'cubelyr: A Data Cube ''dplyr'' Backend' @@ -440,6 +466,7 @@ references: given-names: Hadley email: hadley@rstudio.com year: '2024' + doi: 10.32614/CRAN.package.cubelyr - type: software title: dbarts abstract: 'dbarts: Discrete Bayesian Additive Regression Trees Sampler' @@ -458,6 +485,7 @@ references: given-names: Robert email: robert.mcculloch1@gmail.com year: '2024' + doi: 10.32614/CRAN.package.dbarts version: '>= 0.9-22' - type: software title: deldir @@ -468,6 +496,7 @@ references: - family-names: Turner given-names: Rolf year: '2024' + doi: 10.32614/CRAN.package.deldir - type: software title: doParallel abstract: 'doParallel: Foreach Parallel Adaptor for the ''parallel'' Package' @@ -480,6 +509,7 @@ references: - family-names: Weston given-names: Steve year: '2024' + doi: 10.32614/CRAN.package.doParallel - type: software title: ellipsis abstract: 'ellipsis: Tools for Working with ...' @@ -491,6 +521,7 @@ references: given-names: Hadley email: hadley@rstudio.com year: '2024' + doi: 10.32614/CRAN.package.ellipsis - type: software title: glmnet abstract: 'glmnet: Lasso and Elastic-Net Regularized Generalized Linear Models' @@ -514,6 +545,7 @@ references: - family-names: Yang given-names: James year: '2024' + doi: 10.32614/CRAN.package.glmnet version: '>= 4.1' - type: software title: glmnetUtils @@ -526,6 +558,7 @@ references: given-names: Hong email: hongooi73@gmail.com year: '2024' + doi: 10.32614/CRAN.package.glmnetUtils - type: software title: gnlm abstract: 'gnlm: Generalized Nonlinear Regression Models' @@ -540,6 +573,7 @@ references: given-names: Jim email: jlindsey@gen.unimaas.nl year: '2024' + doi: 10.32614/CRAN.package.gnlm - type: software title: geosphere abstract: 'geosphere: Spherical Trigonometry' @@ -551,6 +585,7 @@ references: given-names: Robert J. email: r.hijmans@gmail.com year: '2024' + doi: 10.32614/CRAN.package.geosphere - type: software title: inlabru abstract: 'inlabru: Bayesian Latent Gaussian Modelling using INLA and Extensions' @@ -566,6 +601,7 @@ references: given-names: Fabian E. email: bachlfab@gmail.com year: '2024' + doi: 10.32614/CRAN.package.inlabru version: '>= 2.10.0' - type: software title: fmesher @@ -579,6 +615,7 @@ references: email: finn.lindgren@gmail.com orcid: https://orcid.org/0000-0002-5833-2011 year: '2024' + doi: 10.32614/CRAN.package.fmesher version: '>= 0.1.7' - type: software title: igraph @@ -613,6 +650,7 @@ references: email: kirill@cynkra.com orcid: https://orcid.org/0000-0002-1416-3412 year: '2024' + doi: 10.32614/CRAN.package.igraph - type: software title: knitr abstract: 'knitr: A General-Purpose Package for Dynamic Report Generation in R' @@ -625,6 +663,7 @@ references: email: xie@yihui.name orcid: https://orcid.org/0000-0003-0645-5666 year: '2024' + doi: 10.32614/CRAN.package.knitr - type: software title: mboost abstract: 'mboost: Model-Based Boosting' @@ -649,6 +688,7 @@ references: given-names: Benjamin orcid: https://orcid.org/0000-0003-2810-3186 year: '2024' + doi: 10.32614/CRAN.package.mboost - type: software title: modEvA abstract: 'modEvA: Model Evaluation and Analysis' @@ -665,6 +705,7 @@ references: - family-names: R. given-names: Real year: '2024' + doi: 10.32614/CRAN.package.modEvA - type: software title: matrixStats abstract: 'matrixStats: Functions that Apply to Rows and Columns of Matrices (and @@ -677,6 +718,7 @@ references: given-names: Henrik email: henrikb@braju.com year: '2024' + doi: 10.32614/CRAN.package.matrixStats - type: software title: ncmeta abstract: 'ncmeta: Straightforward ''NetCDF'' Metadata' @@ -688,6 +730,7 @@ references: given-names: Michael email: mdsumner@gmail.com year: '2024' + doi: 10.32614/CRAN.package.ncmeta - type: software title: progress abstract: 'progress: Terminal Progress Bars' @@ -701,6 +744,7 @@ references: - family-names: FitzJohn given-names: Rich year: '2024' + doi: 10.32614/CRAN.package.progress - type: software title: pdp abstract: 'pdp: Partial Dependence Plots' @@ -713,6 +757,7 @@ references: email: greenwell.brandon@gmail.com orcid: https://orcid.org/0000-0002-8120-0084 year: '2024' + doi: 10.32614/CRAN.package.pdp - type: software title: rmarkdown abstract: 'rmarkdown: Dynamic Documents for R' @@ -756,6 +801,7 @@ references: email: rich@posit.co orcid: https://orcid.org/0000-0003-3925-190X year: '2024' + doi: 10.32614/CRAN.package.rmarkdown - type: software title: lubridate abstract: 'lubridate: Make Dealing with Dates a Little Easier' @@ -771,6 +817,7 @@ references: - family-names: Wickham given-names: Hadley year: '2024' + doi: 10.32614/CRAN.package.lubridate version: '>= 1.9.0' - type: software title: rstan @@ -799,6 +846,7 @@ references: email: badr@jhu.edu orcid: https://orcid.org/0000-0002-9808-2344 year: '2024' + doi: 10.32614/CRAN.package.rstan version: '>= 2.21.0' - type: software title: rstantools @@ -819,6 +867,7 @@ references: - family-names: Johnson given-names: Andrew year: '2024' + doi: 10.32614/CRAN.package.rstantools version: '>= 2.1.1' - type: software title: testthat @@ -831,6 +880,7 @@ references: given-names: Hadley email: hadley@posit.co year: '2024' + doi: 10.32614/CRAN.package.testthat version: '>= 3.0.0' - type: software title: xgboost @@ -880,4 +930,5 @@ references: given-names: Jiaming email: jm.yuan@outlook.com year: '2024' + doi: 10.32614/CRAN.package.xgboost From c8006aabc0b3624ff1156deac2e27ef43c6ad9f6 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Tue, 6 Aug 2024 13:54:26 +0200 Subject: [PATCH 03/21] :fire: fix to allow for scenario projections with different extents --- NEWS.md | 3 ++- R/add_constraint.R | 9 ++++++--- R/class-biodiversityscenario.R | 16 +++++++++++++++- R/engine_breg.R | 5 +++-- R/engine_gdb.R | 2 +- R/engine_glmnet.R | 2 +- R/engine_scampr.R | 2 +- R/project.R | 10 +++++++++- 8 files changed, 38 insertions(+), 11 deletions(-) diff --git a/NEWS.md b/NEWS.md index 71aca24b..fe33bd94 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,7 +3,8 @@ #### New features #### Minor improvements and bug fixes -* Minor :bug: fix related to misaligned thresholds and negative expontential kernels. +* Minor :bug: fix related to misaligned thresholds and negative exponential kernels. +* :fire: :bug: fix for scenario projections that use different grain sizes than for inference. # ibis.iSDM 0.1.4 diff --git a/R/add_constraint.R b/R/add_constraint.R index 10073910..16a91756 100644 --- a/R/add_constraint.R +++ b/R/add_constraint.R @@ -850,12 +850,15 @@ methods::setMethod( # Rasterize the layer # First try and dig out a layer from a predictor dataset if found - if(inherits( mod$get_predictors(), "PredictorDataSet")){ - ras <- mod$get_predictors()$get_data() |> stars_to_raster() - ras <- ras[[1]] + if(inherits( mod$get_predictors(), "PredictorDataset")){ + ras <- mod$get_predictors()$get_data() + if(inherits(ras, 'stars')){ + ras <- stars_to_raster(ras)[[1]] + } } else { # Try and get the underlying model and its predictors ras <- mod$get_model()$get_data() + if(is.null(ras)) ras <- emptyraster(mod$get_model()$model$predictors_object$get_data()) } assertthat::assert_that(is.Raster(ras)) bb <- try({ terra::rasterize(layer, ras, 1)}, silent = TRUE) diff --git a/R/class-biodiversityscenario.R b/R/class-biodiversityscenario.R index 4e764fec..6cf3c89e 100644 --- a/R/class-biodiversityscenario.R +++ b/R/class-biodiversityscenario.R @@ -103,6 +103,12 @@ BiodiversityScenario <- R6::R6Class( assertthat::assert_that(is.Waiver(self$get_predictors()) || inherits(self$get_predictors(), "PredictorDataset")) assertthat::assert_that(is.Waiver(self$get_data()) || (inherits(self$get_data(), "stars") || is.Raster(self$get_data())) ) assertthat::assert_that(is.Waiver(self$get_constraints()) || is.list(self$get_constraints())) + # Check predictor mismatch + if(!is.Waiver(self$get_predictors())){ + ori <- x$get_projection() + test <- self$get_projection() + assertthat::validate_that(sf::st_crs(test) == sf::st_crs(ori),msg = "Predictor and fitted predictor projections mismatch!") + } invisible(self) }, @@ -351,6 +357,15 @@ BiodiversityScenario <- R6::R6Class( return(self[[what]]) }, + #' @description + #' Remove scenario predictions + #' @param what A [`character`] vector with names of what + #' @return Invisible + rm_data = function(){ + self$scenarios <- new_waiver() + invisible() + }, + #' @description #' Set new data in object. #' @param x A new data object measuing scenarios. @@ -382,7 +397,6 @@ BiodiversityScenario <- R6::R6Class( #' Get latent factors if found in object. #' @return A [`list`] with the latent settings get_latent = function(){ - if(is.Waiver(self$latentfactors)) return('None') self$latentfactors }, diff --git a/R/engine_breg.R b/R/engine_breg.R index 4499d168..604a1a5c 100644 --- a/R/engine_breg.R +++ b/R/engine_breg.R @@ -790,7 +790,7 @@ engine_breg <- function(x, mod <- self$get_data('fit_best') model <- self$model df <- newdata - df <- subset(df, select = attr(mod$terms, "term.labels")) + df <- subset(df, select = c("x", "y", attr(mod$terms, "term.labels"))) # Clamp? if( settings$get("clamp") ) df <- clamp_predictions(model, df) @@ -857,8 +857,9 @@ engine_breg <- function(x, type = "xyz") |> emptyraster() }, silent = TRUE) - prediction[] <- out[,layer] + prediction[df_sub$rowid] <- out[,layer] } + names(prediction) <- layer return(prediction) },overwrite = TRUE) diff --git a/R/engine_gdb.R b/R/engine_gdb.R index 1305bfbe..ef7d2b69 100644 --- a/R/engine_gdb.R +++ b/R/engine_gdb.R @@ -553,7 +553,7 @@ engine_gdb <- function(x, type = "xyz") |> emptyraster() }, silent = TRUE) - prediction[] <- y[,1] + prediction[as.numeric(newdata_sub$rowid)] <- y[,1] } names(prediction) <- "mean" # Rename to mean, layer parameter gets ignored for this engine return(prediction) diff --git a/R/engine_glmnet.R b/R/engine_glmnet.R index 0c8895ae..2111b8f7 100644 --- a/R/engine_glmnet.R +++ b/R/engine_glmnet.R @@ -855,7 +855,7 @@ engine_glmnet <- function(x, type = "xyz") |> emptyraster() }, silent = TRUE) - prediction[] <- pred_gn[, layer] + prediction[df_sub$rowid] <- pred_gn[, layer] } return(prediction) diff --git a/R/engine_scampr.R b/R/engine_scampr.R index 7b36c0a7..ce70ae66 100644 --- a/R/engine_scampr.R +++ b/R/engine_scampr.R @@ -796,7 +796,7 @@ engine_scampr <- function(x, type = "xyz") |> emptyraster() }, silent = TRUE) - prediction[] <- out + prediction[df_sub$rowid] <- out } names(prediction) <- layer } else { diff --git a/R/project.R b/R/project.R index 7f1f3d38..223565e0 100644 --- a/R/project.R +++ b/R/project.R @@ -129,6 +129,14 @@ methods::setMethod( new_preds <- mod$get_predictors() if(is.Waiver(new_preds)) stop('No scenario predictors found.') + # Check extents of models and raise a warning otherwise + if(!is.Waiver(fit$model$predictors_object)){ + if(fit$model$predictors_object$ncell() != new_preds$ncell()){ + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Scenario]','yellow',paste0('Model predictors and scenario predictors have different resolution!')) + } + } + + new_crs <- new_preds$get_projection() if(is.na(new_crs)) if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Scenario]','yellow','Missing projection of future predictors.') @@ -348,7 +356,7 @@ methods::setMethod( # TODO: Consider doing this in parallel but sequential times <- sort(unique(df$time)) - for(step in times){ + for(step in times){ # step = times[1] # Get data nd <- subset(df, time == step) From b8106d98981819bc8045f2e520caedfc57a8f96f Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Tue, 20 Aug 2024 15:37:10 +0200 Subject: [PATCH 04/21] Bug fix related to #133 --- R/engine_gdb.R | 4 +++- man/BiodiversityScenario-class.Rd | 35 +++++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/R/engine_gdb.R b/R/engine_gdb.R index ef7d2b69..c9915b46 100644 --- a/R/engine_gdb.R +++ b/R/engine_gdb.R @@ -627,8 +627,10 @@ engine_gdb <- function(x, } # Now predict with model + # MH: There seems to be a problem if variables have some name overlap e.g., dbh and dbh_cv + # because in this case two columns are returned which is an issue later suppressWarnings(pp <- mboost::predict.mboost(object = self$get_data('fit_best'), - newdata = dummy_temp, which = v, + newdata = dummy_temp, which = which(names(dummy_temp) == v), type = type, aggregate = 'sum')) # If bbs is present and non-linear, use bbs estimate. If model is fitted diff --git a/man/BiodiversityScenario-class.Rd b/man/BiodiversityScenario-class.Rd index fc119746..82f17f71 100644 --- a/man/BiodiversityScenario-class.Rd +++ b/man/BiodiversityScenario-class.Rd @@ -58,6 +58,7 @@ This requires set \code{\link{threshold}} prior to projection. \item \href{#method-BiodiversityScenario-get_resolution}{\code{BiodiversityScenario$get_resolution()}} \item \href{#method-BiodiversityScenario-get_model}{\code{BiodiversityScenario$get_model()}} \item \href{#method-BiodiversityScenario-get_limits}{\code{BiodiversityScenario$get_limits()}} +\item \href{#method-BiodiversityScenario-rm_limits}{\code{BiodiversityScenario$rm_limits()}} \item \href{#method-BiodiversityScenario-get_predictor_names}{\code{BiodiversityScenario$get_predictor_names()}} \item \href{#method-BiodiversityScenario-get_timeperiod}{\code{BiodiversityScenario$get_timeperiod()}} \item \href{#method-BiodiversityScenario-get_constraints}{\code{BiodiversityScenario$get_constraints()}} @@ -72,6 +73,7 @@ This requires set \code{\link{threshold}} prior to projection. \item \href{#method-BiodiversityScenario-get_predictors}{\code{BiodiversityScenario$get_predictors()}} \item \href{#method-BiodiversityScenario-rm_predictors}{\code{BiodiversityScenario$rm_predictors()}} \item \href{#method-BiodiversityScenario-get_data}{\code{BiodiversityScenario$get_data()}} +\item \href{#method-BiodiversityScenario-rm_data}{\code{BiodiversityScenario$rm_data()}} \item \href{#method-BiodiversityScenario-set_data}{\code{BiodiversityScenario$set_data()}} \item \href{#method-BiodiversityScenario-set_latent}{\code{BiodiversityScenario$set_latent()}} \item \href{#method-BiodiversityScenario-get_latent}{\code{BiodiversityScenario$get_latent()}} @@ -203,6 +205,19 @@ A \code{\link{sf}} object or NULL. } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-BiodiversityScenario-rm_limits}{}}} +\subsection{Method \code{rm_limits()}}{ +Remove current limits. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{BiodiversityScenario$rm_limits()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +Invisible +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-BiodiversityScenario-get_predictor_names}{}}} \subsection{Method \code{get_predictor_names()}}{ @@ -434,6 +449,26 @@ This object. } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-BiodiversityScenario-rm_data}{}}} +\subsection{Method \code{rm_data()}}{ +Remove scenario predictions +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{BiodiversityScenario$rm_data()}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{what}}{A \code{\link{character}} vector with names of what} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +Invisible +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-BiodiversityScenario-set_data}{}}} \subsection{Method \code{set_data()}}{ From f282d581e9dba0ab1ccdeeaa408eb94813b6b1a0 Mon Sep 17 00:00:00 2001 From: Martin Jung <3788377+Martin-Jung@users.noreply.github.com> Date: Thu, 22 Aug 2024 22:15:15 +0200 Subject: [PATCH 05/21] Addition of parallel computing with future #18 (#134) * Parallel processing with future fixes * Breg future done plus minor modal addition * Part implemented (although sadly not working as planned) * GDB updated for future * Addition of future to glmnet * Small FAQ vignette * :bug: fix for breg and added test #18 --- DESCRIPTION | 8 +- NAMESPACE | 5 + NEWS.md | 1 + R/engine_bart.R | 76 ++--- R/engine_breg.R | 147 ++++---- R/engine_gdb.R | 81 ++++- R/engine_glm.R | 178 +++++++--- R/engine_glmnet.R | 180 +++++++--- R/ensemble.R | 12 +- R/ibis.iSDM-package.R | 4 + R/misc.R | 313 ++++++++++++++++-- R/project.R | 1 - R/utils-bart.R | 113 ++++++- R/utils-breg.R | 140 ++++++-- R/utils-stan.R | 11 +- R/utils.R | 129 +------- R/validate.R | 2 +- R/zzz.R | 3 +- _pkgdown.yml | 12 +- man/engine_bart.Rd | 2 +- man/engine_gdb.Rd | 4 + man/ensemble.Rd | 1 + man/ibis_enable_parallel.Rd | 21 ++ man/ibis_future.Rd | 39 ++- man/ibis_set_strategy.Rd | 31 ++ man/ibis_set_threads.Rd | 21 ++ man/modal.Rd | 26 ++ man/posterior_predict_stanfit.Rd | 4 +- man/run_parallel.Rd | 45 +++ man/validate.Rd | 2 +- tests/testthat/test_functions.R | 8 + tests/testthat/test_parallelPrediction.R | 85 +++++ .../08_frequently-asked-questions.Rmd | 33 ++ 33 files changed, 1302 insertions(+), 436 deletions(-) create mode 100644 man/ibis_enable_parallel.Rd create mode 100644 man/ibis_set_strategy.Rd create mode 100644 man/ibis_set_threads.Rd create mode 100644 man/modal.Rd create mode 100644 man/run_parallel.Rd create mode 100644 tests/testthat/test_parallelPrediction.R diff --git a/DESCRIPTION b/DESCRIPTION index 4f950c49..4d23f59f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,16 +32,17 @@ Imports: R6 (>= 2.5.0), assertthat (>= 0.2.0), doFuture (>= 0.12.2), - dplyr, - foreach, future (>= 1.23.0), + parallelly (>= 1.30.0), + parallel, + foreach, + dplyr, geodist, ggplot2, graphics, methods, Matrix, ncdf4, - parallel, posterior, sf (>= 1.0), stars (>= 0.5), @@ -60,7 +61,6 @@ Suggests: cubelyr, dbarts (>= 0.9-22), deldir, - doParallel, ellipsis, glmnet (>= 4.1), glmnetUtils, diff --git a/NAMESPACE b/NAMESPACE index d4780c69..01528af1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -105,8 +105,11 @@ export(get_ngbvalue) export(get_priors) export(get_rastervalue) export(ibis_dependencies) +export(ibis_enable_parallel) export(ibis_future) export(ibis_options) +export(ibis_set_strategy) +export(ibis_set_threads) export(interpolate_gaps) export(is.Id) export(is.Raster) @@ -119,6 +122,7 @@ export(mask.BiodiversityDatasetCollection) export(mask.BiodiversityScenario) export(mask.DistributionModel) export(mask.PredictorDataset) +export(modal) export(new_id) export(new_waiver) export(partial) @@ -140,6 +144,7 @@ export(rm_limits) export(rm_offset) export(rm_predictors) export(rm_priors) +export(run_parallel) export(run_stan) export(sanitize_names) export(scenario) diff --git a/NEWS.md b/NEWS.md index fe33bd94..b9880261 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ #### New features #### Minor improvements and bug fixes +* Support for modal value calculations in `ensemble()` and export of method. * Minor :bug: fix related to misaligned thresholds and negative exponential kernels. * :fire: :bug: fix for scenario projections that use different grain sizes than for inference. diff --git a/R/engine_bart.R b/R/engine_bart.R index 06338f78..37e03d21 100644 --- a/R/engine_bart.R +++ b/R/engine_bart.R @@ -20,7 +20,7 @@ NULL #' sum-of-trees formulation (Default: \code{1000}). #' @param nburn A [`numeric`] estimate of the burn in samples (Default: \code{250}). #' @param chains A number of the number of chains to be used (Default: \code{4}). -#' @param type The mode used for creating posterior predictions. Either \code{"link"} +#' @param type The type used for creating posterior predictions. Either \code{"link"} #' or \code{"response"} (Default: \code{"response"}). #' @param ... Other options. #' @@ -100,7 +100,8 @@ engine_bart <- function(x, n.burn = nburn, n.trees = iter, n.chains = chains, - n.threads = ifelse( dbarts::guessNumCores() < getOption('ibis.nthread'),dbarts::guessNumCores(),getOption('ibis.nthread')) + n.threads = ifelse( dbarts::guessNumCores() < getOption('ibis.nthread'), + dbarts::guessNumCores(), getOption('ibis.nthread')) ) # Other parameters # Set up the parameter list @@ -473,58 +474,49 @@ engine_bart <- function(x, full[[settings$get('bias_variable')[i]]] <- settings$get('bias_value')[i] } } - check_package("foreach") params <- self$get_data("params") - full$rowid <- 1:nrow(full) + if(is.Waiver(model$offset)) of <- NULL else of <- scales::rescale(model$offset[full$cellid, "spatial_offset"], to = c(1e-6, 1)) - # Tile the problem - splits <- cut(1:nrow(full), nrow(full) / min(nrow(full) / 4, 5000) ) + if(getOption("ibis.runparallel",default = FALSE)){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } - # Get offset if existing - if(is.Waiver(model$offset)) of <- NULL else of <- scales::rescale(model$offset[full$cellid, "spatial_offset"], to = c(1e-6, 1)) + out <- predict_bart(obj = fit_bart, + newdata = full[, model$biodiversity[[1]]$predictors_names], + params = params, + w = w, + of = of, + # FIXME: Somehow parallel prediction do not work with dbarts (RNG) + # All estimates are 0.5 (random) + # By default turned off.... + run_future = FALSE, + N = NULL) - # Make a prediction - ms <- foreach::foreach(s = unique(splits), - .inorder = TRUE, - .combine = rbind, - .errorhandling = "stop", - .multicombine = TRUE, - .export = c("splits", "fit_bart", "full", "model", "params", "of"), - .packages = c("dbarts", "matrixStats")) %do% { - i <- which(splits == s) - - pred_bart <- predict(object = fit_bart, - newdata = full[i, model$biodiversity[[1]]$predictors_names], - type = params$type, - offset = of[i] - ) - # Summarize quantiles and sd from posterior - ms <- as.data.frame( - cbind( apply(pred_bart, 2, function(x) mean(x, na.rm = TRUE)), - matrixStats::colSds(pred_bart), - matrixStats::colQuantiles(pred_bart, probs = c(.05,.5,.95)), - apply(pred_bart, 2, mode) - ) - ) - names(ms) <- c("mean","sd", "q05", "q50", "q95", "mode") - ms$cv <- ms$sd / ms$mean - rm(pred_bart) - return( ms ) - } # End of processing - assertthat::assert_that(nrow(ms)>0, - nrow(ms) == nrow(full)) + } else { + out <- predict_bart(obj = fit_bart, + newdata = full[, model$biodiversity[[1]]$predictors_names], + params = params, + w = w, + of = of, + run_future = FALSE, + N = NULL) + } + # End of processing + assertthat::assert_that(nrow(out)>0) # Add them through a loop since the cellid changed prediction <- terra::rast() - for(post in names(ms)){ + for(post in names(out)){ prediction2 <- self$get_data('template') - prediction2[as.numeric(full$cellid)] <- ms[[post]]; names(prediction2) <- post + prediction2[as.numeric(full$cellid)] <- out[[post]]; names(prediction2) <- post suppressWarnings( prediction <- c(prediction, prediction2) ) rm(prediction2) } # plot(prediction$mean, col = ibis_colours$sdm_colour) - try({rm(ms, full)},silent = TRUE) + try({rm(out, full)},silent = TRUE) } else { # No prediction done prediction <- NULL @@ -676,7 +668,7 @@ engine_bart <- function(x, "q50" = matrixStats::rowQuantiles(pred_bart, probs = c(.5)), "median" = matrixStats::rowQuantiles(pred_bart, probs = c(.5)), "q95" = matrixStats::rowQuantiles(pred_bart, probs = c(.95)), - "mode" = apply(pred_bart, 1, mode), + "mode" = apply(pred_bart, 1, modal), "cv" <- matrixStats::rowSds(pred_bart) / matrixStats::rowMeans2(pred_bart) ) diff --git a/R/engine_breg.R b/R/engine_breg.R index 604a1a5c..8719732a 100644 --- a/R/engine_breg.R +++ b/R/engine_breg.R @@ -444,55 +444,30 @@ engine_breg <- function(x, w_full_sub <- w_full[full_sub$rowid] assertthat::assert_that((nrow(full_sub) == length(w_full_sub)) || is.null(w_full_sub) ) - # Tile the problem - splits <- cut(1:nrow(full_sub), nrow(full_sub) / (min(100, nrow(full_sub) / 10)) ) - # Now depending on parallization setting use foreach if(getOption("ibis.runparallel")){ - # Check that future is registered - if(!foreach::getDoParRegistered()) ibis_future(cores = getOption("ibis.nthread"), - strategy = getOption("ibis.futurestrategy")) - - # Run the outgoing command - # out <- foreach::foreach(s = unique(splits), - # .combine = rbind, - # .export = c("splits", "fit_breg", "full_sub", - # "w_full_sub", "fam", "params"), - # .packages = c("matrixStats"), - # .multicombine = TRUE, - # .inorder = TRUE, - # verbose = settings$get("verbose") ) %do% { - out <- parallel::mclapply(unique(splits), function(s) { - i <- which(splits == s) - # -> external code in utils-boom - pred_breg <- predict_boom( - obj = fit_breg, - newdata = full_sub[i,], - w = w_full_sub[i], - fam = fam, - params = params - ) - # Summarize the posterior - preds <- as.data.frame( - cbind( - matrixStats::rowMeans2(pred_breg, na.rm = TRUE), - matrixStats::rowSds(pred_breg, na.rm = TRUE), - matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE), - apply(pred_breg, 1, mode) - ) - ) - names(preds) <- c("mean", "sd", "q05", "q50", "q95", "mode") - preds$cv <- preds$sd / preds$mean - return(preds) - }) - out <- do.call(rbind, out) + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + # Prediction function + out <- predict_boom(obj = fit_breg, + newdata = full_sub, + w = w_full_sub, + fam = fam, + params = params, + run_future = TRUE, + N = NULL) + } else { + # Tile the problem + splits <- chunk_data(full_sub,N = (min(100, nrow(full_sub) / 10)), index_only = TRUE) + out <- data.frame() - pb <- progress::progress_bar$new(total = length(levels(unique(splits))), + pb <- progress::progress_bar$new(total = length(splits), format = "Creating model prediction (:spin) [:bar] :percent") - for(s in unique(splits)){ + for(i in splits){ pb$tick() - i <- which(splits == s) # -> external code in utils-boom pred_breg <- predict_boom( obj = fit_breg, @@ -506,7 +481,7 @@ engine_breg <- function(x, matrixStats::rowMeans2(pred_breg, na.rm = TRUE), matrixStats::rowSds(pred_breg, na.rm = TRUE), matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE), - apply(pred_breg, 1, mode) + apply(pred_breg, 1, modal) ) |> as.data.frame() names(preds) <- c("mean", "sd", "q05", "q50", "q95", "mode") preds$cv <- preds$sd / preds$mean @@ -515,7 +490,7 @@ engine_breg <- function(x, } } assertthat::assert_that(is.data.frame(out), nrow(out)>0, - msg = "Something went wrong withe prediction. Output empty!") + msg = "Something went wrong with the prediction. Output empty!") # Fill output with summaries of the posterior stk <- terra::rast() for(v in colnames(out)){ @@ -624,7 +599,7 @@ engine_breg <- function(x, matrixStats::rowMeans2(pred_breg, na.rm = TRUE), matrixStats::rowSds(pred_breg, na.rm = TRUE), matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE), - apply(pred_breg, 1, mode) + apply(pred_breg, 1, modal) ) |> as.data.frame() names(pred_part) <- c("mean", "sd", "q05", "q50", "q95", "mode") @@ -724,10 +699,12 @@ engine_breg <- function(x, pred_part <- cbind( matrixStats::rowMeans2(pred_breg, na.rm = TRUE), matrixStats::rowSds(pred_breg, na.rm = TRUE), - matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE), - apply(pred_breg, 1, mode) + matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE) ) |> as.data.frame() - names(pred_part) <- c("mean", "sd", "q05", "q50", "q95", "mode") + names(pred_part) <- c("mean", "sd", "q05", "q50", "q95") + assertthat::assert_that(all(is.numeric(pred_part[,1])), + msg = "Posterior summarizing issue...?") + pred_part$mode <- apply(pred_breg, 1, modal) pred_part$cv <- pred_part$sd / pred_part$mean # Now create spatial prediction @@ -812,36 +789,52 @@ engine_breg <- function(x, # For Integrated model, take the last one fam <- model$biodiversity[[length(model$biodiversity)]]$family - # Rather predict in steps than for the whole thing - out <- data.frame() + if(getOption("ibis.runparallel",default = FALSE)){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + # Prediction function + out <- predict_boom(obj = mod, + newdata = df_sub, + w = unique(w)[2], + fam = fam, + params = settings$data, + run_future = TRUE, + N = NULL) + } else { + # Sequential prediction + # Rather predict in steps than for the whole thing + out <- data.frame() - # Tile the problem - splits <- cut(1:nrow(df_sub), nrow(df_sub) / (min(100, nrow(df_sub) / 10)) ) + # Tile the problem + splits <- cut(1:nrow(df_sub), nrow(df_sub) / (min(100, nrow(df_sub) / 10)) ) - pb <- progress::progress_bar$new(total = length(levels(unique(splits))), - format = "Projecting on new data (:spin) [:bar] :percent") - for(s in unique(splits)){ - pb$tick() - i <- which(splits == s) - # -> external code in utils-boom - pred_breg <- predict_boom( - obj = mod, - newdata = df_sub[i,], - w = unique(w)[2], - fam = fam, - params = settings$data - ) - # Summarize the posterior - preds <- cbind( - matrixStats::rowMeans2(pred_breg, na.rm = TRUE), - matrixStats::rowSds(pred_breg, na.rm = TRUE), - matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE), - apply(pred_breg, 1, mode) - ) |> as.data.frame() - names(preds) <- c("mean", "sd", "q05", "q50", "q95", "mode") - preds$cv <- preds$sd / preds$mean - out <- rbind(out, preds) - rm(preds, pred_breg) + pb <- progress::progress_bar$new(total = length(levels(unique(splits))), + format = "Projecting on new data (:spin) [:bar] :percent") + for(s in unique(splits)){ + pb$tick() + i <- which(splits == s) + # -> external code in utils-boom + pred_breg <- predict_boom( + obj = mod, + newdata = df_sub[i,], + w = unique(w)[2], + fam = fam, + params = settings$data + ) + # Summarize the posterior + preds <- cbind( + matrixStats::rowMeans2(pred_breg, na.rm = TRUE), + matrixStats::rowSds(pred_breg, na.rm = TRUE), + matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE), + apply(pred_breg, 1, modal) + ) |> as.data.frame() + names(preds) <- c("mean", "sd", "q05", "q50", "q95", "mode") + preds$cv <- preds$sd / preds$mean + out <- rbind(out, preds) + rm(preds, pred_breg) + } } # Now create spatial prediction diff --git a/R/engine_gdb.R b/R/engine_gdb.R index c9915b46..0059d3bc 100644 --- a/R/engine_gdb.R +++ b/R/engine_gdb.R @@ -31,6 +31,10 @@ NULL #' baselearners via [add_latent_spatial] or the specification of monotonically #' constrained priors via [GDBPrior]. #' +#' @note +#' The coefficients resulting from gdb with poipa data (Binomial) are only 0.5 +#' of the typical coefficients of a logit model obtained via glm (see Binomial). +#' #' @returns An engine. #' #' @references @@ -476,13 +480,41 @@ engine_gdb <- function(x, } } - # Make a prediction - suppressWarnings( - pred_gdb <- mboost::predict.mboost(object = fit_gdb, newdata = full, - type = self$get_data('params')$type, - aggregate = 'sum', - offset = full$w) - ) + if(getOption("ibis.runparallel",default = FALSE)){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + + # Chunk the data + splits <- chunk_data(full, N = getOption("ibis.nthread",default = 10), index_only = TRUE) + + pred_gdb <- foreach::foreach(s = splits, + .combine = "rbind", + .inorder = TRUE, + .options.future = list(seed = TRUE, + packages = c("mboost")) + ) %dofuture% { + # Make a prediction + suppressWarnings( + mboost::predict.mboost(object = fit_gdb, + newdata = full[s,], + type = self$get_data('params')$type, + aggregate = 'sum', + offset = full$w[s]) + ) + } + + } else { + # Make a prediction + suppressWarnings( + pred_gdb <- mboost::predict.mboost(object = fit_gdb, newdata = full, + type = self$get_data('params')$type, + aggregate = 'sum', + offset = full$w) + ) + } + # Fill output prediction[as.numeric(full$cellid)] <- pred_gdb[,1] names(prediction) <- 'mean' @@ -534,11 +566,36 @@ engine_gdb <- function(x, # Subset to non-missing data newdata_sub <- subset(newdata, stats::complete.cases(newdata)) - # Predict - y <- suppressWarnings( - mboost::predict.mboost(object = mod, newdata = newdata_sub, - type = type, aggregate = 'sum') - ) + if(getOption("ibis.runparallel",default = FALSE)){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + # Chunk the data + splits <- chunk_data(newdata_sub, N = getOption("ibis.nthread",default = 10), + index_only = TRUE) + + y <- foreach::foreach(s = splits, + .combine = "rbind", + .inorder = TRUE, + .options.future = list(seed = TRUE, + packages = c("mboost")) + ) %dofuture% { + # Make a prediction + suppressWarnings( + mboost::predict.mboost(object = mod, + newdata = newdata_sub[s,], + type = type, + aggregate = 'sum') + ) + } + } else { + # Predict + y <- suppressWarnings( + mboost::predict.mboost(object = mod, newdata = newdata_sub, + type = type, aggregate = 'sum') + ) + } # Make empty template if(nrow(newdata)==nrow(model$predictors)){ diff --git a/R/engine_glm.R b/R/engine_glm.R index b585176c..1e6a8912 100644 --- a/R/engine_glm.R +++ b/R/engine_glm.R @@ -327,29 +327,29 @@ engine_glm <- function(x, all(w >= 0,na.rm = TRUE) ) # --- # - # Determine the optimal lambda through k-fold cross-validation - if(getOption("ibis.runparallel")){ - if(!foreach::getDoParRegistered()) ibis_future(cores = getOption("ibis.nthread"), - strategy = getOption("ibis.futurestrategy")) - } - # Depending if regularized should be set, specify this separately + # Fit Base model + suppressWarnings( + fit_glm <- try({ + stats::glm(formula = form, + data = df, + weights = w, # Case weights + family = fam, + na.action = "na.pass", + control = params$control + ) + },silent = FALSE) + ) + if(inherits(fit_glm, "try-error")) stop("Model failed to converge with provided input data!") if( (settings$get('optim_hyperparam')) ){ - if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Estimation]','yellow', - 'No hyperparameter optimization for glm implemented!') - } else { + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Estimation]','green', + 'Running step-wise AIC selection for glm!') suppressWarnings( - fit_glm <- try({ - stats::glm(formula = form, - data = df, - weights = w, # Case weights - family = fam, - na.action = "na.pass", - control = params$control - ) - },silent = FALSE) + fit_glm <- stats::step(fit_glm, + direction = "backward", + trace = ifelse(getOption('ibis.setupmessages', default = TRUE),1,0) + ) ) } - if(inherits(fit_glm, "try-error")) stop("Model failed to converge with provided input data!") # --- # # Predict spatially @@ -368,20 +368,57 @@ engine_glm <- function(x, } # Make a subset of non-na values full$rowid <- 1:nrow(full) - full_sub <- subset(full, stats::complete.cases(full)) - w_full_sub <- w_full[full_sub$rowid] - assertthat::assert_that((nrow(full_sub) == length(w_full_sub)) || is.null(w_full_sub) ) # Attempt prediction - out <- try({ - stats::predict.glm(object = fit_glm, - newdata = full, - type = params$type, - se.fit = TRUE, - na.action = "na.pass", - weights = w_full + if( getOption('ibis.runparallel',default = FALSE) ){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + + # Prediction function + do_run <- function() { + # Chunck the data + splits <- chunk_data(full, N = getOption("ibis.nthread"),index_only = TRUE) + + y <- foreach::foreach(s = splits, + .inorder = TRUE + # .options.future = list(globals = )) + ) %dofuture% { + stats::predict.glm(object = fit_glm, + newdata = full[s,], + type = params$type, + se.fit = TRUE, + na.action = "na.pass", + weights = w_full[s,] + ) + } + y + } + # Run + result <- do_run() + # Combine all + # FIXME: hacky list flattener, but works. Reduce and do.call failed + out <- list() + for(k in 1:length(result)){ + out[['fit']] <- c(out[['fit']], result[[k]]$fit) + out[['se.fit']] <- c(out[['se.fit']], result[[k]]$se.fit) + } + # Security check + assertthat::assert_that( + length(out$fit) == nrow(full) ) - },silent = TRUE) + } else { + out <- try({ + stats::predict.glm(object = fit_glm, + newdata = full, + type = params$type, + se.fit = TRUE, + na.action = "na.pass", + weights = w_full + ) + },silent = TRUE) + } if(!inherits(out,"try-error")){ # Fill output with summaries of the posterior prediction <- fill_rasters(out |> as.data.frame(), @@ -392,7 +429,7 @@ engine_glm <- function(x, } else { stop("GLM prediction failed!") } - try({rm(out, full, full_sub)},silent = TRUE) + try({rm(out, full)},silent = TRUE) } else { # No prediction done prediction <- NULL @@ -649,29 +686,66 @@ engine_glm <- function(x, if(!is.Waiver(model$offset)) ofs <- model$offset else ofs <- NULL assertthat::assert_that(nrow(df)>0) - if(is.null(ofs)){ - pred_glm <- stats::predict.glm( - object = mod, - newdata = df, - weights = df$w, # The second entry of unique contains the non-observed variables - se.fit = FALSE, - na.action = "na.pass", - fam = fam, - type = type - ) |> as.data.frame() + # Run in parallel if specified or not. + if( getOption('ibis.runparallel',default = FALSE) ){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + + # Prediction function + do_run <- function() { + # Chunck the data + splits <- chunk_data(df, N = getOption("ibis.nthread",default = 10),index_only = TRUE) + + y <- foreach::foreach(s = splits, + .inorder = TRUE + # .options.future = list(globals = )) + ) %dofuture% { + stats::predict.glm(object = mod, + newdata = df[s,], + type = type, + se.fit = FALSE, + na.action = "na.pass", + weights = df$w[s] + ) + } + y + } + # Run + result <- do_run() + # Combine all + # FIXME: hacky list flattener, but works. Reduce and do.call failed + pred_glm <- list() + for(k in 1:length(result)){ + pred_glm[['fit']] <- c(pred_glm[['fit']], result[[k]]$fit) + } + pred_glm <- as.data.frame(pred_glm) + } else { - pred_glm <- stats::predict.glm( - object = mod, - newdata = df, - weights = df$w, # The second entry of unique contains the non-observed variables - offset = ofs, - se.fit = FALSE, - na.action = "na.pass", - fam = fam, - type = type - ) |> as.data.frame() + if(is.null(ofs)){ + pred_glm <- stats::predict.glm( + object = mod, + newdata = df, + weights = df$w, # The second entry of unique contains the non-observed variables + se.fit = FALSE, + na.action = "na.pass", + fam = fam, + type = type + ) |> as.data.frame() + } else { + pred_glm <- stats::predict.glm( + object = mod, + newdata = df, + weights = df$w, # The second entry of unique contains the non-observed variables + offset = ofs, + se.fit = FALSE, + na.action = "na.pass", + fam = fam, + type = type + ) |> as.data.frame() + } } - names(pred_glm) <- layer assertthat::assert_that(nrow(pred_glm)>0, nrow(pred_glm) == nrow(df)) diff --git a/R/engine_glmnet.R b/R/engine_glmnet.R index 2111b8f7..92d43a84 100644 --- a/R/engine_glmnet.R +++ b/R/engine_glmnet.R @@ -498,32 +498,76 @@ engine_glmnet <- function(x, w_full_sub <- w_full[full_sub$rowid] assertthat::assert_that((nrow(full_sub) == length(w_full_sub)) || is.null(w_full_sub) ) - # Attempt prediction - if(inherits(cv_gn, "cv.glmnet")){ - out <- predict(object = cv_gn, - newdata = full_sub, - weights = w_full_sub, - newoffset = ofs_pred[full_sub$rowid], - s = determine_lambda(cv_gn), # Determine the best lambda value - type = params$type - ) + if(getOption("ibis.runparallel",default = FALSE)){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + # Chunk the data + splits <- chunk_data(full_sub, N = getOption("ibis.nthread",default = 10), + index_only = TRUE) + + lambda <- determine_lambda(cv_gn) + + out <- foreach::foreach(s = splits, + .combine = "rbind", + .inorder = TRUE, + .options.future = list(seed = TRUE, + packages = c("glmnet", "glmnetUtils")) + ) %dofuture% { + # Make a prediction + if(inherits(cv_gn, "cv.glmnet")){ + out <- predict(object = cv_gn, + newdata = full_sub[s,], + weights = w_full_sub[s], + newoffset = ofs_pred[full_sub$rowid[s]], + s = lambda, # Determine the best lambda value + type = params$type + ) + } else { + # Assume cva.glmnet + out <- predict( + object = cv_gn, + newdata = full_sub[s,], + alpha = cv_gn$alpha, + weights = w_full_sub[s], + newoffset = ofs_pred[full_sub$rowid[s]], + s = lambda, # Determine the best lambda value + type = params$type + ) + # Determine best model based on cross-validated loss + # ind <- which.min( sapply(cv_gn$modlist, function(z) min(z$cvup)) ) + # cv_gn <- cv_gn$modlist[[ind]] + } + return(out) + } } else { - # Assume cva.glmnet - out <- predict( - object = cv_gn, - newdata = full_sub, - alpha = cv_gn$alpha, - weights = w_full_sub, - newoffset = ofs_pred[full_sub$rowid], - s = determine_lambda(cv_gn), # Determine the best lambda value - type = params$type - ) - # Determine best model based on cross-validated loss - # ind <- which.min( sapply(cv_gn$modlist, function(z) min(z$cvup)) ) - # cv_gn <- cv_gn$modlist[[ind]] + # Attempt prediction + if(inherits(cv_gn, "cv.glmnet")){ + out <- predict(object = cv_gn, + newdata = full_sub, + weights = w_full_sub, + newoffset = ofs_pred[full_sub$rowid], + s = determine_lambda(cv_gn), # Determine the best lambda value + type = params$type + ) + } else { + # Assume cva.glmnet + out <- predict( + object = cv_gn, + newdata = full_sub, + alpha = cv_gn$alpha, + weights = w_full_sub, + newoffset = ofs_pred[full_sub$rowid], + s = determine_lambda(cv_gn), # Determine the best lambda value + type = params$type + ) + # Determine best model based on cross-validated loss + # ind <- which.min( sapply(cv_gn$modlist, function(z) min(z$cvup)) ) + # cv_gn <- cv_gn$modlist[[ind]] + } } - # Fill output with summaries of the posterior prediction[full_sub$rowid] <- out[,1] names(prediction) <- "mean" @@ -815,29 +859,75 @@ engine_glmnet <- function(x, if(!is.Waiver(model$offset)) ofs <- model$offset[df_sub$rowid] else ofs <- NULL assertthat::assert_that(nrow(df_sub)>0) - if(inherits(mod, "cv.glmnet")){ - pred_gn <- predict( - object = mod, - newdata = df_sub, - weights = df_sub$w, # The second entry of unique contains the non-observed variables - newoffset = ofs, - na.action = "na.pass", - s = determine_lambda(mod), # Determine best available lambda - fam = fam, - type = type - ) |> as.data.frame() + if(getOption("ibis.runparallel",default = FALSE)){ + check_package("doFuture") + if(!("doFuture" %in% loadedNamespaces()) || ('doFuture' %notin% utils::sessionInfo()$otherPkgs) ) { + try({requireNamespace('doFuture');attachNamespace("doFuture")},silent = TRUE) + } + # Chunk the data + splits <- chunk_data(df_sub, N = getOption("ibis.nthread",default = 10), + index_only = TRUE) + lambda <- determine_lambda(mod) + + pred_gn <- foreach::foreach(s = splits, + .combine = "rbind", + .inorder = TRUE, + .options.future = list(seed = TRUE, + packages = c("glmnet", "glmnetUtils")) + ) %dofuture% { + # Make a prediction + if(inherits(mod, "cv.glmnet")){ + ms <- predict( + object = mod, + newdata = df_sub[s,], + weights = df_sub$w[s], # The second entry of unique contains the non-observed variables + newoffset = ofs[s], + na.action = "na.pass", + s = lambda, # Determine best available lambda + fam = fam, + type = type + ) |> as.data.frame() + } else { + ms <- predict( + object = mod, + newdata = df_sub[s,], + alpha = mod$alpha[s], + weights = df_sub$w[s], # The second entry of unique contains the non-observed variables + newoffset = ofs[s], + na.action = "na.pass", + s = lambda, # Determine the best lambda value + fam = fam, + type = type + ) + } + return(ms) + } + } else { - pred_gn <- predict( - object = mod, - newdata = df_sub, - alpha = mod$alpha, - weights = df_sub$w, # The second entry of unique contains the non-observed variables - newoffset = ofs, - na.action = "na.pass", - s = determine_lambda(mod), # Determine the best lambda value - fam = fam, - type = type - ) + if(inherits(mod, "cv.glmnet")){ + pred_gn <- predict( + object = mod, + newdata = df_sub, + weights = df_sub$w, # The second entry of unique contains the non-observed variables + newoffset = ofs, + na.action = "na.pass", + s = determine_lambda(mod), # Determine best available lambda + fam = fam, + type = type + ) |> as.data.frame() + } else { + pred_gn <- predict( + object = mod, + newdata = df_sub, + alpha = mod$alpha, + weights = df_sub$w, # The second entry of unique contains the non-observed variables + newoffset = ofs, + na.action = "na.pass", + s = determine_lambda(mod), # Determine the best lambda value + fam = fam, + type = type + ) + } } names(pred_gn) <- layer assertthat::assert_that(nrow(pred_gn)>0, nrow(pred_gn) == nrow(df_sub)) diff --git a/R/ensemble.R b/R/ensemble.R index a4c96603..90fdb0b2 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -44,6 +44,7 @@ #' * \code{'median'} - Calculates the median of several predictions. #' * \code{'max'} - The maximum value across predictions. #' * \code{'min'} - The minimum value across predictions. +#' * \code{'mode'} - The mode/modal values as the most commonly occurring value. #' * \code{'weighted.mean'} - Calculates a weighted mean. Weights have to be supplied separately (e.g. TSS). #' * \code{'min.sd'} - Ensemble created by minimizing the uncertainty among predictions. #' * \code{'threshold.frequency'} - Returns an ensemble based on threshold frequency (simple count). Requires thresholds to be computed. @@ -135,7 +136,7 @@ methods::setMethod( ) # Check the method - method <- match.arg(method, c('mean', 'weighted.mean', 'median', 'max', 'min', + method <- match.arg(method, c('mean', 'weighted.mean', 'median', 'max', 'min','mode', 'threshold.frequency', 'min.sd', 'pca'), several.ok = FALSE) # Uncertainty calculation uncertainty <- match.arg(uncertainty, c('none','sd', 'cv', 'range', 'pca'), several.ok = FALSE) @@ -184,6 +185,8 @@ methods::setMethod( new <- max(ras, na.rm = TRUE) } else if(method == 'min'){ new <- min(ras, na.rm = TRUE) + } else if(method == 'mode'){ + new <- terra::modal(ras, na.rm = TRUE) } else if(method == 'weighted.mean'){ new <- terra::weighted.mean( ras, w = weights, na.rm = TRUE) } else if(method == 'threshold.frequency'){ @@ -275,6 +278,7 @@ methods::setMethod( method == "median" ~ median(ll_val, na.rm = TRUE), method == "max" ~ max(ll_val, na.rm = TRUE), method == "min" ~ min(ll_val, na.rm = TRUE), + method == "mode" ~ modal(ll_val, na.rm = TRUE), method == "weighted.mean" ~ weighted.mean(ll_val, w = weights, na.rm = TRUE), .default = mean(ll_val, na.rm = TRUE) ) @@ -338,6 +342,8 @@ methods::setMethod( new <- max(ras, na.rm = TRUE) } else if(method == 'min'){ new <- min(ras, na.rm = TRUE) + } else if(method == 'mode'){ + new <- terra::modal(ras, na.rm = TRUE) } else if(method == 'weighted.mean'){ new <- terra::weighted.mean( ras, w = weights, na.rm = TRUE) } else if(method == 'threshold.frequency'){ @@ -450,6 +456,9 @@ methods::setMethod( } else if(method == 'min'){ out <- apply(lmat[,4:ncol(lmat)], # On the assumption that col 1-3 are coordinates+time 1, function(x) min(x, na.rm = TRUE)) + } else if(method == 'mode'){ + out <- apply(lmat[,4:ncol(lmat)], # On the assumption that col 1-3 are coordinates+time + 1, function(x) modal(x, na.rm = TRUE)) } else if(method == 'weighted.mean'){ out <- apply(lmat[,4:ncol(lmat)], # On the assumption that col 1-3 are coordinates+time 1, function(x) weighted.mean(x, w = weights, na.rm = TRUE)) @@ -497,6 +506,7 @@ methods::setMethod( method == "median" ~ median(ll_val, na.rm = TRUE), method == "max" ~ max(ll_val, na.rm = TRUE), method == "min" ~ min(ll_val, na.rm = TRUE), + method == "mode" ~ modal(ll_val, na.rm = TRUE), method == "weighted.mean" ~ weighted.mean(ll_val, w = weights, na.rm = TRUE), .default = mean(ll_val, na.rm = TRUE) ) diff --git a/R/ibis.iSDM-package.R b/R/ibis.iSDM-package.R index 24bdf49b..31e9792f 100644 --- a/R/ibis.iSDM-package.R +++ b/R/ibis.iSDM-package.R @@ -29,6 +29,10 @@ globalVariables(c("background", "band", "bi_class", "bias", "geometry", #MJ: Added self here hoping that does not crash all methods. "self", + # Cores for parallel processing + "cores", + # Global prediction function + "predict_boom", "id", "included", "i", "km", "vt", "V2", "limit", "lower", "layer", diff --git a/R/misc.R b/R/misc.R index bf767879..27dbfe03 100644 --- a/R/misc.R +++ b/R/misc.R @@ -141,55 +141,310 @@ ibis_dependencies <- function(deps = getOption("ibis.dependencies"), update = TR invisible() } -#' Options to set up ibis for parallel processing with future +#' Set the parallel processing flag to TRUE +#' @description +#' Small helper function to enable parallel processing. If set +#' to \code{TRUE}, then parallel inference (if supported by engines) and projection is +#' enabled across the package. +#' For enabling prediction support beyond sequential prediction see the [`ibis_future`] function. +#' +#' @return Invisible +#' @seealso [future], [ibis_future] +#' @keywords misc +#' @export +ibis_enable_parallel <- function(){ + options('ibis.runparallel' = TRUE) + if(getOption('ibis.nthread')<2){ + myLog('[Setup]','yellow','Parallelization enabled but less than 2 nodes specified!') + } + invisible() +} + +#' Set the number of threads for parallel processing. +#' @description +#' Small helper function to respecify the strategy for parallel processing (Default: \code{'sequential'}). +#' @details +#' Currently supported strategies are: +#' +#' * \code{"sequential"} = Resolves futures sequentially in the current R process (Package default). +#' * \code{"multisession"} = Resolves futures asynchronously across \code{'cores'} sessions. +#' * \code{"multicore"} = Resolves futures asynchronously across on forked processes. Only works on UNIX systems! +#' * \code{"cluster"} = Resolves futures asynchronously in sessions on this or more machines. +#' * \code{"slurm"} = To be implemented: Slurm linkage via batchtools. +#' @param strategy A [`character`] with the strategy. +#' @return Invisible +#' @seealso [future], [ibis_future_run] +#' @keywords misc +#' @export +ibis_set_strategy <- function(strategy = "sequential"){ + assertthat::assert_that(is.character(strategy)) + + strategy <- match.arg(strategy, c("sequential", "multisession", "multicore", "cluster", "slurm"), + several.ok = FALSE) + options('ibis.futurestrategy' = strategy) + invisible() +} + +#' Set the threads for parallel processing. +#' @description +#' Small helper function to respecify the number of threads for parallel processing. +#' @param threads A [`numeric`] greater thna \code{0}. +#' @return Invisible +#' @seealso [future], [ibis_future_run] +#' @keywords misc +#' @export +ibis_set_threads <- function(threads = 2){ + assertthat::assert_that(is.numeric(threads), + threads >0) + options('ibis.nthread' = threads) + invisible() +} + +#' Internal function to enable (a)synchronous parallel processing +#' +#' @description +#' This function checks if parallel processing can be set up and enables it. +#' **Ideally this is done by the user for more control!** +#' In the package parallelization is usually only used for predictions and projections, +#' but not for inference in which case parallel inference should be handled by the engine. +#' @details +#' Currently supported strategies are: +#' +#' * \code{"sequential"} = Resolves futures sequentially in the current R process (Package default). +#' * \code{"multisession"} = Resolves futures asynchronously across \code{'cores'} sessions. +#' * \code{"multicore"} = Resolves futures asynchronously across on forked processes. Only works on UNIX systems! +#' * \code{"cluster"} = Resolves futures asynchronously in sessions on this or more machines. +#' * \code{"slurm"} = To be implemented: Slurm linkage via batchtools. +#' @note +#' The \code{'plan'} set by [future] exists after the function has been executed. +#' +#' If the aim is to parallize across many species, this is better done in a scripted solution. +#' Make sure not to parallize predictions within existing clusters to avoid out-of-memory +#' issues. #' #' @param cores A [`numeric`] number stating the number of cores to use. #' @param strategy A [`character`] denoting the strategy to be used for future. #' See help of [`future`] for options. (Default: \code{"multisession"}). +#' @param workers An optional list of remote machines or workers, e.g. \code{"c(remote.server.org)"}. +#' Alternatively a \code{"cluster"} object can be provided. #' -#' @return None +#' @return Invisible #' #' @seealso [future] #' @keywords misc #' #' @examples #' \dontrun{ -#' # Starts future job -#' ibis_future(cores = 4) +#' # Starts future job. F in this case is a prediction function. +#' ibis_future(cores = 4, strategy = "multisession") #' } #' #' @export -ibis_future <- function(cores = getOption("ibis.nthread"), strategy = getOption("ibis.futurestrategy")) { +ibis_future <- function(plan_exists = FALSE, + cores = getOption("ibis.nthread",default = 2), + strategy = getOption("ibis.futurestrategy"), + workers = NULL + ) { assertthat::assert_that( + is.logical(plan_exists), is.numeric(cores), - is.character(strategy) + is.character(strategy), + is.null(workers) || is.vector(workers) || (inherits(workers, "ClusterFuture")) ) - check_package("future") - # Check that number of cores don't exceed what is possible - assertthat::assert_that(cores <= future::availableCores()) - strategy <- match.arg(strategy, c("sequential", "multisession", "multicore", "cluster", "remote"), - several.ok = FALSE) + # Check if plan exists, if not specify new plan + if(!plan_exists){ + # Check that number of cores don't exceed what is possible + assertthat::assert_that(cores <= parallelly::availableCores()[[1]]) - if(isTRUE(Sys.info()[["sysname"]] == "Windows")){ - if(strategy == "multicore") stop("Multicore is not supported on windows!") - } + strategy <- match.arg(strategy, c("sequential", "multisession", "multicore", "cluster", "slurm"), + several.ok = FALSE) + + # Check if parallel processing is enabled + assertthat::assert_that( + getOption("ibis.runparallel", default = FALSE), + msg = "Parallel processing not enabled. Run 'ibis_enable_parallel()' !" + ) - # Define plan based on formulated strategy - if(strategy == "remote"){ - #TODO: See if a testing environment could be found. - stop("TBD. Requires specific setup.") - #e.g. cl <- makeCluster(4, type = "MPI") - } else if(strategy == "sequential") { - future::plan(strategy = future::sequential()) - } else if(strategy == "multisession"){ - future::plan(strategy = future::multisession(workers = cores) ) - } else if(strategy == "multicore"){ - future::plan(strategy = future::multicore(workers = cores) ) - } else if(strategy == "cluster"){ - future::plan(strategy = future::cluster(workers = cores) ) + # Check that more 1 connection is available + if(strategy != "sequential"){ + assertthat::assert_that(parallelly::availableConnections()>1, + msg = "No further connections are available for parallel processing!") + } + + # isTRUE(Sys.info()[["sysname"]] == "Windows") + if(strategy == "multicore" && !parallelly::supportsMulticore()){ + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','yellow','Parallization multicore not supported om windows. Changing to multisession.') + strategy <- "multisession" + } + + if(is.null(cores)) cores <- 4 # Arbitrary nr of cores if somehow not found + if(is.null(workers)) workers <- cores # If no workers are found, use the cores + + # --- # + # Define plan based on formulated strategy + if(strategy == "slurm"){ + #TODO: See if a testing environment could be found. + stop("Not yet implemented") + #e.g. cl <- makeCluster(4, type = "MPI") + } else if(strategy == "sequential") { + future::plan(strategy = "sequential") + } else if(strategy == "multisession"){ + future::plan(strategy = "multisession", workers = cores) + } else if(strategy == "multicore"){ + future::plan(strategy = "multicore", workers = cores) + } else if(strategy == "cluster"){ + future::plan(strategy = "cluster", workers = cores) + } } - # Register the doFuture adapate - doFuture::registerDoFuture() + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Setup]','green','Specified parallel processing plan with strategy: ', strategy) invisible() } + +#' Internal helper function to split a data.frame into chucnks +#' +#' @param X A [`data.frame`] or [`matrix`] object to be split. +#' @param N A [`numeric`] with the number of chunks smaller than \code{`nrow(X)`}. +#' @param cores A [`numeric`] with the number of processing cores. Used when \code{N} is \code{NULL}. +#' @param index_only [`logical`] on whether only the indices or split X as list is returnsed (Default: \code{FALSE}). +#' @keywords internal +#' @returns A [`list`] object. +#' @examples +#' # Chunck example data into 4 subsets +#' chunk_data(datasets::airquality, N = 4) +#' @noRd +chunk_data <- function(X, N = NULL, cores = parallel::detectCores(), index_only = FALSE){ + assertthat::assert_that( + is.data.frame(X) || is.matrix(X), + nrow(X) > 1, + is.numeric(cores), + is.null(N) || is.numeric(N), + is.logical(index_only) + ) + + n_vars <- nrow(X) + # Use cores as N otherwise + if(is.null(N)) N <- cores + chunk_size <- ceiling(n_vars / N) + n_chunks <- ceiling(n_vars / chunk_size) + + if(index_only){ + chunk_list <- list() + } else { + chunk_list <- vector(length = n_chunks, mode = "list") + } + for (i in seq_len(n_chunks)) { + if ((chunk_size * (i - 1) + 1) <= n_vars) { + chunk <- (chunk_size * (i - 1) + 1):(min(c(chunk_size * + i, n_vars))) + if(index_only){ + o <- chunk + } else { + o <- X[chunk, ] |> as.data.frame() + colnames(o) <- colnames(X) + } + chunk_list[[i]] <- o + rm(o) + } + } + assertthat::assert_that(is.list(chunk_list)) + if(!index_only){ + assertthat::assert_that(sum(sapply(chunk_list, nrow)) == nrow(X), + msg = "Something went wrong with the data chunking...") + } + return(chunk_list) +} + +#' Parallel computation of function +#' +#' @description Some computations take considerable amount of time to execute. +#' This function provides a helper wrapper for running functions of the +#' [`apply`] family to specified outputs. +#' +#' @param X A [`list`], [`data.frame`] or [`matrix`] object to be fed to a single +#' core or parallel [apply] call. +#' @param FUN A [`function`] passed on for computation. +#' @param cores A [numeric] of the number of cores to use (Default: \code{1}). +#' @param approach [`character`] for the parallelization approach taken (Options: +#' \code{"parallel"} or \code{"future"}). +#' @param export_package A [`vector`] with packages to export for use on parallel +#' nodes (Default: \code{NULL}). +#' +#' @details By default, the [parallel] package is used for parallel computation, +#' however an option exists to use the [future] package instead. +#' +#' @keywords utils +#' +#' @examples +#' \dontrun{ +#' run_parallel(list, mean, cores = 4) +#' } +#' +#' @export +run_parallel <- function(X, FUN, cores = 1, approach = "future", export_packages = NULL, ...) { + assertthat::assert_that( + is.list(X) || is.data.frame(X) || is.matrix(X), + is.function(FUN), + is.numeric(cores), + is.null(export_packages) || is.character(export_packages) + ) + message("The run_parallel function is likely deprecated and is only kept for reference...") + + # Match approach + approach <- match.arg(approach, c("parallel", "future"), several.ok = FALSE) + + # Collect dots + dots <- list(...) + + if(!is.list(X)){ + # Convert input object to a list of split parameters + X <- chunk_data(X, cores = cores) + input_type = "data.frame" # Save to aggregate later again + } else { input_type = "list"} + + # Process depending on cores + if (cores == 1) { + out <- lapply(X, FUN, ...) + } else { + if(approach == "parallel"){ + # check_package('doParallel') + # require(foreach) + # isTRUE(Sys.info()[["sysname"]] == "Windows") + # Other operating systems + if(!isTRUE(Sys.info()[["sysname"]] == "Windows") && is.list(X)) { + out <- parallel::mclapply(X = X, FUN = FUN, mc.cores = cores, + ...) + } else { + # Other operating systems + cl <- parallel::makePSOCKcluster(cores) + on.exit(parallel::stopCluster(cl)) + if(!is.null(export_packages)){ + # Send all specified packages to the cluster + for(val in export_packages){ + parallel::clusterExport(cl, varlist = val, + envir = as.environment(asNamespace(val))) + } + } + out <- parallel::parLapply(cl = cl, X = X, fun = FUN, ...) + } + # out <- foreach::foreach(z = iterators::iter(X), + # .combine = ifelse(input_type!="list", "rbind", foreach:::defcombine), + # .inorder = FALSE, + # .multicombine = TRUE, + # .errorhandling = 'stop', + # .export = c("FUN"), + # .packages = export_packages, + # ... + # ) %dopar% { return( FUN(z, ...) ) } + } else { + # Check that future is loaded + check_package("future") + ibis_future() + } + } + # If input data was not a list, combine again + if(input_type != "list" && is.list(out)){ + out <- do.call(rbind, out) + } + return( out ) +} diff --git a/R/project.R b/R/project.R index 223565e0..8c354d5e 100644 --- a/R/project.R +++ b/R/project.R @@ -353,7 +353,6 @@ methods::setMethod( total = length(unique(df$time))) } - # TODO: Consider doing this in parallel but sequential times <- sort(unique(df$time)) for(step in times){ # step = times[1] diff --git a/R/utils-bart.R b/R/utils-bart.R index 0b0329be..500e847f 100644 --- a/R/utils-bart.R +++ b/R/utils-bart.R @@ -87,6 +87,117 @@ varimp.bart <- function(model){ return(var.df) } +#' Prediction with `dbarts` package for bart models +#' +#' @description Helper function to create a prediction with [engine_bart] fitted +#' models. +#' +#' @param obj A [list] containing the fitted model. +#' @param newdata A [`data.frame`] with all the predictor used for model fitting. +#' @param params A [`list`] with parameters for estimation. Normally created during +#' model fitting. +#' @param of A [`numeric`] optional offset. +#' @param w A [`numeric`] [`vector`] containing the exposure variables for PPMs. +#' Can be \code{NULL} if the model is not a PPM. +#' @param run_future A [`logical`] on whether the model is to be run through chunking +#' and the [future] package (Default: \code{FALSE}). +#' @param N An optional [`numeric`] value describing the number of chunking pieces (Default: \code{NULL}). +#' +#' @returns Always a summarized posterior [`data.frame`] with the respective +#' statistical moments. +#' +#' @keywords internal +#' +#' @noRd +predict_bart <- function(obj, newdata, params, of = NULL, w = NULL, run_future = FALSE, N = NULL) { + assertthat::assert_that( + is.list(obj), + is.matrix(newdata) || is.data.frame(newdata) || inherits(newdata, "SpatialPixelsDataFrame"), + is.list(params), + is.null(of), + is.null(w) || is.numeric(w), + is.logical(run_future), + is.null(N) || is.numeric(N) + ) + + # Non-future + if(!run_future){ + # Make a prediction + check_package("foreach") + # Tile the problem + splits <- cut(1:nrow(newdata), nrow(newdata) / min(nrow(newdata) / 4, 100) ) + + # Make a prediction + out <- foreach::foreach(s = unique(splits), + .inorder = TRUE, + .combine = "rbind", + .errorhandling = "stop", + .multicombine = TRUE, + .export = c("splits", "fit_bart", "newdata", "params", "of"), + .packages = c("dbarts", "matrixStats")) %do% { + i <- which(splits == s) + + pred_bart <- predict(object = obj, + newdata = newdata[i, ], + type = params$type, + weights = w[i], + offset = of[i] + ) + # Summarize quantiles and sd from posterior + ms <- as.data.frame( + cbind( apply(pred_bart, 2, function(x) mean(x, na.rm = TRUE)), + matrixStats::colSds(pred_bart), + matrixStats::colQuantiles(pred_bart, probs = c(.05,.5,.95)), + apply(pred_bart, 2, modal) + ) + ) + names(ms) <- c("mean","sd", "q05", "q50", "q95", "mode") + ms$cv <- ms$sd / ms$mean + rm(pred_bart) + return( ms ) + } + } else { + # Set up future if set + check_package("doFuture") + # If not set, use number of threads + if(is.null(N)) N <- getOption("ibis.nthread",default = 10) + + # Tile the problem + splits <- cut(1:nrow(newdata), nrow(newdata) / min(nrow(newdata) / 4, 100) ) + + # Make a prediction + out <- foreach::foreach(s = unique(splits), + .inorder = TRUE, + .combine = "rbind", + .errorhandling = "stop", + .options.future = list(seed = TRUE)) %dofuture% { + i <- which(splits == s) + + pred_bart <- predict(object = obj, + newdata = newdata[i, ], + type = params$type, + weights = w[i], + offset = of[i] + ) + # Summarize quantiles and sd from posterior + ms <- as.data.frame( + cbind( apply(pred_bart, 2, function(x) mean(x, na.rm = TRUE)), + matrixStats::colSds(pred_bart), + matrixStats::colQuantiles(pred_bart, probs = c(.05,.5,.95)), + apply(pred_bart, 2, terra::modal) + ) + ) + names(ms) <- c("mean","sd", "q05", "q50", "q95", "mode") + ms$cv <- ms$sd / ms$mean + rm(pred_bart) + return( ms ) + } + + assertthat::assert_that(nrow(out)>0) + } + return(out) +} + #' Partial effects for bart models adapted from embarcadero package #' #' @param model A fitted [dbarts::bart] model. @@ -192,7 +303,7 @@ bart_partial_effect <- function(model, x.var, equal = FALSE, cbind( apply(pd$fd[[i]], 2, function(x) mean(x, na.rm = TRUE)), matrixStats::colSds(pd$fd[[i]]), matrixStats::colQuantiles(pd$fd[[i]], probs = c(.05,.5,.95)), - apply(pd$fd[[i]], 2, mode) + apply(pd$fd[[i]], 2, modal) ) ) names(ms) <- c("mean","sd", "q05", "q50", "q95", "mode") diff --git a/R/utils-breg.R b/R/utils-breg.R index d55615dc..dc0d82d5 100644 --- a/R/utils-breg.R +++ b/R/utils-breg.R @@ -168,58 +168,126 @@ setup_prior_boom <- function(form, data, priors, family, exposure = NULL){ #' model fitting. #' @param w A [`numeric`] [`vector`] containing the exposure variables for PPMs. #' Can be \code{NULL} if the model is not a PPM. +#' @param run_future A [`logical`] on whether the model is to be run through chunking +#' and the [future] package (Default: \code{FALSE}). **Note that this also summarizes +#' directly the posterior!** +#' @param N An optional [`numeric`] value describing the number of chunking pieces (Default: \code{NULL}). #' #' @note By Default 20% of the iterations are considered as burnin. #' #' @returns A [`data.frame`] with the respective prediction. #' -#' @keywords utils +#' @keywords internal #' #' @noRd -#' -#' @keywords internal -predict_boom <- function(obj, newdata, fam, params, w = NULL) { +predict_boom <- function(obj, newdata, fam, params, w = NULL, run_future = FALSE, N = NULL) { assertthat::assert_that( is.list(obj), is.data.frame(newdata) || inherits(newdata, "SpatialPixelsDataFrame"), is.character(fam), is.list(params), - is.null(w) || is.numeric(w) + is.null(w) || is.numeric(w), + is.logical(run_future), + is.null(N) || is.numeric(N) ) - check_package("BoomSpikeSlab") - - # Make a prediction - if(fam == "poisson"){ - suppressWarnings( - pred_breg <- BoomSpikeSlab::predict.poisson.spike( - object = obj, - newdata = newdata, - exposure = w, - burn = ceiling(params$iter*0.2), - type = params$type, - mean.only = FALSE # Return full posterior + + # Non-future + if(!run_future){ + # Make a prediction + if(fam == "poisson"){ + suppressWarnings( + pred_breg <- BoomSpikeSlab::predict.poisson.spike( + object = obj, + newdata = newdata, + exposure = w, + burn = ceiling(params$iter*0.2), + type = params$type, + mean.only = FALSE # Return full posterior + ) ) - ) - } else if(fam == "binomial"){ - suppressWarnings( - pred_breg <- BoomSpikeSlab::predict.logit.spike( - object = obj, - newdata = newdata, - burn = ceiling(params$iter*0.2), - type = params$type, - mean.only = FALSE # Return full posterior + } else if(fam == "binomial"){ + suppressWarnings( + pred_breg <- BoomSpikeSlab::predict.logit.spike( + object = obj, + newdata = newdata, + burn = ceiling(params$iter*0.2), + type = params$type, + mean.only = FALSE # Return full posterior + ) ) - ) - } else { - suppressWarnings( - pred_breg <- BoomSpikeSlab::predict.lm.spike( - object = obj, - newdata = newdata, - burn = ceiling(params$iter*0.2), - type = params$type, - mean.only = FALSE # Return full posterior + } else { + suppressWarnings( + pred_breg <- BoomSpikeSlab::predict.lm.spike( + object = obj, + newdata = newdata, + burn = ceiling(params$iter*0.2), + type = params$type, + mean.only = FALSE # Return full posterior + ) ) - ) + } + } else { + # Set up future if set + check_package("doFuture") + # If not set, use number of threads + if(is.null(N)) N <- getOption("ibis.nthread",default = 10) + # Chunk the data + splits <- chunk_data(newdata, N = N, index_only = TRUE) + + pred_breg <- foreach::foreach(s = splits, + .combine = "rbind", + .inorder = TRUE, + .options.future = list(seed = TRUE, + packages = c("matrixStats"), + globals = structure(TRUE, add = "modal")) + ) %dofuture% { + if(fam == "poisson"){ + suppressWarnings( + pred_breg <- BoomSpikeSlab::predict.poisson.spike( + object = obj, + newdata = newdata[s,], + exposure = w[s], + burn = ceiling(params$iter*0.2), + type = params$type, + mean.only = FALSE # Return full posterior + ) + ) + } else if(fam == "binomial"){ + suppressWarnings( + pred_breg <- BoomSpikeSlab::predict.logit.spike( + object = obj, + newdata = newdata[s,], + burn = ceiling(params$iter*0.2), + type = params$type, + mean.only = FALSE # Return full posterior + ) + ) + } else { + suppressWarnings( + pred_breg <- BoomSpikeSlab::predict.lm.spike( + object = obj, + newdata = newdata[s,], + burn = ceiling(params$iter*0.2), + type = params$type, + mean.only = FALSE # Return full posterior + ) + ) + } + # Summarize the posterior + preds <- as.data.frame( + cbind( + matrixStats::rowMeans2(pred_breg, na.rm = TRUE), + matrixStats::rowSds(pred_breg, na.rm = TRUE), + matrixStats::rowQuantiles(pred_breg, probs = c(.05,.5,.95), na.rm = TRUE) + ) + ) + names(preds) <- c("mean", "sd", "q05", "q50", "q95") + preds$cv <- (preds$sd / preds$mean) + # Mode + preds$mode <- base::apply(pred_breg, 1, FUN = terra::modal) |> as.numeric() + return(preds) + } + assertthat::assert_that(nrow(pred_breg)>0) } return(pred_breg) } diff --git a/R/utils-stan.R b/R/utils-stan.R index 37329e15..f45b78a3 100644 --- a/R/utils-stan.R +++ b/R/utils-stan.R @@ -323,7 +323,7 @@ run_stan <- function( model_code, data = list(), #' @param obj A \code{"stanfit"} object (as used by rstan). #' @param form A [`formula`] object created for the [ibis.iSDM::DistributionModel]. #' @param newdata A [data.frame] with new data to be used for prediction. -#' @param mode A [`character`] of whether the linear `predictor` or the `response` +#' @param type A [`character`] of whether the linear `predictor` or the `response` #' is to be summarized. #' @param family A [`character`] giving the family for simulating linear response #' values (Default: \code{NULL}) @@ -335,16 +335,17 @@ run_stan <- function( model_code, data = list(), #' * The brms R-package. #' #' @export -posterior_predict_stanfit <- function(obj, form, newdata, mode = "predictor", family = NULL, offset = NULL, draws = NULL){ +posterior_predict_stanfit <- function(obj, form, newdata, type = "predictor", family = NULL, offset = NULL, draws = NULL){ assertthat::assert_that( inherits(obj, "stanfit") || inherits(obj, "CmdStanFit"), is.formula(form), is.data.frame(newdata), + is.character(type), is.null(family) || is.character(family), is.null(draws) || is.numeric(draws), is.null(offset) || (length(offset) == nrow(newdata)) ) - mode <- match.arg(mode, c("predictor", "response"), several.ok = FALSE) + type <- match.arg(type, c("predictor", "response"), several.ok = FALSE) # Build model matrix # Note: This removes all NA cells from matrix A <- stats::model.matrix(object = stats::delete.response(stats::terms(form)), @@ -386,7 +387,7 @@ posterior_predict_stanfit <- function(obj, form, newdata, mode = "predictor", fa ) # 16/01/2023 - Change towards matrix multiplication by default (below) - # if(mode == "predictor"){ + # if(type == "predictor"){ # # Summarize the coefficients from the posterior # pp <- posterior::summarise_draws(pp) |> # subset(select = c("variable", "mean", "q5", "median", "q95", "sd")) |> @@ -438,7 +439,7 @@ posterior_predict_stanfit <- function(obj, form, newdata, mode = "predictor", fa colnames(a) <- rownames(a) <- NULL # Backtransformation - if(mode == "response"){ + if(type == "response"){ if(family == "poisson"){ a <- apply(a, 2, function(lambda) ilink(lambda, link = "log")) } else if(family == "binomial") { diff --git a/R/utils.R b/R/utils.R index cd747522..d3f3b06f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -60,18 +60,23 @@ text_yellow <- function(text) { paste0('\033[33m',text,'\033[39m') } #' @inheritParams text_red text_green <- function(text) { paste0('\033[32m',text,'\033[39m') } -#' Calculate the mode +#' Calculate the mode of a provided vector #' #' @param A [`vector`] of values or characters. +#' @param na.rm [`logical`] whether \code{NA} values are to be removed (Default: \code{TRUE}) #' -#' @keywords utils -#' -#' @noRd +#' @keywords utils, misc +#' @examples +#' # Example +#' modal(trees$Girth) #' -#' @keywords internal -mode <- function(x) { +#' @returns The most common (mode) estimate. +#' @export +modal <- function(x, na.rm = TRUE) { + if(na.rm) x <- x[!is.na(x)] + if(length(x)==0) return(NA) ux <- unique(x) - ux[which.max(tabulate(match(x, ux)))] + ux[which.max(table(match(x, ux)))] } #' Check whether function exist in name space @@ -337,116 +342,6 @@ sanitize_names <- function(names){ ) } -#' Parallel computation of function -#' -#' @description Some computations take considerable amount of time to execute. -#' This function provides a helper wrapper for running functions of the -#' [`apply`] family to specified outputs. -#' -#' @param X A [`list`], [`data.frame`] or [`matrix`] object to be fed to a single -#' core or parallel [apply] call. -#' @param FUN A [`function`] passed on for computation. -#' @param cores A [numeric] of the number of cores to use (Default: \code{1}). -#' @param approach [`character`] for the parallelization approach taken (Options: -#' \code{"parallel"} or \code{"future"}). -#' @param export_package A [`vector`] with packages to export for use on parallel -#' nodes (Default: \code{NULL}). -#' -#' @details By default, the [parallel] package is used for parallel computation, -#' however an option exists to use the [future] package instead. -#' -#' @keywords utils -#' -#' @examples -#' \dontrun{ -#' run_par(list, mean, cores = 4) -#' } -#' -#' @noRd -#' -#' @keywords internal -run_parallel <- function(X, FUN, cores = 1, approach = "parallel", export_packages = NULL, ...) { - assertthat::assert_that( - is.list(X) || is.data.frame(X) || is.matrix(X), - is.function(FUN), - is.numeric(cores), - is.null(export_packages) || is.character(export_packages) - ) - # Match approach - approach <- match.arg(approach, c("parallel", "future"), several.ok = FALSE) - - # Collect dots - dots <- list(...) - - if(!is.list(X)){ - # Convert input object to a list of split parameters - n_vars <- nrow(X) - chunk_size <- ceiling(n_vars / cores) - n_chunks <- ceiling(n_vars / chunk_size) - chunk_list <- vector(length = n_chunks, mode = "list") - - for (i in seq_len(n_chunks)) { - if ((chunk_size * (i - 1) + 1) <= n_vars) { - chunk <- (chunk_size * (i - 1) + 1):(min(c(chunk_size * - i, n_vars))) - chunk_list[[i]] <- X[chunk, ] - } - } - assertthat::assert_that(sum(sapply(chunk_list, nrow)) == nrow(X)) - X <- chunk_list;rm(chunk_list) - input_type = "data.frame" # Save to aggregate later again - } else { input_type = "list"} - - # Process depending on cores - if (cores == 1) { - out <- lapply(X, FUN, ...) - } else { - if(approach == "parallel"){ - # check_package('doParallel') - # require(foreach) - # isTRUE(Sys.info()[["sysname"]] == "Windows") - # Other operating systems - if(!isTRUE(Sys.info()[["sysname"]] == "Windows") && is.list(X)) { - out <- parallel::mclapply(X = X, FUN = FUN, mc.cores = cores, - ...) - } else { - # Other operating systems - cl <- parallel::makePSOCKcluster(cores) - on.exit(parallel::stopCluster(cl)) - if(!is.null(export_packages)){ - # Send all specified packages to the cluster - for(val in export_packages){ - parallel::clusterExport(cl, varlist = val, - envir = as.environment(asNamespace(val))) - } - } - out <- parallel::parLapply(cl = cl, X = X, fun = FUN, ...) - } - # out <- foreach::foreach(z = iterators::iter(X), - # .combine = ifelse(input_type!="list", "rbind", foreach:::defcombine), - # .inorder = FALSE, - # .multicombine = TRUE, - # .errorhandling = 'stop', - # .export = c("FUN"), - # .packages = export_packages, - # ... - # ) %dopar% { return( FUN(z, ...) ) } - } else { - # Check that future is loaded - check_package('future.apply') - # Check that plan for future has been set up! - assertthat::assert_that( getOption("ibis.use_future") == TRUE, - msg = "Set up a future plan via [ibis_future] to use this approach.") - out <- future.apply::future_lapply(cl = cl, X = X, fun = FUN, ...) - } - } - # If input data was not a list, combine again - if(input_type != "list" && is.list(out)){ - out <- do.call(rbind, out) - } - return( out ) -} - #' Clamp a predictor matrix by given values #' #' @description To limit extreme extrapolation it is possible to \code{'clamp'} diff --git a/R/validate.R b/R/validate.R index 91f33b5d..2d89f124 100644 --- a/R/validate.R +++ b/R/validate.R @@ -31,7 +31,7 @@ #' * \code{'logloss'} = Log loss, TBD #' * \code{'normgini'} = Normalized Gini index, TBD #' * \code{'cont.boyce'} = Continuous Boyce index, Ratio of predicted against expected frequency calculated over -#' a moving window: \deqn{\frac{P_{i}{E_{i}} }}, where \deqn{ P_{i} = \frac{p_{i}}{\sum{j=1}^{b} p_{j} }} and \deqn{ E_{i} = \frac{a_{i}}{\sum{j=1}^{b} a_{j} }} +#' a moving window: \deqn{\frac{P_{i}}{E_{i}}}, where \deqn{ P_{i} = \frac{p_{i}}{\sum{j=1}^{b} p_{j}} } and \deqn{ E_{i} = \frac{a_{i}}{\sum{j=1}^{b} a_{j}} } #' #' **Discrete:** #' * \code{'n'} = Number of observations. diff --git a/R/zzz.R b/R/zzz.R index 4c3983e3..bffd7c78 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -31,7 +31,8 @@ # Use the future package for any options. Default is FALSE options('ibis.nthread' = parallel::detectCores() - 1) options('ibis.runparallel' = FALSE) - options('ibis.futurestrategy' = "multisession") + options('ibis.futurestrategy' = "sequential") + options(future.globals.onReference = "ignore") # Raise an error for pointer objects (SpatRaster) options(doFuture.foreach.export = ".export-and-automatic-with-warning") # Other dependencies not directly added in DESCRIPTION (to minimize potential diff --git a/_pkgdown.yml b/_pkgdown.yml index aa686df0..ad4c8a41 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -163,6 +163,16 @@ reference: - Log - has_keyword("classes") + - title: Parallel processing + desc: > + Functions to enable or set up parallel processing + contents: + - ibis_future + - ibis_enable_parallel + - ibis_set_strategy + - ibis_set_threads + - run_parallel + - title: Miscellaneous functions desc: > Other functions only relevant for development @@ -173,9 +183,9 @@ reference: - has_keyword("misc") - print - myLog + - modal - new_id - new_waiver - - ibis_future - ibis_options - ibis_dependencies diff --git a/man/engine_bart.Rd b/man/engine_bart.Rd index 3be00c8f..44fa401c 100644 --- a/man/engine_bart.Rd +++ b/man/engine_bart.Rd @@ -16,7 +16,7 @@ sum-of-trees formulation (Default: \code{1000}).} \item{chains}{A number of the number of chains to be used (Default: \code{4}).} -\item{type}{The mode used for creating posterior predictions. Either \code{"link"} +\item{type}{The type used for creating posterior predictions. Either \code{"link"} or \code{"response"} (Default: \code{"response"}).} \item{...}{Other options.} diff --git a/man/engine_gdb.Rd b/man/engine_gdb.Rd index e0620fac..18a81d11 100644 --- a/man/engine_gdb.Rd +++ b/man/engine_gdb.Rd @@ -52,6 +52,10 @@ projections. Such as for instance the ability to specifically add spatial baselearners via \link{add_latent_spatial} or the specification of monotonically constrained priors via \link{GDBPrior}. } +\note{ +The coefficients resulting from gdb with poipa data (Binomial) are only 0.5 +of the typical coefficients of a logit model obtained via glm (see Binomial). +} \examples{ \dontrun{ # Add GDB as an engine diff --git a/man/ensemble.Rd b/man/ensemble.Rd index 2056a7d6..ce218aff 100644 --- a/man/ensemble.Rd +++ b/man/ensemble.Rd @@ -87,6 +87,7 @@ Possible options for creating an ensemble includes: \item \code{'median'} - Calculates the median of several predictions. \item \code{'max'} - The maximum value across predictions. \item \code{'min'} - The minimum value across predictions. +\item \code{'mode'} - The mode/modal values as the most commonly occurring value. \item \code{'weighted.mean'} - Calculates a weighted mean. Weights have to be supplied separately (e.g. TSS). \item \code{'min.sd'} - Ensemble created by minimizing the uncertainty among predictions. \item \code{'threshold.frequency'} - Returns an ensemble based on threshold frequency (simple count). Requires thresholds to be computed. diff --git a/man/ibis_enable_parallel.Rd b/man/ibis_enable_parallel.Rd new file mode 100644 index 00000000..3a188e62 --- /dev/null +++ b/man/ibis_enable_parallel.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{ibis_enable_parallel} +\alias{ibis_enable_parallel} +\title{Set the parallel processing flag to TRUE} +\usage{ +ibis_enable_parallel() +} +\value{ +Invisible +} +\description{ +Small helper function to enable parallel processing. If set +to \code{TRUE}, then parallel inference (if supported by engines) and projection is +enabled across the package. +For enabling prediction support beyond sequential prediction see the \code{\link{ibis_future}} function. +} +\seealso{ +\link{future}, \link{ibis_future} +} +\keyword{misc} diff --git a/man/ibis_future.Rd b/man/ibis_future.Rd index 4f32e1fa..9fc662ef 100644 --- a/man/ibis_future.Rd +++ b/man/ibis_future.Rd @@ -2,11 +2,13 @@ % Please edit documentation in R/misc.R \name{ibis_future} \alias{ibis_future} -\title{Options to set up ibis for parallel processing with future} +\title{Internal function to enable (a)synchronous parallel processing} \usage{ ibis_future( - cores = getOption("ibis.nthread"), - strategy = getOption("ibis.futurestrategy") + plan_exists = FALSE, + cores = getOption("ibis.nthread", default = 2), + strategy = getOption("ibis.futurestrategy"), + workers = NULL ) } \arguments{ @@ -14,17 +16,40 @@ ibis_future( \item{strategy}{A \code{\link{character}} denoting the strategy to be used for future. See help of \code{\link{future}} for options. (Default: \code{"multisession"}).} + +\item{workers}{An optional list of remote machines or workers, e.g. \code{"c(remote.server.org)"}. +Alternatively a \code{"cluster"} object can be provided.} } \value{ -None +Invisible } \description{ -Options to set up ibis for parallel processing with future +This function checks if parallel processing can be set up and enables it. +\strong{Ideally this is done by the user for more control!} +In the package parallelization is usually only used for predictions and projections, +but not for inference in which case parallel inference should be handled by the engine. +} +\details{ +Currently supported strategies are: +\itemize{ +\item \code{"sequential"} = Resolves futures sequentially in the current R process (Package default). +\item \code{"multisession"} = Resolves futures asynchronously across \code{'cores'} sessions. +\item \code{"multicore"} = Resolves futures asynchronously across on forked processes. Only works on UNIX systems! +\item \code{"cluster"} = Resolves futures asynchronously in sessions on this or more machines. +\item \code{"slurm"} = To be implemented: Slurm linkage via batchtools. +} +} +\note{ +The \code{'plan'} set by \link{future} exists after the function has been executed. + +If the aim is to parallize across many species, this is better done in a scripted solution. +Make sure not to parallize predictions within existing clusters to avoid out-of-memory +issues. } \examples{ \dontrun{ -# Starts future job -ibis_future(cores = 4) +# Starts future job. F in this case is a prediction function. +ibis_future(cores = 4, strategy = "multisession") } } diff --git a/man/ibis_set_strategy.Rd b/man/ibis_set_strategy.Rd new file mode 100644 index 00000000..fe9fb26b --- /dev/null +++ b/man/ibis_set_strategy.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{ibis_set_strategy} +\alias{ibis_set_strategy} +\title{Set the number of threads for parallel processing.} +\usage{ +ibis_set_strategy(strategy = "sequential") +} +\arguments{ +\item{strategy}{A \code{\link{character}} with the strategy.} +} +\value{ +Invisible +} +\description{ +Small helper function to respecify the strategy for parallel processing (Default: \code{'sequential'}). +} +\details{ +Currently supported strategies are: +\itemize{ +\item \code{"sequential"} = Resolves futures sequentially in the current R process (Package default). +\item \code{"multisession"} = Resolves futures asynchronously across \code{'cores'} sessions. +\item \code{"multicore"} = Resolves futures asynchronously across on forked processes. Only works on UNIX systems! +\item \code{"cluster"} = Resolves futures asynchronously in sessions on this or more machines. +\item \code{"slurm"} = To be implemented: Slurm linkage via batchtools. +} +} +\seealso{ +\link{future}, \link{ibis_future_run} +} +\keyword{misc} diff --git a/man/ibis_set_threads.Rd b/man/ibis_set_threads.Rd new file mode 100644 index 00000000..b870b205 --- /dev/null +++ b/man/ibis_set_threads.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{ibis_set_threads} +\alias{ibis_set_threads} +\title{Set the threads for parallel processing.} +\usage{ +ibis_set_threads(threads = 2) +} +\arguments{ +\item{threads}{A \code{\link{numeric}} greater thna \code{0}.} +} +\value{ +Invisible +} +\description{ +Small helper function to respecify the number of threads for parallel processing. +} +\seealso{ +\link{future}, \link{ibis_future_run} +} +\keyword{misc} diff --git a/man/modal.Rd b/man/modal.Rd new file mode 100644 index 00000000..5cdc6ae1 --- /dev/null +++ b/man/modal.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{modal} +\alias{modal} +\title{Calculate the mode of a provided vector} +\usage{ +modal(x, na.rm = TRUE) +} +\arguments{ +\item{na.rm}{\code{\link{logical}} whether \code{NA} values are to be removed (Default: \code{TRUE})} + +\item{A}{\code{\link{vector}} of values or characters.} +} +\value{ +The most common (mode) estimate. +} +\description{ +Calculate the mode of a provided vector +} +\examples{ +# Example +modal(trees$Girth) + +} +\keyword{misc} +\keyword{utils,} diff --git a/man/posterior_predict_stanfit.Rd b/man/posterior_predict_stanfit.Rd index bc482694..3e357281 100644 --- a/man/posterior_predict_stanfit.Rd +++ b/man/posterior_predict_stanfit.Rd @@ -8,7 +8,7 @@ posterior_predict_stanfit( obj, form, newdata, - mode = "predictor", + type = "predictor", family = NULL, offset = NULL, draws = NULL @@ -21,7 +21,7 @@ posterior_predict_stanfit( \item{newdata}{A \link{data.frame} with new data to be used for prediction.} -\item{mode}{A \code{\link{character}} of whether the linear \code{predictor} or the \code{response} +\item{type}{A \code{\link{character}} of whether the linear \code{predictor} or the \code{response} is to be summarized.} \item{family}{A \code{\link{character}} giving the family for simulating linear response diff --git a/man/run_parallel.Rd b/man/run_parallel.Rd new file mode 100644 index 00000000..85506f22 --- /dev/null +++ b/man/run_parallel.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{run_parallel} +\alias{run_parallel} +\title{Parallel computation of function} +\usage{ +run_parallel( + X, + FUN, + cores = 1, + approach = "future", + export_packages = NULL, + ... +) +} +\arguments{ +\item{X}{A \code{\link{list}}, \code{\link{data.frame}} or \code{\link{matrix}} object to be fed to a single +core or parallel \link{apply} call.} + +\item{FUN}{A \code{\link{function}} passed on for computation.} + +\item{cores}{A \link{numeric} of the number of cores to use (Default: \code{1}).} + +\item{approach}{\code{\link{character}} for the parallelization approach taken (Options: +\code{"parallel"} or \code{"future"}).} + +\item{export_package}{A \code{\link{vector}} with packages to export for use on parallel +nodes (Default: \code{NULL}).} +} +\description{ +Some computations take considerable amount of time to execute. +This function provides a helper wrapper for running functions of the +\code{\link{apply}} family to specified outputs. +} +\details{ +By default, the \link{parallel} package is used for parallel computation, +however an option exists to use the \link{future} package instead. +} +\examples{ +\dontrun{ + run_parallel(list, mean, cores = 4) +} + +} +\keyword{utils} diff --git a/man/validate.Rd b/man/validate.Rd index bdc190a2..5a6c1c91 100644 --- a/man/validate.Rd +++ b/man/validate.Rd @@ -80,7 +80,7 @@ FP the false positive and FN the false negative) \item \code{'logloss'} = Log loss, TBD \item \code{'normgini'} = Normalized Gini index, TBD \item \code{'cont.boyce'} = Continuous Boyce index, Ratio of predicted against expected frequency calculated over -a moving window: \deqn{\frac{P_{i}{E_{i}} }}, where \deqn{ P_{i} = \frac{p_{i}}{\sum{j=1}^{b} p_{j} }} and \deqn{ E_{i} = \frac{a_{i}}{\sum{j=1}^{b} a_{j} }} +a moving window: \deqn{\frac{P_{i}}{E_{i}}}, where \deqn{ P_{i} = \frac{p_{i}}{\sum{j=1}^{b} p_{j}} } and \deqn{ E_{i} = \frac{a_{i}}{\sum{j=1}^{b} a_{j}} } } \strong{Discrete:} diff --git a/tests/testthat/test_functions.R b/tests/testthat/test_functions.R index 05ea1086..c5651f1f 100644 --- a/tests/testthat/test_functions.R +++ b/tests/testthat/test_functions.R @@ -200,6 +200,14 @@ test_that('Test other generic functions', { suppressWarnings( expect_true( is.nan(logit(5)) ) ) expect_length(logisticRichard(rpois(10,.5)), 10) + # Combine formulas + form1 <- y ~ x + z + form2 <- y ~ x + expect_true(is.formula( combine_formulas(form1, form2) )) + + # Modal calculations + expect_type( modal(rpois(50,1)), "integer") + }) # ---- # diff --git a/tests/testthat/test_parallelPrediction.R b/tests/testthat/test_parallelPrediction.R new file mode 100644 index 00000000..99f29aee --- /dev/null +++ b/tests/testthat/test_parallelPrediction.R @@ -0,0 +1,85 @@ +# Ensure that future setup works +# This might be tricky in CI as different setups make use of different parallel +# configurations +test_that('Testing parallel setup', { + + # Set to verbose + options("ibis.setupmessages" = FALSE) + + skip_if_not_installed("future") + skip_if_not_installed("doFuture") + + # Load data + # Background Raster + background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) + # Get test species + virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) + # Get list of test predictors + ll <- list.files(system.file('extdata/predictors/',package = 'ibis.iSDM',mustWork = TRUE),full.names = T) + # Load them as rasters + predictors <- terra::rast(ll);names(predictors) <- tools::file_path_sans_ext(basename(ll)) + + # Add pseudo absence + abs <- pseudoabs_settings(nrpoints = 0,min_ratio = 1,method = "mcp") + suppressMessages( + poa <- add_pseudoabsence(virtual_points,template = background, field_occurrence = "Observed", settings = abs) + ) + + # Now set them one up step by step + x <- distribution(background) |> + add_biodiversity_poipa(poipa = poa,field_occurrence = 'Observed',docheck = FALSE) |> + add_predictors(predictors, transform = 'none',derivates = 'none') |> + engine_glm() + + expect_no_error( + fit1 <- train(x, "test", inference_only = FALSE) + ) + + # Now enable parallel + expect_no_error( + expect_invisible( + ibis_enable_parallel() + ) + ) + # Set nr of threads + expect_no_error( + expect_invisible( + ibis_set_threads(2) + ) + ) + + # Set strategy + expect_no_error( + expect_invisible( + ibis_set_strategy(strategy = "sequential") + ) + ) + + # --- # + # Now define a plan + ibis_future() + + expect_no_error( + fit2 <- train(x, "test", inference_only = FALSE) + ) + + # Try with multi-session + ibis_future(strategy = "multisession") + + expect_no_error( + fit3 <- train(x, "test", inference_only = FALSE) + ) + + # Assume they are all identical + expect_gte( + cor(fit1$get_coefficients()[,2], fit2$get_coefficients()[,2]), + 0.99 + ) + expect_gte( + cor(fit1$get_coefficients()[,2], fit3$get_coefficients()[,2]), + 0.99 + ) + + # Set parallel to FALSE again + options('ibis.runparallel' = FALSE) +}) diff --git a/vignettes/articles/08_frequently-asked-questions.Rmd b/vignettes/articles/08_frequently-asked-questions.Rmd index f180e96c..9dd5256e 100644 --- a/vignettes/articles/08_frequently-asked-questions.Rmd +++ b/vignettes/articles/08_frequently-asked-questions.Rmd @@ -324,6 +324,39 @@ plot(fit$get_data("fit_best")$evaluation_log) ``` +
+I am predicting over a large area, is there a way to parallize the computation? + + +Yes and no. +Generally, the computation speed is handled by the respective engine and not every +engine supports for example multi-threaded computations. +However, the most computationally demanding steps in the package is usually the +spatial prediction and there are some functionalities to 'tile' up the data over which +predictions are made. + +This is using the R [`future`] package for asynchronous projections. + +**Note: This won't usually improve things for small models/covariates as the overhead of setting up a model negates any speed improvements** + +To set this up, simply execute the following +```{r, echo=TRUE,eval=FALSE} + +# Set parallel option +ibis_enable_parallel() # Enable parallel processing in general +ibis_set_threads(4) # 4 Threads +ibis_set_strategy("multisession") # R multi-session +ibis_future() # Set up a future plan +``` + +Now most prediction should make use of the specified future plan. This counts for +both initial model predictions and projections. + +If you aim to parallelize over a range of species instead, it might be more worthhile +to rather parallize the iteration and not the prediction. + +
+ ## Model troubleshooting From 64f85b2a8324e7fa84654b606a9acc7aa5e9eb0c Mon Sep 17 00:00:00 2001 From: Martin-Jung Date: Thu, 22 Aug 2024 20:17:05 +0000 Subject: [PATCH 06/21] Update CITATION.cff --- CITATION.cff | 105 +++++++++++++++++++++++++-------------------------- 1 file changed, 51 insertions(+), 54 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index a73746c1..c9c56099 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -104,6 +104,56 @@ references: year: '2024' doi: 10.32614/CRAN.package.doFuture version: '>= 0.12.2' +- type: software + title: future + abstract: 'future: Unified Parallel and Distributed Processing in R for Everyone' + notes: Imports + url: https://future.futureverse.org + repository: https://CRAN.R-project.org/package=future + authors: + - family-names: Bengtsson + given-names: Henrik + email: henrikb@braju.com + orcid: https://orcid.org/0000-0002-7579-5165 + year: '2024' + doi: 10.32614/CRAN.package.future + version: '>= 1.23.0' +- type: software + title: parallelly + abstract: 'parallelly: Enhancing the ''parallel'' Package' + notes: Imports + url: https://parallelly.futureverse.org + repository: https://CRAN.R-project.org/package=parallelly + authors: + - family-names: Bengtsson + given-names: Henrik + email: henrikb@braju.com + orcid: https://orcid.org/0000-0002-7579-5165 + year: '2024' + doi: 10.32614/CRAN.package.parallelly + version: '>= 1.30.0' +- type: software + title: parallel + abstract: 'R: A Language and Environment for Statistical Computing' + notes: Imports + authors: + - name: R Core Team + institution: + name: R Foundation for Statistical Computing + address: Vienna, Austria + year: '2024' +- type: software + title: foreach + abstract: 'foreach: Provides Foreach Looping Construct' + notes: Imports + url: https://github.com/RevolutionAnalytics/foreach + repository: https://CRAN.R-project.org/package=foreach + authors: + - name: Microsoft + - family-names: Weston + given-names: Steve + year: '2024' + doi: 10.32614/CRAN.package.foreach - type: software title: dplyr abstract: 'dplyr: A Grammar of Data Manipulation' @@ -129,32 +179,6 @@ references: orcid: https://orcid.org/0000-0003-4777-038X year: '2024' doi: 10.32614/CRAN.package.dplyr -- type: software - title: foreach - abstract: 'foreach: Provides Foreach Looping Construct' - notes: Imports - url: https://github.com/RevolutionAnalytics/foreach - repository: https://CRAN.R-project.org/package=foreach - authors: - - name: Microsoft - - family-names: Weston - given-names: Steve - year: '2024' - doi: 10.32614/CRAN.package.foreach -- type: software - title: future - abstract: 'future: Unified Parallel and Distributed Processing in R for Everyone' - notes: Imports - url: https://future.futureverse.org - repository: https://CRAN.R-project.org/package=future - authors: - - family-names: Bengtsson - given-names: Henrik - email: henrikb@braju.com - orcid: https://orcid.org/0000-0002-7579-5165 - year: '2024' - doi: 10.32614/CRAN.package.future - version: '>= 1.23.0' - type: software title: geodist abstract: 'geodist: Fast, Dependency-Free Geodesic Distance Calculations' @@ -219,7 +243,6 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' - doi: 10.32614/CRAN.package.graphics - type: software title: methods abstract: 'R: A Language and Environment for Statistical Computing' @@ -230,7 +253,6 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' - doi: 10.32614/CRAN.package.methods - type: software title: Matrix abstract: 'Matrix: Sparse and Dense Matrix Classes and Methods' @@ -261,19 +283,9 @@ references: - family-names: Pierce given-names: David email: dpierce@ucsd.edu + orcid: https://orcid.org/0000-0002-2453-9030 year: '2024' doi: 10.32614/CRAN.package.ncdf4 -- type: software - title: parallel - abstract: 'R: A Language and Environment for Statistical Computing' - notes: Imports - authors: - - name: R Core Team - institution: - name: R Foundation for Statistical Computing - address: Vienna, Austria - year: '2024' - doi: 10.32614/CRAN.package.parallel - type: software title: posterior abstract: 'posterior: Tools for Working with Posterior Distributions' @@ -333,7 +345,6 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' - doi: 10.32614/CRAN.package.stats - type: software title: terra abstract: 'terra: Spatial Data Analysis' @@ -391,7 +402,6 @@ references: name: R Foundation for Statistical Computing address: Vienna, Austria year: '2024' - doi: 10.32614/CRAN.package.utils - type: software title: 'R: A Language and Environment for Statistical Computing' notes: Depends @@ -497,19 +507,6 @@ references: given-names: Rolf year: '2024' doi: 10.32614/CRAN.package.deldir -- type: software - title: doParallel - abstract: 'doParallel: Foreach Parallel Adaptor for the ''parallel'' Package' - notes: Suggests - url: https://github.com/RevolutionAnalytics/doparallel - repository: https://CRAN.R-project.org/package=doParallel - authors: - - family-names: Corporation - given-names: Microsoft - - family-names: Weston - given-names: Steve - year: '2024' - doi: 10.32614/CRAN.package.doParallel - type: software title: ellipsis abstract: 'ellipsis: Tools for Working with ...' From 7dfbc6d765dbd096dc16e250b40a4bec4ce1a72f Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 22 Aug 2024 23:04:57 +0200 Subject: [PATCH 07/21] :fire: Addition of superlearners to `ensemble` --- NEWS.md | 4 +++- R/ensemble.R | 62 +++++++++++++++++++++++++++++++++++++++++++++---- man/ensemble.Rd | 11 +++++++++ 3 files changed, 72 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index b9880261..48b1eecd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,11 @@ # ibis.iSDM 0.1.5 (current dev branch) #### New features +* Support for 'modal' value calculations in `ensemble()` and export of method. +* Support for 'superlearner' in `ensemble()`. +* Support for future processing streamlined. See FAQ section for instructions #18. #### Minor improvements and bug fixes -* Support for modal value calculations in `ensemble()` and export of method. * Minor :bug: fix related to misaligned thresholds and negative exponential kernels. * :fire: :bug: fix for scenario projections that use different grain sizes than for inference. diff --git a/R/ensemble.R b/R/ensemble.R index 90fdb0b2..53dd5a91 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -35,6 +35,9 @@ #' standard deviation (\code{"sd"}), the average of all PCA axes except the #' first \code{"pca"}, the coefficient of variation (\code{"cv"}, Default) or #' the range between the lowest and highest value (\code{"range"}). +#' @param point A [`sf`] object containing observational data used for model training. Used +#' for method \code{'superlearner'} only (Default: \code{NULL}). +#' @param field_occurrence A [`character`] location of biodiversity point records (Default: \code{'observed'}). #' @param apply_threshold A [`logical`] flag (Default: \code{TRUE}) specifying #' whether threshold values should also be created via \code{"method"}. Only #' applies and works for [`DistributionModel`] and thresholds found. @@ -49,6 +52,8 @@ #' * \code{'min.sd'} - Ensemble created by minimizing the uncertainty among predictions. #' * \code{'threshold.frequency'} - Returns an ensemble based on threshold frequency (simple count). Requires thresholds to be computed. #' * \code{'pca'} - Calculates a PCA between predictions of each algorithm and then extract the first axis (the one explaining the most variation). +#' * \code{'superlearner'} - Composites two predictions through a 'meta-model' fitted on top +#' (using a [`glm`] by default). Requires binomial data in current Setup. #' #' In addition to the different ensemble methods, a minimal threshold #' (\code{min.value}) can be set that needs to be surpassed for averaging. By @@ -95,14 +100,17 @@ NULL methods::setGeneric("ensemble", signature = methods::signature("..."), function(..., method = "mean", weights = NULL, min.value = NULL, layer = "mean", - normalize = FALSE, uncertainty = "cv", apply_threshold = TRUE) standardGeneric("ensemble")) + normalize = FALSE, uncertainty = "cv", + point = NULL, field_occurrence = 'observed', + apply_threshold = TRUE) standardGeneric("ensemble")) #' @rdname ensemble methods::setMethod( "ensemble", methods::signature("ANY"), function(..., method = "mean", weights = NULL, min.value = NULL, layer = "mean", - normalize = FALSE, uncertainty = "cv", apply_threshold = TRUE){ + normalize = FALSE, uncertainty = "cv", + point = NULL, field_occurrence = 'observed', apply_threshold = TRUE){ if(length(list(...))>1) { mc <- list(...) } else { @@ -137,10 +145,21 @@ methods::setMethod( # Check the method method <- match.arg(method, c('mean', 'weighted.mean', 'median', 'max', 'min','mode', + 'superlearner', 'threshold.frequency', 'min.sd', 'pca'), several.ok = FALSE) # Uncertainty calculation uncertainty <- match.arg(uncertainty, c('none','sd', 'cv', 'range', 'pca'), several.ok = FALSE) + # Method specific checks + if(method == "superlearner"){ + assertthat::assert_that(!is.null(point), + msg = "Ensemble method superlearner requires a specified point data.") + assertthat::assert_that(utils::hasName(point, field_occurrence), + msg = "Field occurrence not found in specified point data.") + assertthat::assert_that(dplyr::n_distinct(point[[field_occurrence]])==2, + msg = "Superlearner currently requires binomial data for ensembling!") + } + # --- # # For Distribution model ensembles if( all( sapply(mods, function(z) inherits(z, "DistributionModel")) ) ){ assertthat::assert_that(length(mods)>=2, # Need at least 2 otherwise this does not make sense @@ -228,6 +247,23 @@ methods::setMethod( } else if(method == 'pca'){ # Calculate a pca on the layers and return the first axes new <- predictor_transform(ras, option = "pca", pca.var = 1)[[1]] + } else if(method == 'superlearner'){ + # Run a superlearner with the specified point data. + # Ensure that predictions have unique names + names(ras) <- paste0('model', 1:terra::nlyr(ras)) + ex <- terra::extract(ras, point, ID = FALSE) + ex <- cbind(point[,field_occurrence], ex) + fit <- glm( + formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> as.formula(), + family = binomial(),data = ex + ) + # Now predict output with the meta-learner + new <- emptyraster(ras) + new[which(!is.na(ras[[1]])[])] <- terra::predict( + fit, ras, na.rm = FALSE, type = "response", + cores = getOption('ibis.nthread')) + attr(new, "superlearner.coefficients") <- coef(fit) + try({ rm(ex,fit) },silent = TRUE) } # Rename @@ -349,7 +385,6 @@ methods::setMethod( } else if(method == 'threshold.frequency'){ # Check that thresholds are available stop("This function does not (yet) work with directly provided Raster objects.") - } else if(method == 'min.sd'){ # If method 'min.sd' furthermore check that there is a sd object for all # of them @@ -368,6 +403,23 @@ methods::setMethod( } else if(method == 'pca'){ # Calculate a pca on the layers and return the first axes new <- predictor_transform(ras, option = "pca", pca.var = 1)[[1]] + } else if(method == 'superlearner'){ + # Run a superlearner with the specified point data. + # Ensure that predictions have unique names + names(ras) <- paste0('model', 1:terra::nlyr(ras)) + ex <- terra::extract(ras, point, ID = FALSE) + ex <- cbind(point[,field_occurrence], ex) + fit <- glm( + formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> as.formula(), + family = binomial(),data = ex + ) + # Now predict output with the meta-learner + new <- emptyraster(ras) + new[which(!is.na(ras[[1]])[])] <- terra::predict( + fit, ras, na.rm = FALSE, type = "response", + cores = getOption('ibis.nthread')) + attr(new, "superlearner.coefficients") <- coef(fit) + try({ rm(ex,fit) },silent = TRUE) } # Rename names(new) <- paste0("ensemble_", lyr) @@ -392,7 +444,7 @@ methods::setMethod( suppressWarnings( out <- c(out, new) ) } } - + # Check and return output assertthat::assert_that(is.Raster(out)) return(out) } else { @@ -470,6 +522,8 @@ methods::setMethod( stop("This has not been reasonably implemented in this context.") } else if(method == 'pca'){ stop("This has not been reasonably implemented in this context.") + } else if(method == 'superlearner'){ + stop("This has not been reasonably implemented in this context.") } # Add dimensions to output if(inherits(mods[[1]], "stars")){ diff --git a/man/ensemble.Rd b/man/ensemble.Rd index ce218aff..c0eed7d3 100644 --- a/man/ensemble.Rd +++ b/man/ensemble.Rd @@ -13,6 +13,8 @@ ensemble( layer = "mean", normalize = FALSE, uncertainty = "cv", + point = NULL, + field_occurrence = "observed", apply_threshold = TRUE ) @@ -24,6 +26,8 @@ ensemble( layer = "mean", normalize = FALSE, uncertainty = "cv", + point = NULL, + field_occurrence = "observed", apply_threshold = TRUE ) } @@ -52,6 +56,11 @@ standard deviation (\code{"sd"}), the average of all PCA axes except the first \code{"pca"}, the coefficient of variation (\code{"cv"}, Default) or the range between the lowest and highest value (\code{"range"}).} +\item{point}{A \code{\link{sf}} object containing observational data used for model training. Used +for method \code{'superlearner'} only (Default: \code{NULL}).} + +\item{field_occurrence}{A \code{\link{character}} location of biodiversity point records (Default: \code{'observed'}).} + \item{apply_threshold}{A \code{\link{logical}} flag (Default: \code{TRUE}) specifying whether threshold values should also be created via \code{"method"}. Only applies and works for \code{\link{DistributionModel}} and thresholds found.} @@ -92,6 +101,8 @@ Possible options for creating an ensemble includes: \item \code{'min.sd'} - Ensemble created by minimizing the uncertainty among predictions. \item \code{'threshold.frequency'} - Returns an ensemble based on threshold frequency (simple count). Requires thresholds to be computed. \item \code{'pca'} - Calculates a PCA between predictions of each algorithm and then extract the first axis (the one explaining the most variation). +\item \code{'superlearner'} - Composites two predictions through a 'meta-model' fitted on top +(using a \code{\link{glm}} by default). Requires binomial data in current Setup. } In addition to the different ensemble methods, a minimal threshold From db0c36212e930ebd1c0afa933435d993f2ae3b9f Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Fri, 23 Aug 2024 16:33:57 +0200 Subject: [PATCH 08/21] Addition of k-means threshold approach --- NEWS.md | 3 ++- R/threshold.R | 18 +++++++++++++++++- pkgdown/favicon/apple-touch-icon-120x120.png | Bin 2205 -> 4081 bytes pkgdown/favicon/apple-touch-icon-152x152.png | Bin 2824 -> 5398 bytes pkgdown/favicon/apple-touch-icon-180x180.png | Bin 3400 -> 6612 bytes pkgdown/favicon/apple-touch-icon-60x60.png | Bin 1191 -> 1968 bytes pkgdown/favicon/apple-touch-icon-76x76.png | Bin 1462 -> 2532 bytes pkgdown/favicon/apple-touch-icon.png | Bin 3400 -> 6612 bytes pkgdown/favicon/favicon-16x16.png | Bin 548 -> 659 bytes pkgdown/favicon/favicon-32x32.png | Bin 773 -> 1094 bytes pkgdown/favicon/favicon.ico | Bin 15086 -> 15086 bytes vignettes/Get_started.Rmd | 19 ------------------- 12 files changed, 19 insertions(+), 21 deletions(-) delete mode 100644 vignettes/Get_started.Rmd diff --git a/NEWS.md b/NEWS.md index 48b1eecd..92aa5329 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,9 @@ # ibis.iSDM 0.1.5 (current dev branch) #### New features -* Support for 'modal' value calculations in `ensemble()` and export of method. +* Support for 'modal' value calculations in `ensemble()`. * Support for 'superlearner' in `ensemble()`. +* Support for 'kmeans' derived threshold calculation in `threshold()` * Support for future processing streamlined. See FAQ section for instructions #18. #### Minor improvements and bug fixes diff --git a/R/threshold.R b/R/threshold.R index 7b5dc344..776661da 100644 --- a/R/threshold.R +++ b/R/threshold.R @@ -28,7 +28,9 @@ #' @param return_threshold Should threshold value be returned instead (Default: \code{FALSE}) #' @param ... other parameters not yet set. #' -#' @details The following options are currently implemented: +#' @details +#' The following options are currently implemented: +#' #' * \code{'fixed'} = applies a single pre-determined threshold. Requires \code{value} #' to be set. #' * \code{'mtp'} = minimum training presence is used to find and set the lowest @@ -52,6 +54,8 @@ #' Requires the \code{"modEvA"} package to be installed. #' * \code{'AUC'} = Determines the optimal AUC of presence records. Requires the #' \code{"modEvA"} package to be installed. +#' * \code{'kmeans'} = Determines a threshold based on a 2 cluster k-means clustering. +#' The presence class is assumed to be the cluster with the larger mean. #' #' @returns A [SpatRaster] if a [SpatRaster] object as input. Otherwise the threshold #' is added to the respective [`DistributionModel`] or [`BiodiversityScenario`] object. @@ -113,6 +117,7 @@ methods::setMethod( ) # Matching for correct method method <- match.arg(method, c('fixed','mtp','percentile','min.cv', + 'kmeans', # modEvA measures 'TSS','kappa','F1score','Sensitivity','Specificity', 'Misclass','Omission','Commission','Precision', @@ -264,6 +269,7 @@ methods::setMethod( # Match to correct spelling mistakes method <- match.arg(method, c('fixed','mtp','percentile','min.cv', + 'kmeans', # modEvA measures 'TSS','kappa','F1score','Sensitivity','Specificity', 'Misclass','Omission','Commission','Precision', @@ -325,6 +331,16 @@ methods::setMethod( # Combine as a vector tr <- c(tr, value) + } else if(method == 'kmeans') { + # K-means based clustering. Presence and absences are identified through + # by getting the value within regular sampled values + val <- terra::spatSample(raster_thresh, size = 1e6, method = "regular", + na.rm = TRUE, exhaustive = TRUE) + val <- subset(val, complete.cases(val)) + if(nrow(val)<5) stop("Not enough values for clustering found...") + clus <- stats::kmeans(val, centers = 2) + tr <- clus$centers[which.min(clus$centers[,1])] + rm(clus, val) } else { # Optimized threshold statistics using the modEvA package # FIXME: Could think of porting these functions but too much effort for diff --git a/pkgdown/favicon/apple-touch-icon-120x120.png b/pkgdown/favicon/apple-touch-icon-120x120.png index 2766747fb042e41625c8b0beb68b4ef3c653d7e0..142e8d21018f0b883e0a068fbda8cbf9380c7ef2 100644 GIT binary patch delta 3881 zcmV+^57zLV5%C|8bbsgw7Y#Ntf^I|(000h_NkluMyzyDN126dmdinxBMt>w3@#LB>OvjRg`hKvQjkk^ zgmSaA^xgu!rI(~lnp=~ccmBvZ=}B^ubID0l=&Iu}(~|#lLvRa2IE2HPXlZNxKkFonG)cV~4v~L!%<|Jmf$(Y$CPz zjf<5Gck%M8$Q<9Zvkz<{?e!l{P%zxZ%$KTt(Q2`Nal6t+Uo&~Qi#m9X@DWcsmmY*cBXS9Iot z8w4?HEH+`dF)~xBOZ-l2&ajDe&{M83Vz_YzR)Le;r+(0|iPYc$XC1i#=u}^~Id8Cu zw9U889B#C}8tv1b*O7PJAn5d0HyAhEh=)|-0*`1O5`Wl4YV&&wlnpm3k>lNM_mILS zQoZ|~GQ0t3jjvdrHfYRedVTo1lp|f`*`%)C;YuA=xW<^n3tQwI|DB?%ceqlEU%TjV zbtxmqy4{XpgH5D8?(y!S4?xFTWL0vjjY1TJf-oVJhu%l~ONY)DgwjxyD{{;RUo|N^ zfNY|ea(@ea&vj~&@9T*^Yo*9H)O)l0=<%-enwFH=R9dXwF2yc%tq;4<37XUz@AKa8 zJg1vzp9A27K5nae@IKetZ)b8{8)v?AG~41}rVyDr`9i1rfu+vx-Etaj(xE`5(xjsY zZ0ffR?KV1q%ly4H9`vMfF2ZOR*=LPrA8@-8^E+si{si*{xl%V7x2MwA$lZHQTKnQ_VL)oj+Tf1iV|5Vi$YTQt-cVr`zK9 zR-?iV7Q5MQ!E*01+j?gT)~0T<6|OYTPu*+1Fn9}By56t+b81{>x!wptp)0&oaJ`RV zntz2VRJ+wIwcg=_No}XX^=4?d&%4c5A<|)QubcRQ3a6sL2Cw;`QWyI}yqc%fM2kJ* zi>e1_;Zo>6E`PuUPH>|uRi?XVU5dr6v{tz>0t#%g-8ZfF zs%KKvwUri|V}|1_bfVjO{Gw2iws<#oRVF~J5q$m8Ftuf3W7=n9`l%sEmWbvMb>pYuTmF##Wpbo#;Mn=LZm>X%q)w% zWMy~WuUM^3dFF+g;;R<8$3yDU0T(#O&EB7R?mA%w z)%d&ztR)_|%=cOA)vGqij~q~~)PEw4DpY#O549l(h{bD1NbiIXah&K*m%GE`I(izW zr^a~Hx!G8@%4{zRPF8HDB7d<)P-%{rMBd{#Mb=xPRhiSh;dLcWwqBh|$D6KPofo_z zsBoHcL6fbv#!ER@hxPF*6*|QZTeB$~FS{f;R_Uus&kcK&oX_-H@7avLo_`?YTJx4r zADXw#1XiXx>VPwgr87{ZOo^7vyDe{R;8{Lpp3!!B+(X%V(zhP)Ja;=W{`Vz5Zjt9w z{Ho9>)h4S}qQO>gs!tJNzXgD&S<;Q$6>BYVrR_<-h)i*j3(YmjSfvVdXz-?&Ew{o( zjfWlkkShHp+h^S^p|@h;3x7%HCxowrRiPuKQfJr`o(Z>w`C-h^Jcn1OTUC%X@QAQ1 z1;`_zBtCjIKRg{eLpn8vXT!~5Rwy{~fv1LzDF9Z6>L3(`Yr^)lu!ri!rtqzB+ zg9je;b9iFP4)ZAGxW2AFeeCKPjWzi4J$KtR_Xlrqv6A$;z;n)rQwGmgbywMyw(T{Jm`LBK4Z2!J>271r|ygLQT8_q3aR)c73jx!-o%wHR-f z5^cr}vc_Z$Tz~8e&w4(K|JdLrKXRE%%*`+^4jS!L?kNx2VuuEu%1u(L#Y`s+szPTC zJku#|$#O8Z-3wl@#7X8m+q+Ci@o!!IP>DYr7s~u9z zL&`GnC^g3h`v-Z^We3=dBN$ z(msc$TuEC|!Xif|xYlZRY~r1P*%Qy%VXtJm>_R&4QY1#TPUkWi)? zw&~K{I)CE>2mH>{CcEXZ?7|y1;8rc&(Rh9r4Ym5!8~=x>Zs>s519DH6nVEizxH$>l>ZW0-pas{GL_x!v{0wh%(mWNl0YLRDs-y1+SzXMhBZSr3^0Vi37bwZs=J+b z8h>S;4u8;~Kv1O2C}WINro%dKYIMFYxXZdBLLLI(NSSeJ)WmI?=&3<)k{O<}O1TQ7 zjWI&82tlc1ZL`}%zk1KE^A?X=uErdg}RB)u2(cY#ke4S%ouPiOg#8Sc(Iavp%Iyt`kU29nz8Sm$W9 zp;zk+3KT0d%0$yOtJS8(<6cr`j@5Z?%Xt89Ri-MwaU&VD%l95?r!muwvnFZ(Q4lFq zVUjAOfud$yY0p4I<3tsavp%2JR_LV-4gZiy@_@jQ*O3{Hpg#9msKlFRevR> zK%qu^t<-L^on{L5qSRUB6*(_$xY@IU=?WD0@x6(n2Gfl5rh3Inl`B)CP@$N8+H~sB zA*NDflUk)_W3P~R>kQ`8GN z%3COs2jDU0n5a^*A{BjFau6vs-G2$n#fjv^t@7lqy{W=pQXt-Y&L?_t7r z8;vt9+n2PpIbgP#j!~o7DCOGivsb-F2N8(`2l}0riqPqxM)m47Y7rTwSu09R(vVA) zZu5k1dbOvwOI5cn14%xItyO_{jq)4;%_KQUJ zdm_6D)tFaPZ>R0AF->tzrW>Zmxj?m;m=TUOHXeGULyiQU+O=rWrcQ6iBhuiC8E zPP?>bj=Qb@4b%NuvC(o*Dl{|wPU053RU3hJjVhEQrd4r2%TFRfhks`K)!C=X!FcS| z6E&t)y*=tIx7z;9CsP~!!k0YI*R}%#6V&>>7masJx`$V@-6o_(?%Pf~d!a_6cpkfK zv(+vQBGu|LoiK0rj9VGWYou-3hPntyIRMrKdl0bX2^4tc!d0oy4-yJig<9MCS-r%;gsb(W=E`PZ%5 zOkZ4*X_!&y6pLJ%atq6V$OU9=)8wLcXtdi7Tl=rpO@8Yx|CiZVK{jz!x%a!t`vzJH zmkPP>1=HI!64RpIPCM0U>ECc2p7(vf&U{r&wt?h$SG&R7{(t|kf8=a!x=X{rzB$Q?crQk#|>^ew#KI{G%HmuhmccU zFl(D8^oINW*nb!s< zu*JD=%@132>8Sd2NkT`}$7#BBlzo1vOGniQrV=`;J|ULSQT36yE)DBv0RJDjij}$d zUbs2{001R)MObuXVRU6WV{&C-bY%cCFfuePFgPtTGgL7%IyE#pH83kMFgh?WwDCix r0000bbdv%I5*jouFgPtTGgL7%IyE#pH83kMFgh?W#jN`plP(BvdTgmg delta 1967 zcmZ|Ec{~$}0|0OpUXDnvpA8+J+vI%HT)!pfY>6ydM$vL?lQ8W$_KQykb5!1Bwo$or z6f?tQzm+4Ry}6G$QqCCLD&e*F`~Ua({l5Qx#m5;M50gmC2Y@=NW?(>}v7Fp5XMN8> zFW#Qs6q2yWF@rwwr5IRDj0QwY@4;aYsQ8kx;5wBXA^qhM98P!21_44p?i`TQ1 zwcP?OyH9rQ2y5FtNLwPdwqM|=_09bKdZtI@6Z?`hkta8yQmnjKG-hBrT^xuHSZPKi zC#KJya_*?*&I8i0cTo&{fKbvQIRu)8$le`r^ln217hKyxku5BTelyA9IUHQBP9Qdv zPk(_oRnbuHuN{f==?K0}6ebT^iukngxBfhG>lh{dD2FuPy2r3rQxLoju1H`Gm`8LB z>GjW=?m=%1kS}e2Zs88#5T4W>=82TD)!h&IrWm#zEC{gES{(6!djl@&dMQ@YHOuwD zH&J53EHA|(a&FVwH=BjIenl9jD(A8na;x<_#{Axux!`B_J;8Y22Ed+wLlwF z$-L|yQ&6C?4@JkueQgG+k`bbc)&OSTX;rNIUf-lVdu}c+&9r1HrOR8MhvvF0)MC)} znORSJuU(%iOAW8M{O5uQF~6c7sjDwf8zK#fY<}yGg_0F=oGJ8#fb$-L&_Z2*{@mdH z<#1&rP*555)U$~^Yf41rSoxPZO_MWs=ta#fgZCzT6nRoS0ZNdcukmf5&K8BQXH70C za(>SBPyM5_YtfkZrbVyX?)+rMNrGU>tL#)iFq0ES^<~bj~zL2=lw(e>@pAX4Z zRBJ~!m6#IvK>DfyrFF6)v`LACc!TJvI@A9W#IL{e#eriV3D%2fiL?5C^|+Tr(YbS3 zV+XbV-GMut)~7eev|Rh$iGNC$w#>5f!M~o14oVvdHL-w?+#-j)z>2faV_9P+v<5mJX`*8%=*XN2A=D_=4qqz2AX;>N+kX~xRSh(XRjg10deYVnQ;vvS(xwX`OGns z4H+D*o;IIc-DnFV-y>atDbzt+ywqAkj@EBHc76{yWXC;M7K0==0HzBZLaGdP&rS3t zC|4;tt2s3zjdPe324qxzp?QmG#SJw zrP8(EecIo548xSel73Y(TusGACJ}Rn73<_j^nryb8Uc&O(CxF}Z1$(%*re-1Jf=Vs zcWku%1x=!_B2QkNBNV$XN9(xM*31CxM`y0x66Ry>Ym6(sNHc;nB7+Z$9?Xnw+$5Xu z4!NpQr3ytS`FUz!1a(ox`=o9|(5BMTMk7AF&d1#7kd2w~v?ZT~2_V0(i_w}&ZCqi(UyRG}x ziHn547ur1naIvRj^CbZ@m~o<662(!r(blG*uTP46Z4^SsaNf&#_7<;O$49r$9SqKx zK_a62I^&TUvToqZxY9= z%z#mknM*(9BDHFzZO5lpwKSQWrxRtaX)IrWRTCT5AHn9J8;8DIZ09QTQFR~Wz#&`5 zNk3O3byeTZ2%AcTg_$LTS8IRI= zx->G_>gzMVLu^EPhi;}R;afmi2|F>uEyY3mt{fXgnBdfv_ t>bd|skc}zpv4Pmw=&yo_g%|#B<5&efg_-K{{{cvc(Z&D( diff --git a/pkgdown/favicon/apple-touch-icon-152x152.png b/pkgdown/favicon/apple-touch-icon-152x152.png index 3459cf2998216c441fb2938d4f5d8f3da6a8339c..929fc717e027ac1feb1a4429b67b32f48eca4232 100644 GIT binary patch delta 5222 zcmV-s6q)OY7M3cIbbsgw7Y#Nu^=WjN000xaNklQneXw>uHjTwDydZF zgp6b$gwY@*NFXQzMg|4J#>Od4H`)wQ1g;G}+ITP6-rIV;O&dYL;UPjdYUfJ0kQM@( zU=RZ$hGq;2A!JUdN-9asr)u3l>QtrXI#qS1`0!hQ)H!GGvwzRKzV+_4*Lv4P?kUg7 zmRart^0RHqk)UyI@QNnQHu;7r*)}J)RqAr9)eDIf_ngJbvu##xs=yf@RMiHnHC0>T zTt(S7FSit#>D#t-fz_J!Sn33M*)}s*G}<-RYw8hK5H#E1tB%UHso7VFi#@KcS6Hp7 z!CId(EZZh$Pk;GN^<$Mu!D>wh{oF!@*)}~Jn(CW2_X}2Q+Tpuqi?W@8OlpLyJTE>V zTtU#}WnVHj+u6vBik$BeH3Np#n(95}QbV$xo%AZtN$#?D(6Cz5e#^{PknL=xOB3DV zP0cC8)so(Ehv|QLC0dy)J)<$juv${wi@soFwzHTz6@NP0FC9z^tkzU(r3(~iJFA0N z%Q-yoYJ+ebWhS@?o)TV@OVs8UD%EtiftcyM6yi2nmhy_x_y0Qmgk8?F~1ZkZmMA ztHgzVt$#M_pxUPfzjH+{hJ^B+;z#`q)nqCi@Q^ceDk?@KzpZ%g~! zZ{ENgPy>x69py9r&dlygg-`pCuh?#?CEm8H!?Djg(^u^5_0peofg5eXY>S%a{9{4_f9YHfIXhFc-Pbyq=yr zFMq0X5Hxo&_fIMu>f`e3)jNR6ZpVGLC^FrLeb6dR%1!VSyA3hL0vEd1FEwGf$;LX< zV_>F5#v9kuPfT&E3*BwG%5(!O^a0oVsG&Wd@`fF%6R#sjnIm{L;c2hirUsOnWsF+y z*dgBG`y1_b5DQH9WzT^>c*Fz&L7m^&2!F=9&h>U#4ffdR5^Eg7g?6a!?V*@&t~*^~ zso$zg7qG}Nu6AW#b?1vMvP6X-a=B^B46(zvyo5`fV~KsHy2*4kN)))q!yUf=5tq5% z9wj7hH#p?YF2A(LQgdA459$#2h#P&tDpM@5%qRNFPl*f6x7^)cYWG8ZDEYS5Sbs|_ z_m#ez8pX;I|Jy?4e&}ldpx76cpeS+dGba0*FSyo^5*~M0MTW`4dJS&!NhcfMs+TMCVCyQ!M2af7?8_l7_B_^@j7|2$)cX{I~bO=kPH z`YvY`YtoQ-ooBt5eAxz1_b*IQV7?PvYN@qt7aI_;$kG1RX9pj{?EJi3VSkUa&2g>< z-}6L|->X#Vd6c=uhdhud?Ax1vtX=lDy>GO_d@EJ;zjj*cQVTrfUa$35qV)!Bl*?S> z#8gDdCuwMxEgG!xv=UR?<}#}_D3B-K!P0Vv+C21t4HkA|>{;enW`Da+o_B){12uE3 zB|hRl|JHL=u_s`~&auP?2Y=HK6GTSH6HM_j>uqg2Qs{iIc}I<{s>B8Sl{5XT*V}#n z3gsU0jym~fIL~Xgfygk!6dCC(f9=nfC(dsvv+BGsaFdD5_H7^Y11r0)Fm?~@Buji^ zpgnz2TX9?HIu~hhj9T|~D1Xki#0FI+8s$40F~b?|?{J+%uC&N@m48Z1vD=-A91QbK z^P>W-nPPTYYoma3AGU|4(7obeM|d*a9?lD6J9MgLucn^{ z4~zM0CEXrbXs)&G-XG^im-iZ(%s0UVA69Fl-+Ih*9YQ&|qCtAtl&~rEq?_8#Dh!_v z8$$n79oB{$!hg}3^0iF0B`5YWfZ^E0-%?-qL$msMzq_ZT4#LEZ^{Jw`B=h8i390C8k{{lII534QjYnWQKqAxH}w|@uo`3e=p{= zUXIp^TjZt`jBble_cf3Ep7&>TtX#^0o#M=1j=pWATYrp5*{@CVWh>q5?2JtUNindY zzLF^No2+tMmp;eWUE+)sXJM?xR(QaLO4Ekvuu@zPyUHb?(cS*LO2gdT?r5{gK9ZKX zEyG>rqt^J5Cml!^s~$Drdf4ejbszSV`H#%RZ2C~r>tFi5 z5l%?q^-=|1=la;-7nryf^xpC!A)kqm4D(aHEaN*mT*w9`vUaUT@IA@_bsk ze}DE;uV?M{s7FN##FQ9ij*EOerG;@%D)OQS(%k#hucp!Lur;g?6Z_rpChD>cfIBrHKusdQyq@)^Gf2?3d8z0nJB%$&K3F3K^w8pDo+~e zIP;zE^d4J)4Yt|nEpOXum%a9=)Y!+hn=;UonRKCF8ditRVNyza0}H~5;aA-h-GA}$ zc(^P~X`5)8t$xWtdDtX#Y)Em_C+@%8Y_>U_KE20nS!~E3)}U(o(~b6K8itB&@*kZ( zsr5)s;2I>bF(S{WrBe7rA_Up&kZQXObGu`*!KaG`1#FvDR;9(P*Ax9sFSx{oF88u| z{#Qm?1_M#jg?>R8o~D5z`QaBKgntmelz4wh*dIdpekjRYk)MuEkhrR}+>kWcjEc4a zc#rxSu69k<7dOe-QPexJJu!ccxF6c8$X6}MvRyd~tO~ml%Q?VnR$-jQSvEOmfid;BI#&ej|HYhJU%2{A#bP8)%`d2lEI3=rg<$o-&@pOsA zuk@c-kk!>7a}-#<87S*yUXA)L5-p zOz5<3Pvi|1PWQenS(qcYWJ@_U!B|7hGZ)X>&~0QQQsGUfTkJ)(S+F$gz>178&IBV9 z=L9=GZJAYQN#?Cfe0R>77 zGhB&ncH3gVv940-cNzDxECB25Qz7yEBN$?#LYq9R)u&=gl_@hsp$Idu&mQF#dRMSE z!^koStb3nouiyl;G{A_am0GC4 z%eI?gxRQiVbv!qSIe*##&GHnOXOiiimRvi6f%WZEhcS?6u9+HaGed#HKGj*xicA(^ zv-_RxcIUa(%SSS>NG#z~qYUZAr#hBXW1J`7+bZSvcy16WG1GA(RM_MHdfge8_*#ZK zdeZ`IqSKTo;Zp_e%BeilO;B&6rf%zB`C^6`uG|FWDs47RB!ANEC9lYHif1yiTtixb z?Nw<^5{G*)_3-Q~GJjK^-HFUc3Kc0)tWeB&!!@cCw@aN`^@gf3))rgE%*ZgZv^^yotP{-X z(Wlxgm|`?`Xfi~J5-|lL0dd>yXjc+O7%H+=ZCkx8lgQErEKh-5PI9~<3cB&B!>}UL zoForpH8{MSXlOel=sc0IR8X%;OX-(MWN86bW|9d;8-I#gWjgy*`*+1=IZh05ql{3e z+WsW!?nALxyc4oWWV!~w?{g?;P5~=%vU1IWxJ`ob9gapy6=~9}$SBi{PI%9|wktJ4 znVO^;I~|eD6xpR(g`IY%ae2420Nd?%&Qb=NyhR(bfD*GEEz&GsOx$j@%8b&W(SB8l zvMU)KMt|0*PO;6NQ=R51t!XO5wt3n@WkLd3FkYTQMaqm+qR}uk*lUk!L4|xpoyxAh z6&WgSlf4eA6*s|Ho6?G_CtxXvm~8j7g@z@np8HI2l$e;w$~CIBU!5BDiQ{qGl_%|6 zk)T;aqLLA}SAz(p7Kpmc*&MKHyK~m=CiypeOMjthgPr?(&_UBpaFi*=D^Q{Y)hg^& z>7ZIoTAzNA28WWs6$#>MRM}_0YW13xC~-hsghCTk_kSyy?u`GH?|8dA3%b{!mWPiN z8DYHfW;xN2M8zP_=mBpm+S#X?I~iVKqx!^(=XHLcSP*=GYV>T+%ft6J0&>6`5KJ=P zaDRme%FR-eFn=J(BF*CJ)vD8=S?Iy!3L7<|(IH#BIM4~L!3Otvu+!A_B!RVTadDN; z^>>SlBJYRySr*$^lty0}U{cDeh+~f7$9<+UV&puCEtH`we+?-8z zi6s^-iqxu6mRPbXsFmNxrMfGpdiu|{1b=vHRobD_PA{nJw5?Rqs`i+F@MF7rr=8rO z_L!sdG@3gX-EnX@kp$qEnnZUTM{)lU1=CC-kzJ-1xUj$|50wN|;+-M01T88MKF6~kQU`kuE- z?5LP|=Cn0>+TWNh{?*@dD(dCzCVz*#Yo|Rb`U2MErGagiIMA6Wy==&tJhI-5>baci zd~T#!z5RCEsX|RMzV*()H{=}n)SW!X`=Y-}W}Dt*kqySDs*g9*qEesWm3OI+)ez8)XlBg=?SwW!&v?tk@Ahb`i= z0t}{D>~Bo%{c2s2#nSInt=i$=+~>`~&sI#;^uv57yVfUqU(>cdGKMNhuTQn=pp}+d zmzpqtD(7pKILDIS7wzrnWoh-P7ByODsmD^cgjuR5xQ_BkfA7Se8&Dm+tb2n7?NcoZ z-gKV_``A`I%fMPz)&5(bHGipp$WrE0t=i)k?(u4>`$W<+g}T70u6J>w4IX)48N^Zt#kx?iM+Sh10`% z;rK8*#8S6#LbJDgeehc#XH$`5eb3JBvX>X~QoGJXg?r6S^J3Q-QGcPc{nEjd!s(o9 zt#m=gb|J`s%3SFgjcI`u_o6QhbPMEM)Q*(-Oz2lCQEu)xo%5##t>`fW0{g#=Z z{rOVqRgv>OqGr&r>OJMstWBHDutxYB&x;QjR+E=~$=GaXBeR<7Hk${8YlrWe{g+y5 z^`?BM`mxG>!8+*Y7Jp`R=cgP~iHkk1E-6?I*7{Vky`q1~8toeEyKg|XrDhv^H8Fes zJ&DZpZQFXpwZ~E?a#N))w_1I>M$dB=E6=uBxvkca zP_s?GVM?~mITDoTWXmk~fm{sL{C}$-qd}c|kIeu803~!qSX*>tVRU6WV{&C-bY%cC zFfuePFgPtTGgL7%IyE#pH8CqNFgh?W5{5_;0000bbVXQnWMOn=I&E)cX=Zr$GdeXiIyEsXFfckWFk{>Bu9KMxZ&JK`eEE)2)M^pLu2_c{ZNx0GLv3}XXqwg@wPP!7#HHqY5{}(7c0%eC`HyK4iTncmihwKat?2YCKLuAza zJ~1X3IVDchpOYySN&@F2fMYh#(VxNw=# z2wMh=ILBaKngI)kfLkwWL-=lP3V?Z)mtBUMP5YxW=EwEG0{F@2W$TD9-RxUOKfSk> zLr<{hW8aozK1ZL8F{UDVu>QHDTA#29lVn~A~FmLn|B@fL1s|7HE#jksj& zCu6vIO}3F(H#W6D9uG?!+Te1=D|Fc5Tm%G6U;YF+6dQKBHF(PpjR2N zE*#8k>J-v>g zYJ7cd0&`6MsD7kISqboLO!jsUNryX>Z>rh+x#6pTUC`UiiF@;D?WcufrjPteP|3#j z=Dv^)q&`CmHe>4Z6&8ZW%!sB>uLDp zvr!pLRjS_wGZvQ|(RROLDl7B4FH~pC$)*bXzRE<6;Bu9H_&~1dMaZ0CrZeg!K=VR$ zmuYTJm9Ay}NSP8VCDZm~UO;o0xK7xnG;0(3g$t!=QKX?_a$q_1s3_s6tKoMFIPvBc zK^s`t+{=5E))({c$FbD$V{!YRIlJkRbxCL_t~1$kZK-aK>eTJURW(kj zH=Jeq_SL@g5{xc*ipy0@Vgd+QVZW8Yh)MjSSCXd-5A|c6JK1_#O+eX<{vH=?u0r;S z;PeoqW}s2idvRxOt>%d=)Fr7_&v$q8v`$nK;g1hq42T&b_^!i$ZCgg(|4^vK`fdUl zn(F9e!RQD%`t3YU!Kx=uxa*Cju)T8ezQf$>>Jk}FVzQX z=m$L9r$CR2jWN{sxF=5HMZ4~hFMHA$eZ`I&5&S;zY-5}yeuUYA1a?^i38@A3Au(tIAY z)9pM%hysrnwxv1CyS6XTsa|CAq|j??vA3|5VRzJ&d$<eoPHKiL2`m7oV^PYr8AFBr0Hk7i!7-{gF%vg~tV)Ko!} zhrf-qrrcn6cj^JI^uVsqioV-Oe#5%BX46t_6M+$oyN*S{W3*iYse7}yLkIk(J@G;X zC*N_z&|aPWo(@k|ZwrqCbjx5ZE?H2A1G~oYsBGX0h9bOQCv3KAS<_8 zC}SHIa1Ez++0I%%g|?^H_0cu-1`NMBEWiOgEgT?=+{5~0komu=xQ$0zimhdT6N3B=^kMLN`ePF!${X{2xJj#$YWAto63LR(b_0{Mi19 z_myzAI`#3k+p~!V!5N6^JDTx5u{eXKz7zoi&U`(p!>@VwO;^2Rwm{fe3Y?ygy=W)y zKYc0^DdLtFmG&QPKX)1JwO*fidC*DYc)?qZenP#oD1}v^wl(;x|PDHFA zmkRCi!Fo3U3kJa5W=yf>V&KiWA*V!U>NN>Lfs_{XTtxqn7&t9@ea%CkTj)+jFVON5 zQ;O~CzJuvsm#5go*mjD^ViJQ`rUKs`xiA+H-5}ezVJ43nCW&KLT9vlonQSI_&wfBO z#krQ_LG&U#3l;P<+Drf;!Y6FObnsO=7hF;B>QL@8xM(}#QVW4YgHUO}C=qSuUa9zg zJtV2}?G2H({D$@MNuFVZZ-UvT-YVJW2_Y1`r*jy$memb?NOfPVBnIEuj`1uab-Y#$@xKcBY+MmvyC=VxYw-JbCt}%FIQ>La#|w z8-9@3TQ?mZbA@}v6}NhW(Vv<8Fvy$KUNZ8qJ-QH*AxkLL8idXphVq(AZFfbyXHD*1Mz!hY2u|puRS*E%}Yf zoj}*-h3ueen2A%E zhijOpwtI-@-(i43VK8N=iZV{?z_it1iqLCNZ74K7@{b$;Ap(Lt?s-N3Z}Bhi ML!o?+@Pt3;pBPNV761SM diff --git a/pkgdown/favicon/apple-touch-icon-180x180.png b/pkgdown/favicon/apple-touch-icon-180x180.png index e22ab0de817a267515958b1517c67e9534b9f28a..27df41f1e7e960d2a0da8bc5804d433ffdc96a8d 100644 GIT binary patch delta 6446 zcmZ{oRb13hyoMEnkPzuqYRRQ@X;?r~Nok~E>27`^lCl_-bW1EO!b&$tcjqo$OG&N> z=<$E<&c(T!&wS^7-np2odHU(6MLzlhy96{O;-W4jYtnb_&<3eP6%7Ix579x%7KSPE zKgYtVw#yAbdUWx`>@11|qPm1icp3yEPu@O@WUYJ4HR+EiMX#E+Z;ijvuiq}4z|^j7GVrx)dV-64im<(QXLzjA78^o~h)fUIM5 zKyKJ2+VN>L4J&B?s+o~ZU`~4>R|u10Imzk(chMT~^SOMHY`RW<(G}=?TA`UR=!d!# z*u45^H9w>19a45-_MURPDd-v>Pb9SOVWq5-JFgj^U&C``rqr^~ti9!U*1OHRC#XR~ z&{k7fH%*UDKzoy=y1M|JIiQUkXmmgQsXToRMzL{xUec_UX5y5e(|)S+Wu4w73ATk9 z1g%JzecUG{#!ooq9&@6N_WCpkPDV2$l7kBw8&ZDA^Eerah>EM217EqjY(CyYgkk8_i;4LTgRrn7^6&0CNT&5Vf|-nNs6Fvp}*!U z_{OOK$e(L=RSQn?sXMu?h2!wvCa7V($mmb8`s*MfLwNnPrIisplv8p{E6S+`jX0{K z*AMG^PM%LK_UDLhY=NS^ZMc5qv|#_>FwobkW?Z^$uhK3>JOm?*D`qEbeeL;GE2mNJ z_yF@Tk=g}X`;1bPOQN|2=Atnp7Ni|XeSZ`<<1o9O1zmwMUE%^NR3jn{LQM1e?>_=x za?01;g&JhoRK&FW zFctk>@X5CPsSpwC046-DU8>)}mHSqMk*By{pM)PlWPhZzl~6^2q*tT{&D}z7=7WKt z)Idu%N#*xqVGOivSuSnOH_KReivh_ATRyMG#xSegV^-aOAJV-M{NBk*F3a{}U-oR7 zFYxeUq|tm={-%4M8W{b<6>_I{Uu9@}zEP{(m#pbK)j8U_!&)e*k~zC}p3zt37X(qu{*v>gnnnWB6%et%9%A7$kD z8%dWp`M@FaDtuSctWspq5xnPBrBq_Z9uI+kMI3mGR+oxh)q-_In>Ny749!@dmc#}= z^CO2#4*MN>9x0e3Zc}zkyTeBN^a47*J8ys6INds`R&G1HP4c;U7Ou*B8fLx<@E~*# zV(%C3%YoZFbF(?>6z>5R=EQoCBM3>%Ws!&B$U2fv3=JAYma~)hZVn=g|C^gXjJGAvgNd&!?B^2**^rnjTVmT9jjN7op-O< zS^1RbHZCRlKCyV+CLk%6of~E<*1vCbdzbJA=3@t*mLvWkBa%9b9-R|KT*JV7!ovyv+e0Rb z>|?!S&A%mA8dI&*PxBUm$GUlnDLlNg`IE%<{sR&wKO9IbkU7ZdL7hvbxF?28`un5t zXD_X$caPjItttTNC9JG?Zd0*DbHQqn>Z*7 z$N92B?Q0 zIhiv?hw9v4wl*A}f#H|DJ|!PW+rm$?SYeGIT~2QOLuDR=pf3HBg>}0}vL3Y^c4v&R zWL1|NAvpm)pA4m;)<~ri*yT6s2(RtHT=jUd#a$D`x_{3usf2eDT6}SQ;MJ>DQ8@D+ z>j*h#>Ce^IVXB9}P#oM4_jN9u)7P68MOu!qVKlqn^TPQdq244G--|o{c zo|+Vzd~hZR{ZwXVBji^z`4+Q!6}LQxIrR}KE?@3OInbMS;Nre5ftK-PeEOdywWb@r z&HFx~=)dP>0F($W+-aB6%VXe?37=hB?2C!WkFI!ZarE0=wB9;vzjcpH9Z96+`~7PB z3oPq2@r88$L+Og@E|g`pytXpb({S z-ohXG`bB8f(8ASP(Ato-i@XyC*Plb!PR>lfO`=|a610~3(Qo{lPn~) zsN^ef7WaKlb}%Y@KW&sA?@^nG&Ut~{VRm-;$i)^hxS!d&+Um+GR|_mDVcRb_krY-p z^|FE2dcK<>BWz%kxUOJ6&fTkBU|Y}wsu~B3o(XLC{#{w;FKOaZq{Kb+Ng8FGiV0OS zgEe{(SI=ZPr+>?$G3w)_fUl8tpT0Dvm7BLMI03q?NL~jEzx>fP*Zr4*Ijihhl=(0* z8L1UK04a5&YfMiRr5LF80VxqZV!{p~?*1lbP7}^4V&@1r7_aj9DC`=oU~B5CuG4{q zKf@G~{bJ$A83~ER7N3L)Uih#Opx0I)UCxm#NswoP-SslN@qFOlqmL)3PRe|DNv-No z8@SoTo)qP~ZiL~$#yOwXoCx&1gy~-R1_HC^ZFiyIo~F2Y6>Ifd0N=48C*kp}T-y6p zU8_Cg=L?BD6b)BCaPPF{F&dGKbs^v$R4okS+kzb;G(xo7sXS~J@f@z39@(>$pCqJv z_B)cl!`}*5e_zdIS+MBbSK1~=c%+)H8CZ-P#Ys__-gGFdk2Z`={;7-_CMvMRske{K z-%jbA%e?oh%2mIt{yyN>wq&0^KHgCrzE+Wtp6d*PV5fS6r)mjl3Tg{SYk|=dA6~8*{VWAMp-37&M+{c7OVSL|_)8?>i~QBxJ6@~0-|+%w`Li$KpLG}}Vr;{x zLq}c&@^w~`HTV%g${}ppP&KV?UX!2ZqD>N=AN@0uL@du%KYr~L{8)m?t(n~1afS1C z!Hu|UCmTUmFU(q!Q-0$|i;^?>)Tdqd8>aEQ*7dS~|4jx+@E9B)BgK}026m>a7*xXD zUyvFJjKHIALE^dSsdXSNDj?dLHo88B&Bw*Zu5a#B>q#5;F&_$ryAmq^&QVYSx6Goc~m2jGw2HV)V zEpK1tu>n5lmUsV#F-`~KQZWB2hlJR^=OkjpngwSnVwbU`LH($Yrhk4`*cv~P)iZGU zP~`81lPE@%rD)@|l3*{oP~PH{2%;2l-Lf>gS4F&%d!*wq_deo~)Tm2;Plm zndl)^3Gb@J&%F?po9x4$nZKrea!Zyto%*tk6TqSoU?tm9YcA69R+}sYT)AQ?W?HEb z9`J?)Bif^$GwP?@Y&}nYOXv93;$*Btx41XGwCni;Jd)Y;bvw-%W7@56Y{CAaQrkXt zbRKUBdwHl1J#)8AHYC-4y;1W)PxI3{KzA4(VOw|a+fov|>(W^<$McwX_>79Co#=)M z0(_oMp~K4W#J~)$FHHSLT9EirLE+%Yw~oCwJ9_^s<&s$Vk<&#vNF+OT z-yxv$qY+aCULjm!g0`4-FcfSvNhzWuv+fI4?*(aokH2#A?ol0-i}Ead>YGsh z9yM#ZLXuHPh0x3ze|1HlQCMTwW40y)KzxkiAb{5?Kv8OkN9S8HPK_6hN0iZzC*tfHd~Q^C?}2QK)7BqaW)jnIi%b%zoFENsBEc}Y@X~_}S#kE# zQK^Y*yTFRi{KCt0`9j-|4o*sg$su+P28uH0;t4BNPs|PlHD0$VM68hAE%$j2_*(rJ zEHto*@*7OpW$$K@C2rAZIeZNTzqHPhZu!)l$jS*V0d;3jz$$DXz$$!VYutsiN}~x) z-{G|s4YV7ts-gWU2gPeNd=1j?=_Rj;f8Sqw0J4r$QX#Z!*fC^dWK}5atMDmEx|t*c zkF2flRy;-nbVsh534$1}QlJ|7;w=mIPE23gm;_?#z#0+Oul~m-NW3ZYu?b6Xs?^{$ zclWhx+_)>-NkFaoSx6LXK|K7WdkayNzgblQo6rwck9b-~)jpl|1y!S13{u6KtO^=X z4q5t-GGfzGgTvL4k0`&Cb`h{8|DcI%JABYQB5V`|Rw93=!Keu&mW~olG|R39QY1aj z?q@!#h$-Rj>vcb6B!X^o8zIf(6toN|^RW%v=cSQBM#NC9mFr!UnW9Hje0^`c-XZMihv4M`eWPf%s+?w!(xdyX;6a zTDnj>r@r?U5(;ec8dN-QyAy;xe7uNIL42VW%EzN{)n8TFC;tIXUDnH1IYSOoBWY z1lpVeKab1p1nnR`FR=9Rxb7P(OebNlYBc?fV)?}v?*kMGx^^F^i^CpP#;}5AUZ8Tn?5InbqdxKaKXi{%oW6rF;+ZL3=> zUUtGSMU_28HA4;RO`d7P4#t<&3GM0sL6x6K_s7#hC|)x0Na#0GYZnYA7?t)|1`)k0 zpDC@?20j^w?ra%Mq+=Cce^wQkx64G+qZ(-0HK7tFiciXy*c%n%@HQxW$Krze#7Rz> zoW92@JaZVkBP>tD;L!{cB7qqqs)ts*KMrt9O*oG@ptIg!BjHaB^NiEIRJkZAh{Vcj z_2EVl4w=cmMW1$oB)ojQV$65#R)_qKe49U?feXL7fmruiiB_t^LI^ZRp>m+NpQ2Py zH_sA&NH6LXKO`0L(4%Lh25|b0924!9+zx2V&Vx2-G3;Teorf{dJJ7Db0V&xz++%zgarF>@jMAa}B zSWG>F8v3O+W3WH!wR1kYpwueFM~lvPPh<)ickiHv#Z5oODriOGT`36(xpf<|E@($> z->J+v(6z6}HWbX``h)ed({#$sT2`Ce9PMk&E-!R+eA_fzJv<}CH?)N?PCad*A2M6!(^!%gx%B`0Z2IM? zf5#JHDs0$@AWOv>*f)fznTahN=(-r-rkG#64SvzkXk-BQYwFFxiHY;cDpm-o!=Ij|J;F z!Mai)ba@aa;TA)`&?dC|6p+jyLR*fw>1}Un1>*W13jgIjwSFa8{nrks_KHlE>{z#Q z))K7#RAbfcMfnl1!XUfxaOnDJz2JDo6SIG%I7)KG&FeZh$`^v6H?xZ&}pj!L&U4^Ut6sLuVzu;ex~a>;WbUwC+BOL}0KW z_Z$4b zz>1ZhaqG5iT~zD`eq#OvNhozYI>!l0S>1(E7D~3F!{Tr6XS~7B; zP5U!(}5pFjq4>H^Ze? zdPapF1^!pQ6_9%60%}7$xGS$Ioms4H8ki$2%8o)nUySJ7)gn33tDk%UUi93ymQ4{V z6r&p!qR^~|4)K}d>2`~~%KUrzH`ul9i>h7t`-1`gOJ|Ym^0I((5!Qdr2c-4JnG1m# zt_Ld2fM3HGR$ySo;0#7%SdX*idlgfWE~T@fd+Tr4GqZ z*YoX3XO9!x7?Ka>9QV|6g50Y`=m-_Rq%C9tTeU}Zf-~v+o@!-1%zC-HN)#!e7tNA| z&3a^t1`U%#rZuYG2r(qHO1J%tSc4|Xbkhb;#k5Q$ri+HjYN=ANx|@ITG}Ne4Lt8v8xnJo0a!5Kx@< zJ=SC+BcSA8K2~yhMpP_|d()8p$qap%q*4qp{xUps4Gdx)*K{lDdou%NIg xSWpryEMg!e0ud91hzauw3PJ=0+1&L${2#!L&BM;wA?W`n^hB^CNejdt{{yk-*bo2! delta 3210 zcmajhc{~%2!@%*;(%hSzIkMsF)@&k2?)x6n+}AKgxogBw&RA~dR!St-R7B+{!#0*B zH|1VABXWH8d;Wc%*XwznzdnDx|NneJ4qV8N#ILZ33UVnnp6{&$05~@+j18RbPHmLq zBAv#>$$ChrV!8p8osUaee}dHql_biR?%Gf#_>r5i@BNa}f*!7Oei7b=eQDyh-ZG^y zT5mGrYAl%)v#s9-G=K&h0{M*04b4Hs^}(h6M_rl7K`Ler6R;V(6CeMVtLx7E$)*PW z_GTw#>r_IHpCj3@+W!BFFxbkzNy1hMHBnc~0`061XD_5Xn}%^0fY~T^Pot-8)z^5U3i~>haSmGcZCZ2M<10PWinsCZ9Ym-ASZ6u388sCDYjV)1zB$!a{cy(Y;k0SrCUxHAK_b<>3O=2R*zYWJ(wH*1=Rp6x>a=JRnL@;6kPJD zaU2X<=gJ)@cOGGD+*0(Nw=5kI(4$G4buiaCTdCsCYyOiD|h0>lhy)jV1p9l^9*pbWMbHZ zt5CT_Z^rySAtT<5BlIj@zyY(_EErA7cZ$e@`9-O-R6?F~TEnTsZ*&IHyVjj^pO@or z`CW9ove=T;1khj}aRW!DjZ9D+YV~ocGFr+)v9_xLeb6m7mKN(%12@T~_kq@;x5ha|bB7 zhVo->xVcbFD&uO_md9p#vaQ_?kfVlk_0d>!q2g=<(_EUsTPD^PR!P~_&iQxLWOuy& zP?nK}9E=gN;TivdYp3K*M=*SNUU{dChOT@*GWsBul7S_-O(GA50W$r?t9#`owYW^ zEv~2ZgBuVr6Zfe;qDxt}ifvUxiujjp)SB~H-rC;2vmqJuI1QF^g)OHS*jntJi+=c~qx7x)JrrIY23F$y zc3Jr&GH=Y&Svbp&*06nrgGUZoXV6^vo#jI~kaXzoke@1X^ZWRzlbzQw)?at0ja2eD zfpgYSMT1n9k>I6C=i-dlivcEs_H+2!ZiD>T@IPfzplx9(Pu6`!aqCY;X$q$+DlBB( z$4%ooMi;i#=g-+-wWt52R5qts83~GyTO*_LBQlM|mV}olu%8Uo2HgjYeOpk;SrDqX zn#;_PVjGZAja8SF^R)&kTJWHkhwIKUQvC~_ z@vd~}A3j_`tWn#OkzUEx_7ss!t~E7V(O38EbiKT#lGT3PC60PuH??Er*ub(HcqjWU z3}i$nj9H1)Z+!jP-^S}BwQasQ(By~YYx8{xj@AMj(E4*#s|3Qr)y73QDe3R{9V;by z>u=%V!pnYMbwoa%@C3t*=T#R(Z2~6n9@-^*z*2t|2UfupQg5m^Li8q)4EH0Cb_BA# z1f8l(b4%t1#!mEHqr#-vq7M5nLO>F^8*BihuFcrP6tPL3X!3ZDkMv@KGl#!6SGUF7 zPIx4D; zVYDX%ytdYyT@&oCC{Fui{qsKZ=(_w!YvG&rJa<6j_Z_-*09!?9#ezrWILN4H%(id0 zwgqe|3@2O#0c~`G%d*|#jD;Ke)J7oye6N4YUQ9g%G#uI)EOgAavrc~yKkttoeYDzk z_k(Y%zxJdM=+63O^whFB2fp)_l$WaI>(aQyqPB|uv01{*vU&CIXDEq`0M{Q|mI8pl zS?lmP5#B+?f*1>gFa@cC6xT)=QFLJnOqY;;EI~I*4--Wy_xKnp-v=}z+ zvCDDQkzyde88wH)%brV+JEXh{5YXyVou1jeyzo4O2Eb5;?Y(XJT(;02lT&>sGcrz6 zSWKgP5e;W{X+?{?>UXuPxH`c@pP#h+bu81+O=K%gB-k&Ow0|=@^m|K9*Yt+!TgZBTp0kg zQOe$U?_$0v$(mR`&r~St^#LYDnX>D_wJ2=?QeJ^w*ef?7pdalf(E?O`tz=g^HRLTt zW$e`WEIu>OgL`o|)~4a_pB?oA#kz<{4({eQe@uTke`3|>V&`JlXNcvze3V@D-x7Y# z5iH`}+V!Of{?f92wsqe^d9zPYZyhoOL^vv!+G8&Y5nk5mJ!@+260D@8ld4Z2_KWxO zBS=Mkg~l7Ggou5!=$C6LCz`9W_IQ4XNdBlPgWozi11~NL(zhRgA-ja7)zCOktCMX- zy(V~C0il=~t^60GrjcXDIi};?|B~7x=@=`sZ2O^?ZGqTV+Xlsw301T@p^9#I!CZk8 zb|>VzduzC?5sUT^Y;t%dqsAJdQ~ec~CKM53rAgdd}g~ zeUyM+-t{Xfq_7CA$fc~V%DF6+*W2tLcUft|6CCRP(9J~?l$ zg285N%2Us{k~#C*P8g~0{sEp#^X9r9rtE^rrjht>oUi|VGTkB&rNYgRMa6Q+Hk_FJ zR6MCmMW(i7gqH+W7h2wEVVKK%ZL{J@;z+60=JbHg92DeCoRdWVsPPH(^u(=lr)BkpOHGeQ7w&15|7B%-{R)@i6tH17)++1f#9euMHnB`7Ro6`sXuf^lt~TXXE$K z>8rZx_KR4#8|c1BveA)(0=_wn7_1Tds7rgQ_wGuz0c=&Z_zEzJza@)z;yZueUy<9* z`A)wuoMUcF>~X412%a7n0_i@CLvsLP8^!E;wae!yqU`o;PHM~NN{RJwZAu(J%Br*o znI~eLn5l{R|DIY7|3AJvLw_58Znm9FKNdI!001(PCg@0vPo%$=U%3B&1%QAf5Xx{> uWrT(k0->df&{9Jx!r@wQxH3R_>A!)H+nAsL-2V>TJqpkOKwh9o$bSH&4D7`K diff --git a/pkgdown/favicon/apple-touch-icon-60x60.png b/pkgdown/favicon/apple-touch-icon-60x60.png index 42f002148499a0276d0478decbb2f8920a0d774b..4622a578455e70877fd338e50cb3f4c08a87d22a 100644 GIT binary patch delta 1765 zcmV`pto-OF^_(%*SC|M~yV_kTR+@;v7}hlMHWQ=ag& zjY<|+!-BNJ13nN!n+Kiu@jw^(rq^Y~WXXBcx7D3lXsPQwY4{j4Uq(FR3(C$6G~r^8 z>N)|MFFk(mQpwYeZE~-DvqJOb1NUn_eb8!O^NR6#u_0u=>NYi}4o%tUF@r@x^JUl; z*D5^~>?#lIJbx)@z8vw03ndl;&A8L<1wr#=k9#zp9JJC`{L`37L`!7ivPgtj6z3LH zTNy1;9_!=tu_n@Sb!?24k%*?aI7DMy5{VGTz3gUHGa*W5c(UHl+-IdE39Z6sBqY#a z&{}ETLY3vtcfMWHQa)p^D^+OpRj=9PD*qNFt?)%_w14?X%nfdFkB4l?JA;Icx~i=A*+qqD`fmbyN$Y(YLPVT4Y`RbN?qj38tv6p2r69gi`{OEA89Il zp-fVnXAN2`Ww%P_C_z$%H~iI6w^$-jCM)3`NpH(eHK)N{p74E3PP91ba~^iPrl~VA zVYPN^q<<~4N3C92=jm{zLzJ zY<1bplY78&we}lOsoZi0b;;;dV^oWjeFn5DaY&~c^h>GNIekzk^tS69EPT-D?NeGh z#g_N2IB|?;Ra*UNkN2thUP!pn57c?q&$UlJtACKOR7!_-BWDV{&aX6Mt(<#=S~s}a zYW0%3yyGP=*r9L1md`rIcSl}3Vo9uwzr|=wRbMK5uiZnV>8(C$7j zJ8W>O|DAJ{u9+HZieJY|T;U;OlfRy^O|!*T`G#wX@?r@C3j=Sk(|ZNKyLID5kGs_^ z)<{o#KdWDlowjL{QLk)zXeUvxtZMmC1yhYN~MvsgUlv8g+i8T5+%p0mx3p0=wf>k2i?tRC>J@p(S& z@vcAH>@5$fK3(8qlyk&k{KZAqew^Sk)w0;(DeFH@@G75Bf-=upr~D+po_8ZKyMJy{ zuHLnlTCCY>JI*vXp-R0L*V=Bi5@FmCUpkZEQj09LOoJ-dD6?IuN{f_fbBq7jTBOq` z8a!d+GEM4KNXV&ng&i8zsge>#Wc)Xm8GYDkNthB1JI5;aETw0d2Y zazjOfv$M^LA$v4ApxU{XS%Dt^lhQqT-b)}MQ0<_D`n@$5b|fFB^P7ob`+qE(Jo-*+ zS&c@Qs#7biSC=89ldVi3j2Y0QOF#OM);4p18TXo+1NCoAb)ujxN=jKgj}b$=c^H5D;z`{b#*U|*Bfp+>o3HO3`X z9J8@ouOZ_?){rAU@}W+2IDax7+vzv%_Eg~*Oz+wr&wD{y>+zK6nDzqnsNMn_$MorN zK$}hjva-e`v=?^upvT>5^YqrtoC2$~$z3)apYv6&)?$g3lkLeG)~|Q60SS!ibI3uR zjvn9UWo`3IPZ&HAF?;SU<5qXLU^@Cdqk8ojG=_wnL0t~&&~0R@*MHjUQGe7ibMEFn%#fSmu*bh;4Yg~9!Jk%C@)h6z0h4Rp z0`AA(&j0`bC3HntbXsI#bY(hYa%Ew3WdJfTGBhnPI4v?WR53F;H8eUjI4dwPIxsLx zv<+VX001R)MObuXVRU6WZEs|0W_bWIFfuePFgPtTGgL7%IyE#pG&n0TFgh?WI_b6J HlQ;x#_G@kc delta 945 zcmV;i15W&~52p!`bbsan8x{;E(4xK~0009_NklW;o>0|j}FWU!m1c!utV?%uKPJb;nM)_rqxNLYzR|mDTYGW}O zF@ByM-gYi(a`XRmX~>9cx(sM?%6b1NP>OZ>W0y|tvK8L-jNjrOUAA?q-0z`q z?K7lFvwz?9xTM>#QKLb=iyB|bOL%ooq~b?CCnpF<%yE@!Gm!AJLyj3Ss70q$LczdO zRjMq|`f@!^SZ0eh`;z@zNJfQPJPr2y+kHVEo!c%)BOQ9eh~06nj`IjkCtMS4KDF8M z#RBIl4re*;EurZ@6AJ~dP$nz{X49PK#D= zwNaJ2T$?>WhUBzezQa*|jzSwW$n>MvR4a8M>9d?gC4TTy#JkDup7gDY-gKu|61h<( zn`rTND;_v-bY%wYGbv-Q^T diff --git a/pkgdown/favicon/apple-touch-icon-76x76.png b/pkgdown/favicon/apple-touch-icon-76x76.png index d37b5ed37aac4dd07f5a565b40e071dd364b76c8..f3efa90fd2764998b5dfd1350b0defde7405e6fc 100644 GIT binary patch delta 2334 zcmV+(3E}p(3*-}!bbsgw7Y#Ns8)p@?000PyNkllB?GsK~{> z?Z`<`nbhw4mP?#ztXb}{D=Snc?eTeY&m2^#TRowFQmh~t@QmA(pMI#MtNl_}PEeV2 z+@r2jcsj8b`+u54Q-aE*7T@$5(dmGy@i9BZ)501|FS}cPexXX-Y>U2AfErBw9=E}a z{6HnV-cNL%GE^pYdBjzx{^FYNOZI0fjY1+na815q(Zmf;L|)}K8@*EnEHGcvY7Jna z1)9b@!6HpoS!abZ2VCoFOQp03-lS5KA~%S&LYXVQMSo9T6;^q{3{^_)vCBX@zru_DZk-CR`gyuk zhdyP3tu}bpt0z0Ma<^IIhrX|IBCv9|_=FYNU%h=85RmY+9?M

q2^gQDBR|sr6as zrA@Fvq(y=K{%WTy#`myu-Rmab@GD2h1B=GpFxS$)>~%A%tC_ zDdetWVNr>^JFu-R|>OUDI}-k$SUpx^q&` zzgnelq*tl%U$=U#1!^p^#zj-!&gs#a53q!rJ?!A9YwiB!U*G~C^?r4eHqxt2o0Mt^ zbF(cLrv|o2olRMD8{O*{-eIkalz)#|HphB&IcSfA9`%Y=DfJTOeG^V*;^JRW`=gvH_6@W6ByJyY>xU4J7S#boNy z4~z*G1s3vU`b`^`S(8$dHpFZb@B>UWua91_d`l8Jy*as zSgISRi{FQ8IoEZ zu-=z_(JQAPY^04+5`rKWNm{K(uh%J&KoC@^l5nZ}{mABNEG(x0cD|)*(>4l%0SU#* zl$&p*XH|k&q*$pM=WF+jS6%C6yH6)rzj{?-u}FcG3YE$fOIV@XA%8(aQkiIB=& zFw=9IU8&Fh(+Ae%AFeY?>CiZe1hFdfY?o9irC6zQz4qwQr(K_A8bq$~&nco!0c@sP zk;STp#!(Qdvr5VwmAVa}R}Y9(Xcw!pRD*=oHcx3^Z6w$vhjuevrdXq5Gf-%uQY9*t z=+vobsQ7R-RT7$&nSX7ImvrUAGgNpOETkVbt6o*$O6+rqYID^}>a&Ytbnd>lQ}YE7t3nc5ONk zYg3`tLA?_}o$xmg*qQMxBadtv{Xv5Z%pSi}7rRcSq-wDqg?}QWdp{EN>vmL|c3pbK zB9SsQIG{Cqm&CTa&;51`JG{|nNhdsSlXi>KPHB`n6sgyxPo-F|RJ!n38yzR`}$6Px4o}^Wli_CJNWEzK{Pqz*oj_DI4k`VOi(CnaQoujt~f}OtO zVMnqxK3TxQe0RFToNQ=?2J|}Ss17~)5s5?w9M`HzlYcfnCmZCDpZKm_6E!?}Bt*hW zpKyz^lhNvwX0_2_$Hw12>9)y6Pfzw;m|KWOiMRTctA~AD1})@jqd^UL+D4nwr`34? zgBtI3mt~m}gJ=c0*eIi2zU!e0_h_cAQ6V(Ra9Ma;SQ+MoREQ?~_&<#yG#NvU2s%pS zwzF{tf`5(%bxww9WpqvkwhihW4Fw$3IT<{eQMudCy>Qcv&dC7XLFGN9`Tq(zROAKW zG>QNK03~!qSaf7zbY(hYa%Ew3WdJfTGBhnPI4v?WR53F;H8eUjIV&(QIxsNp!v^aB z001R)MObuXVRU6WZEs|0W_bWIFfuePFgPtTGZR!XGdeXiIy5;eFfckWFr1#gSCdBt EZ_*QgYybcN delta 1255 zcmVyAT3Ct z3P=IPDCH*98+d#07K4yTP%%anNsJ~)qVWr^|f&X1-geUu#CT;ejty2}YCXxq&U@u6|eS5dR9ZsF}>gqw_1 zs#tgR_S^1TTm0!{NB7r!L96n$-c6o}36?t`7FVOeKI^@xT#t^E)ysErVQbs~3OuJO z&eys`tvAbnj(-t0)ZVyoF%P1T3JvF#b*7wFX^xWcg-vukA=oTkyqhq9=M%ThTm!?J z7H4=iAxxv`9#x;Rth0CR^0F&L!jV;KyFjBaZEWtLYSV2^Q`Xre*yBy33<2?GO`R4u5z@S*F7}$X0=m^aGYwfqzggVU}f@KWYumP+@@z|3(ND2!J_J$Eir4Aru~8oU06@o zVWZyp&>lz%|2_ms;|y}@v1WyDOm7CV*1caeeE>=Sdn zlG&P;Iipos9QTl26uH7wAKU3G73k|Gy;5zm-QTJZ@u)oSHy<*H=xu_VO*Pn74;$oq z97=Lh?NDK5?)SOM7M2N~RHxo1i>>jOds8?LhE6w21s-l?D=vZR(6j-HIo`Y#N}0@tva7KQ)G9U8NcleZmKzPQC&TkqNJI>? zMAR|cJ+I6>E96S$@1Hctq_Jx}?WBWt``%uG-lkZU>KB`iq^n+WDUcg(Z)M4nB}27`^lCl_-bW1EO!b&$tcjqo$OG&N> z=<$E<&c(T!&wS^7-np2odHU(6MLzlhy96{O;$n@11|qPm1icp3yEPu@O@WUYJ4HR+EiMX#E+Z;ijvuiq}4z|^j7GVrx)dV-64im<(QXLzjA78^o~h)fUIM5 zKyKJ2+VN>L4J&B?s+o~ZU`~4>R|u10Imzk(chMT~^SOMHY`RW<(G}=?TA`UR=!d!# z*u45^H9w>19a45-_MURPDd-v>Pb9SOVWq5-JFgj^U&C``rqr^~ti9!U*1OHRC#XR~ z&{k7fH%*UDKzoy=y1M|JIiQUkXmmgQsXToRMzL{xUec_UX5y5e(|)S+Wu4w73ATk9 z1g%JzecUG{#!ooq9&@6N_WCpkPDV2$l7kBw8&ZDA^Eerah>EM217EqjY(CyYgkk8_i;4LTgRrn7^6&0CNT&5Vf|-nNs6Fvp}*!U z_{OOK$e(L=RSQn?sXMu?h2!wvCa7V($mmb8`s*MfLwNnPrIisplv8p{E6S+`jX0{K z*AMG^PM%LK_UDLhY=NS^ZMc5qv|#_>FwobkW?Z^$uhK3>JOm?*D`qEbeeL;GE2mNJ z_yF@Tk=g}X`;1bPOQN|2=Atnp7Ni|XeSZ`<<1o9O1zmwMUE%^NR3jn{LQM1e?>_=x za?01;g&JhoRK&FW zFctk>@X5CPsSpwC046-DU8>)}mHSqMk*By{pM)PlWPhZzl~6^2q*tT{&D}z7=7WKt z)Idu%N#*xqVGOivSuSnOH_KReivh_ATRyMG#xSegV^-aOAJV-M{NBk*F3a{}U-oR7 zFYxeUq|tm={-%4M8W{b<6>_I{Uu9@}zEP{(m#pbK)j8U_!&)e*k~zC}p3zt37X(qu{*v>gnnnWB6%et%9%A7$kD z8%dWp`M@FaDtuSctWspq5xnPBrBq_Z9uI+kMI3mGR+oxh)q-_In>Ny749!@dmc#}= z^CO2#4*MN>9x0e3Zc}zkyTeBN^a47*J8ys6INds`R&G1HP4c;U7Ou*B8fLx<@E~*# zV(%C3%YoZFbF(?>6z>5R=EQoCBM3>%Ws!&B$U2fv3=JAYma~)hZVn=g|C^gXjJGAvgNd&!?B^2**^rnjTVmT9jjN7op-O< zS^1RbHZCRlKCyV+CLk%6of~E<*1vCbdzbJA=3@t*mLvWkBa%9b9-R|KT*JV7!ovyv+e0Rb z>|?!S&A%mA8dI&*PxBUm$GUlnDLlNg`IE%<{sR&wKO9IbkU7ZdL7hvbxF?28`un5t zXD_X$caPjItttTNC9JG?Zd0*DbHQqn>Z*7 z$N92B?Q0 zIhiv?hw9v4wl*A}f#H|DJ|!PW+rm$?SYeGIT~2QOLuDR=pf3HBg>}0}vL3Y^c4v&R zWL1|NAvpm)pA4m;)<~ri*yT6s2(RtHT=jUd#a$D`x_{3usf2eDT6}SQ;MJ>DQ8@D+ z>j*h#>Ce^IVXB9}P#oM4_jN9u)7P68MOu!qVKlqn^TPQdq244G--|o{c zo|+Vzd~hZR{ZwXVBji^z`4+Q!6}LQxIrR}KE?@3OInbMS;Nre5ftK-PeEOdywWb@r z&HFx~=)dP>0F($W+-aB6%VXe?37=hB?2C!WkFI!ZarE0=wB9;vzjcpH9Z96+`~7PB z3oPq2@r88$L+Og@E|g`pytXpb({S z-ohXG`bB8f(8ASP(Ato-i@XyC*Plb!PR>lfO`=|a610~3(Qo{lPn~) zsN^ef7WaKlb}%Y@KW&sA?@^nG&Ut~{VRm-;$i)^hxS!d&+Um+GR|_mDVcRb_krY-p z^|FE2dcK<>BWz%kxUOJ6&fTkBU|Y}wsu~B3o(XLC{#{w;FKOaZq{Kb+Ng8FGiV0OS zgEe{(SI=ZPr+>?$G3w)_fUl8tpT0Dvm7BLMI03q?NL~jEzx>fP*Zr4*Ijihhl=(0* z8L1UK04a5&YfMiRr5LF80VxqZV!{p~?*1lbP7}^4V&@1r7_aj9DC`=oU~B5CuG4{q zKf@G~{bJ$A83~ER7N3L)Uih#Opx0I)UCxm#NswoP-SslN@qFOlqmL)3PRe|DNv-No z8@SoTo)qP~ZiL~$#yOwXoCx&1gy~-R1_HC^ZFiyIo~F2Y6>Ifd0N=48C*kp}T-y6p zU8_Cg=L?BD6b)BCaPPF{F&dGKbs^v$R4okS+kzb;G(xo7sXS~J@f@z39@(>$pCqJv z_B)cl!`}*5e_zdIS+MBbSK1~=c%+)H8CZ-P#Ys__-gGFdk2Z`={;7-_CMvMRske{K z-%jbA%e?oh%2mIt{yyN>wq&0^KHgCrzE+Wtp6d*PV5fS6r)mjl3Tg{SYk|=dA6~8*{VWAMp-37&M+{c7OVSL|_)8?>i~QBxJ6@~0-|+%w`Li$KpLG}}Vr;{x zLq}c&@^w~`HTV%g${}ppP&KV?UX!2ZqD>N=AN@0uL@du%KYr~L{8)m?t(n~1afS1C z!Hu|UCmTUmFU(q!Q-0$|i;^?>)Tdqd8>aEQ*7dS~|4jx+@E9B)BgK}026m>a7*xXD zUyvFJjKHIALE^dSsdXSNDj?dLHo88B&Bw*Zu5a#B>q#5;F&_$ryAmq^&QVYSx6Goc~m2jGw2HV)V zEpK1tu>n5lmUsV#F-`~KQZWB2hlJR^=OkjpngwSnVwbU`LH($Yrhk4`*cv~P)iZGU zP~`81lPE@%rD)@|l3*{oP~PH{2%;2l-Lf>gS4F&%d!*wq_deo~)Tm2;Plm zndl)^3Gb@J&%F?po9x4$nZKrea!Zyto%*tk6TqSoU?tm9YcA69R+}sYT)AQ?W?HEb z9`J?)Bif^$GwP?@Y&}nYOXv93;$*Btx41XGwCni;Jd)Y;bvw-%W7@56Y{CAaQrkXt zbRKUBdwHl1J#)8AHYC-4y;1W)PxI3{KzA4(VOw|a+fov|>(W^<$McwX_>79Co#=)M z0(_oMp~K4W#J~)$FHHSLT9EirLE+%Yw~oCwJ9_^s<&s$Vk<&#vNF+OT z-yxv$qY+aCULjm!g0`4-FcfSvNhzWuv+fI4?*(aokH2#A?ol0-i}Ead>YGsh z9yM#ZLXuHPh0x3ze|1HlQCMTwW40y)KzxkiAb{5?Kv8OkN9S8HPK_6hN0iZzC*tfHd~Q^C?}2QK)7BqaW)jnIi%b%zoFENsBEc}Y@X~_}S#kE# zQK^Y*yTFRi{KCt0`9j-|4o*sg$su+P28uH0;t4BNPs|PlHD0$VM68hAE%$j2_*(rJ zEHto*@*7OpW$$K@C2rAZIeZNTzqHPhZu!)l$jS*V0d;3jz$$DXz$$!VYutsiN}~x) z-{G|s4YV7ts-gWU2gPeNd=1j?=_Rj;f8Sqw0J4r$QX#Z!*fC^dWK}5atMDmEx|t*c zkF2flRy;-nbVsh534$1}QlJ|7;w=mIPE23gm;_?#z#0+Oul~m-NW3ZYu?b6Xs?^{$ zclWhx+_)>-NkFaoSx6LXK|K7WdkayNzgblQo6rwck9b-~)jpl|1y!S13{u6KtO^=X z4q5t-GGfzGgTvL4k0`&Cb`h{8|DcI%JABYQB5V`|Rw93=!Keu&mW~olG|R39QY1aj z?q@!#h$-Rj>vcb6B!X^o8zIf(6toN|^RW%v=cSQBM#NC9mFr!UnW9Hje0^`c-XZMihv4M`eWPf%s+?w!(xdyX;6a zTDnj>r@r?U5(;ec8dN-QyAy;xe7uNIL42VW%EzN{)n8TFC;tIXUDnH1IYSOoBWY z1lpVeKab1p1nnR`FR=9Rxb7P(OebNlYBc?fV)?}v?*kMGx^^F^i^CpP#;}5AUZ8Tn?5InbqdxKaKXi{%oW6rF;+ZL3=> zUUtGSMU_28HA4;RO`d7P4#t<&3GM0sL6x6K_s7#hC|)x0Na#0GYZnYA7?t)|1`)k0 zpDC@?20j^w?ra%Mq+=Cce^wQkx64G+qZ(-0HK7tFiciXy*c%n%@HQxW$Krze#7Rz> zoW92@JaZVkBP>tD;L!{cB7qqqs)ts*KMrt9O*oG@ptIg!BjHaB^NiEIRJkZAh{Vcj z_2EVl4w=cmMW1$oB)ojQV$65#R)_qKe49U?feXL7fmruiiB_t^LI^ZRp>m+NpQ2Py zH_sA&NH6LXKO`0L(4%Lh25|b0924!9+zx2V&Vx2-G3;Teorf{dJJ7Db0V&xz++%zgarF>@jMAa}B zSWG>F8v3O+W3WH!wR1kYpwueFM~lvPPh<)ickiHv#Z5oODriOGT`36(xpf<|E@($> z->J+v(6z6}HWbX``h)ed({#$sT2`Ce9PMk&E-!R+eA_fzJv<}CH?)N?PCad*A2M6!(^!%gx%B`0Z2IM? zf5#JHDs0$@AWOv>*f)fznTahN=(-r-rkG#64SvzkXk-BQYwFFxiHY;cDpm-o!=Ij|J;F z!Mai)ba@aa;TA)`&?dC|6p+jyLR*fw>1}Un1>*W13jgIjwSFa8{nrks_KHlE>{z#Q z))K7#RAbfcMfnl1!XUfxaOnDJz2JDo6SIG%I7)KG&FeZh$`^v6H?xZ&}pj!L&U4^Ut6sLuVzu;ex~a>;WbUwC+BOL}0KW z_Z$4b zz>1ZhaqG5iT~zD`eq#OvNhozYI>!l0S>1(E7D~3F!{Tr6XS~7B; zP5U!(}5pFjq4>H^Ze? zdPapF1^!pQ6_9%60%}7$xGS$Ioms4H8ki$2%8o)nUySJ7)gn33tDk%UUi93ymQ4{V z6r&p!qR^~|4)K}d>2`~~%KUrzH`ul9i>h7t`-1`gOJ|Ym^0I((5!Qdr2c-4JnG1m# zt_Ld2fM3HGR$ySo;0#7%SdX*idlgfWE~T@fd+Tr4GqZ z*YoX3XO9!x7?Ka>9QV|6g50Y`=m-_Rq%C9tTeU}Zf-~v+o@!-1%zC-HN)#!e7tNA| z&3a^t1`U%#rZuYG2r(qHO1J%tSc4|Xbkhb;#k5Q$ri+HjYN=ANx|@ITG}Ne4Lt8v8xnJo0a!5Kx@< zJ=SC+BcSA8K2~yhMpP_|d()8p$qap%q*4qp{xUps4Gdx)*K{lDdou%NIg xSWpryEMg!e0ud91h>7qD3PJ=0qv%Ye{}15C=3(dT5cK~O=g_s7qy=J+{{dDE*x>*G delta 3210 zcmajhc{~%2!@%*;(%hSzIkMsF)@&k2?)x6n+}AKgxogBw&RA~dR!St-R7B+{!#0*B zH|1VABXWH8d;Wc%*XwznzdnDx|NneJ4qV8N#ILZ33UVo%g$C9G0Gt~Z#s*Gzr#8xQ zkxpacWIZHQG2H;l&c`LKKf&sQN)lyDcWtN={K!q%_kKxfK@ZnCzX)%`zBF-LZ<$gU ztv8u*HI__@+176Z8bE^$fqX{hhUOsR`ry+3qpnQkAQdx*3D}I?iI4xw)pck7WK#ow zd$W_Wbt)mp&yj3cZU28o7;I(VBw?$Bny9N~fp*r1vlr5xO~bg0ax9gi6(&cVUpvZo zzKzS0E)3(+?j0-{2viMg_4sL(85kjyg9jfgr~F3iG6-B*jVGqIv<%CfWIsh zt64#rEu)9M11(s? zy!Hpy4kA0-<)czemG!sxmA{fyCdQXE6H+h?bB)WbNm0~shZYFL zr>`G9oTPCCsOrBK>**c(srzuJz4RAE$(wiMU4926cxeZ`$dq*}?2b@5)TJ~N(o~+F z$5l)L(oc+j#wA@_0!z7-bm!WpkMOO_^gLZhtH-Rx9?T8@f@**j-732As%J_^3NHE7 zI1UD_bL9?{JCCq6ZYlcCTb7Op=+UIjI+*L6tyFPma?Hx!*_MlAC??XHVVUK3-5j&Y zAA3e4oDf_WVMutACOc?LLIGBNDI zRj6E|H)DREkP&aj5qcIc;DFg|7K|q4J4Ix{{G!xZDj`ogt>M(+H#&ppUF*)d&&%<* z{4Tm(S!_va0%$OgxPc>6@(Z|UU=_EI6(STCq4AMzexvlIHxlQdc3`8%$n^4;nfTD4 zH#_y!X?|G`Da$j}G`RKl6@xu~&UFapdE-QI)`5q7MxdW73 zL-{c`+*~Lom2ov|%VRS=+173c$Wg<&`e>}VP;s__X)aCREfZ@CtEB8|=lnZrvO8XX zD9gw~4#o)C@QnY!wNvt@BN#qBFT7ky3I>3V2w zqS!c;mSNox|?&uB52T2+Q_dV{}&RQGd z7S~hy!3~I*iThL^(WNX~#kQ&;Mf}S)YR!2p@9;um6~5xr)ry-w>{+8S9GL~7ntAPV zk$LsJH%Q@^j@4wrv|qYXzyB7Cz9o1DKA2T;h*N^l?w94OICwV@4v63j)mvmjcfXC+ z5PERowpiGO=F-WzuX^8W@T1a+Cg{XFE=^CIv=7%|M0N~37s@3~IQ>Ykd`^!pim{NG zmS0u;7vHmWBx`+ZH3}xT!nXg1*^mr+oCZs|!j{tuY%TWAML&GgQTo>Y9ty7x11oWU zyR7^XnK$O?ES%*>YuLWR!6S#PGia{-&hjA~NIG#w`hMk;xn zz&UHEqCqOlNbu66b8*J&#Q>8*`#F4Vw?Tev_@6Q<(6+FYC+ohVxb-KaG=8V>CY7CL6zS*JgUpZ7UwcvrbZ7lCdTQC61K;^d%1hPqb!l8;QCmg-*eqdY*}VGqGn7O|fa{MfO94RO ztaW&tapHcE1j)a1GLe|PiQaFjemkARp&nHExPvCl8;0bZ<=CY*y z7Oooms946@J5cCl$K?4#>)<*oIc&93+|+iu7dc$C(TGd79gD`2??T=d+^IV^S`3@^ z*yXtDNHGxKjGDvYWzQwZ9a3He2x#@GPS0#!UU;5C17Ik__TIL9E?a1i$*I1R85t)j zET+-Dh=wz}w4y~`^}E_tT%F*d&re$ZI+khZCbE?#66_bt+mjI$Yz#nl=r=M}q^RMx#@6*AC2Qq^nRlbdAglAk41@^V1CG5t_%R$ zC}nTFcQId-WKAreXDSr+`T&!nOxg9|T9mc`DX+jT?3J4k(2sVLXaTCeR=V?Xeey2rujOo;5Xh306|lN!6zh`^9_t z5u~ENLgNioLd3pV^vkuB6U|jwdptixB!ASD!Ec?MffpAA>Dv#$kX^#kYG|CN)ycM^ zUK2d6fKbegR{o1o)5tO79Mkdce@X3;bc~f*w*An{wm|HwZG&RTgeqE{P(`=9V6MOk zyAyKVy)|6ch(-H_JOfp)cVC327Jwk0c857T_MB1SWmtMl9>*k#Jg6AB2iV6#J?HT0 zzDjw*1{^^(*=z0BcX8R`-NFc+{-0+di<}|LJSnV6mvv`G1fONwz|L4m6RQalpPV;W z!C*5s<*8>}$((s@Cydm0{{YXWd2?M4Q+B~*(@6X`&e#7wnQjq?QsL&uqGCB@8%|7q zDxTD(B2!y3!b^gx3oUQ7FwEt>wpsBcair90b9%sL4hr%_L!9V(?EdMT=LiWQBDca% zo-`AoeL-2s`+w1THQ*@Rk2sa-bm;FJvfPNDn=q>GJh@9nhJsqv<|W0Kj{qq?#`nQAFv+;ZA z^i^GT`$eqW4Rl{5+2}|?0pA=(4AzK!)TKSudv_(<0Jf@Hd<7WA-;%{U@twc#ugLA@ ze5YR+&M~(o_Bhoh1W%6(fpj0np*aAtjbe7a+U0W;QFePaC$;5srNnx;HYJW9WmQ^) z%o8zA%+$pEe@`uk{~zC-p}&nkH``989}64<005at6LciTC(>WbFWmpX0zkkK2xYjc uGD5=%fzVP#XsKORgu}Jqa9g_Y+??~dx3hNVCbY>AhH#?8zHI2>A?cRDBRhRh8TvjY- z`Sx{1qs_dj)8jj|0_7WAJCw?ECZ@Jp`7-@@*=yesu<>cttf)(!VX4PtLl=o1m~igO zYANm+@_awkTqme-8nt}*e5(F%N={ABi)ydxC7hStb1p65zL1`A@!1TaW;tf2J(m}` ziA%HHnXo+fSXjEH&(bpA`D*@qR@{}C7d&U)v({A6Lu)6ju|NDv{hj{1%*Nx1Wmj%6 zFfgc=xJHzuB$lLFB^RXvDF!10BNJT%3tc1Q5JO`tQxhvwb8Q0yD+7bVFymSc6dk$w TDVb@NxOFgaADuFJD`P$YZ4|t3 delta 334 zcmbQtx`bsyN&PcMX)zuXW$E)-3=9k>JzX3_G|n%*xY5grQRLXi`=O^_ut}A2Uh=%2 zvF$4R1FRbL|Pns^Z?b-EE-S5BDggTF0=uLhoGO_qcz1OvczLp!7t;$^D z+)z7lUg^YL!lnAVl4>`;&Ofj&iA&q6e3`-gM|UmWGRw<7we@G8*=nL%S-!~RUz6hE zN7vezr>3?AoSkQW`_{a)GxwjD?~(Ed`*;5T7uNL&nx{Ydt(^$;m1>D=L`h0wNvc(H zQ7VvPFfuSQ(ls#DH8KxzHZrm@G_o=^(l#)#GB9wzt9A}WM{a&fW?Ch(4pa?h4fBd7 It1#sQ0A=QlNdN!< diff --git a/pkgdown/favicon/favicon-32x32.png b/pkgdown/favicon/favicon-32x32.png index 56ef9a6ed704ff38e41983e488eef78cea12be10..f747233762f400d91ef0bb115b54079a2cafb89a 100644 GIT binary patch delta 906 zcmV;519kj`2F3`Gbbsgw7Y#N$`?CD10008(Nkl6b10#Oky6B=cIW* zOqB>xYpo9`6w{3s)M}*=cik1mm38N;SP&6hh`O>^p&MOhAud9(0R_Q;R*e;rRKc3q zgeDD{WRm7J*TpnVCNEQa?(YBp&bjwH_q$xSN0Fyo@Rh@g{C^L0ddH{`{_(E8cSf%D zs$b;9t;qS+Ytp+Tmw46%i?_+EvFM`bmF`SV*zZ%*o5-t?aoz#R?dYveyPAr&sECRv zjiL}$(H>pV77s>UbVNhchY@GAug{rBmE%r1Ald0*%chl>^P`8fn~{*ws7cPS@5veR zp+1>>t4QeazJE7#NYJ3hvT`|TS!o&dN-X1s>#`hJ7nj>E=me+e$Dw!83!2Lec z?Tn9{bWDSB-|07Keuw5&`gX0b-pEEof1Hn%SVboK;(usVZfxqH>P-TB;#|BLBQY6s zQHX5x$MH!0m%xeWjhYyUtuY^GqiTadfd?(Z7Z$zlh;A=vEx74TIX%*53ceNyJm8W= zTy|N~$6j*Old=X~@rR$xC^fm0iHD+kgHeyg5Ak_)Z#@~CuP|t3gZ7BCE_u=Lra!AF zn5@l*%75exSoiN2bJ5m?U~}Oi79oObvS0&VYOcNo405UK#G%YYVEiyAyF*7ppnGBhnPI4v?WR53F;H8eUkIV&(QIxsL$ gG``6I0038dR9JLUVRs;Ka&Km7Y-J#Hd6TRHS>CR_00000 delta 561 zcmX@c(aJWVr2ZMBv>1=sS^A?v+yy*BZpuJM; z;DjrOHqB*q3ushH(W_<5?I{!7^4`{E^9nJ?+{0#VoT4`to#@S+CZd!g;$rr==hEdQ zlhT@J{#!F2zSq&4UR)P{ZtwHBvM=Ym@@~4$DZJ_!T-1?S?6A0gPtDdHQz9Ef55Fio zJ;n9&vAYFco1_l7YBM!jpPMb5)Aimh=0dih zr>tpXU}~I`-gc<}^1E%qJHig_5b7aosnmP+ZZe%frAUn?~E!{JNU zw*8Xj%r$>E&o$Y~`|h7Ac27&~g`(jpXDy%a@`>1$mK&>;_$DxO6{#`>6m|;TY2F(x8_%SMZP{ z{Alz;_HX$w*1$~@SM;|z_cJgssFt`!l%yn*kaq9>TSnV6 zcI~5)VvSNK*V!OJODKPm2AD6osYT);v3?7@*ME z@`ow8l#?nf<4U&Na2TI?*edU>Fo{{$L+soZ|-z{a!mX*AD^QJd8w6#ys zQ&CV6@1k1S*G#cOaYbS1rna;X88SrPe*0~iGG&U49XnRIhoAoa`%CZMy`^i{u3pCG zsvuM$x^3X#M$%F|L3{78u z{k81dw@-HM+GS{m2LL}{`}Xa^J9cc~mvNaiX_EBn)hj*uJ88JAG%Z&&RD>$57k+ns z6Y{!X!GiMe!w<{w;ls^5hpz9x|6Wd>JSj(y9+hLqj>&i5eJ8tj?+)-_d0}j}Y}sPQ zjJ4rG{%#sr-=X$B_R-Z|=r2~Rn6zorMkY?2C<_)WFtTKheE#|8vTfToxp3iv{P4pM zvS-hpz?`z<0sU*&t~KNK#v5-$BY(>Wdv_j%yLhIb`P!~sI~hE9u)O%z zqD2dN;)y4uPoF+U$D`}f`7gixvb^`+dvfsLL9=cbEm|ZWfBdm5U%uR|@dF1A$l=3> z<(+rlkuF`jNY0!&z0mA@CuaI};LKi{FJC?>U%tH5uU}s}bm$<@KKrcn>(|flgZ^B# zYL(Idc5LR&n`iXui4!Nx*rCU0D@w$Les`bPI;@N8)vHVM=FQDMh29xAZk(|x(6#Ji zj0ev$Aa~1WrqJ)?2OE?*J$dqES+Qb;v5l~Ym}87f#flXzEg7jZoqo&90}nhPUwrX} z85g_fp|i4Q&z=#w?KfFQKl>auot@{ezWS%eB`yBMcN9D?ujsC$m$ROSJ zyQt|eUc9&zDpbgR@3}5fqJ**OTDEK{ue|b#JpcUj>G=R&+l`uj_FD8~v~oiaoj-qG z&Ye4F_A$mG+BQPGA2t0oYt}S-Wr((d=wZ$@ZQ9hx8ym=$ix)4-%9SgP&4%6Fx^-(~ zx8=!`$M~7->5Q`ny&5(B=)%#XN6YQE-yTFSJmI$&C{RG!wry+X%P+tDV#y9!r=+CF z)vH&9eGD5Le*wD*TN__9f}EnJpZ2W1>5MN_s8B(YlapoHvSk6gEhNDnA7WeFamO8* zLO=4wC$#H;amKHTXTg4D4rPY?X%jty9godes#GaCa^y%{$j5IOKYqO63rC=x-!n9S zXqSBxpNVnCA3t;EjG-S}^VeU0jfxl6z>h!vXnbPyLlk>*hUtfgq@*O{o7}i@L!g1e zyu!crQf}V7X?y`}xGGhuL_@b7o0#ZF7vVoS3uA&EjlXj3+BN4-f$J+*t{9(Y)TmLC zn3x#LJ{A-Gi~(~8{YN=__N?(`c#iIW`st_5Sm4Vuukf|7+0d={J-inqVx}Lz1v>E? zAAImZqyL>Wu^(WwK`;B0^S3x$$4q}5Xo!WUaP)hMpEzZUuZ5hMH^iH^j!NJ@?!rb?eqOeDW^#YC2;ZDSie0lyu{V z$dg$4qmMpn^xxx;KW=z|rXD?d7+)S61G(}JHWM+br=EIB8a8Zbc-KDUvBw@WJn%j7 zX?`zRvScXwqlq6H2K;|Q#&4My_uhN2bnDhlkhPT|bBS@e>#n;D4a^VZ4i7wM-Y~z2 zqjOE{g%}Jz{eAb{XYADw^3O>8*2zOq{2aQl+n|$qk1Uzn=p^KB?K|c&vM*DnjIleI zJJ=lPD{?fYOP4m^)vH&}tP5-s+Mqo}JmTk0KEmcN{QcQ}W3A(zzi{%vb;$ft9C*m= z{E?fFp!{77JY;45&dEnm{xnJ+Z2pvE4q2T)b@Fkm=C7SRaDA(uA8_+=tDfI*^1*!0 zlJhenDaoQ*TjXkDYJH(_YP~5TwdOa4o*qf2Rt=p=@~ zrm?u8<5D_R-pkzbe=hO`qg@$WLOOzzj!zip4U|E6fJpif)!>BUBceJ@ZGe{0mJkvUUAJev5+p+kpEjE=Jv z_Dlu&`%RlRnX%#Q1pZ*C_WaMbXpPNm3)kBfLEq3neiY+OZvFlD-#58Na@C9jadL9< z(8T@JsZ)&)86mH;Q~Pp`L%RJFyCz19Z%B>--;Of@oX;Re$QcLXQTzArH*|)Py^}Z3 z{acx^&dFuqxfl0)VeVt@ zpLXFDJ;Yjn;e{8xilwZ*sTEdZb_G9eRjDjGwiK?jerMJh=b<`^|ZWFlWFb_Kyzl-o1N3 zkJqYIONI>_X8JgN`n2gc+#h1vmo8m0=UKw!<|6hF-|Q*Gb=ccBZrm8IyO7VJ0eRS1 zj7yH5`X}dvo?&gBI(15Z{`qIQeED+7{_I2eCJ#Uy%@Mb8kE5slp&9;ZlR~?k>mt|T zF63d^AIK*XOLOt-zW3Zex|cIn6mpW}s?opp>=k>S z+m7|j{zp8T7$I?6VvFcK>@8x<*j~hO*$dEJ{1!rggtI@COjCmFFLF}!2MxA;VzcNW zbOQZiA7O`L7jxDey+Pa<8njgq$^J_1{kOjX`x6<%D|!qdQ>*7$+vL}f5%0h+b`Sd! zdxPH&h{pc>je=DBERFrGKU#jg)Unv#PCC-~A0B9km;d3Uf$QJP|8mojs1JS*|I>8DWRx>OXE$zdjbw25r%%PTJHy=!-rzR6(4AflX2b;uK^B zycOioRIx#U|I%FHH4c%aI%Kl0)1O$!=o9_+C&d&+MMb!RZ;y|ENY{JHm@#9FKg|As zE>vBdqWa;m{{Cl$GY*hl@7pM#^*XwmbL#kS*iM|o#gF7HrQhyj9l;a6KRl7Q+M_UQ zpIj6F(}54dxnz7n&Xuw^x@@j}`b|j%|0{67e$PATPx6e`uVQaUx7v67^+B!43#9qp z`40c5fW1LJ%r8f08+>2devj_7`>1UL{mD5x`etvn&;50p?`fYL7xa?@B^H4Xij9Ij ziVuuj9sXyU?`e~>9{3HMBjdb>vv6jH|C4dp5<%ZXBeKUPeCw^ZjPJ=gEqqk$6&DYD zkNnb%ANv~n6?tE-i80vy#Syze7Iyps^GDmie&?Nc8XFs1obR!>@srsLnTIN;8~Uwt z{^+eK%*jDI=MQOrDf9&x6F*Y4KCFGX=db_sK$WCd#N1djcFer2AALPgJg?uBWDSfY YYW!DYznk={@oKT82j1abzTw;d18}nQa{vGU literal 15086 zcmeI2d2AF_9LJ{?DVI>PO!Ac_8C zga#u>z(4Q+L?Mi+C5hEYX^q2!^6Q2|P~RFnw9 zzo7?04}=~FJrH^z^gyTfz;RfA29!V_$N}jD=xW8X`;Y7$1J$q<9)JsBA)Eqw2IrZG zW~FkmY8Z@yneYzmhj}mqdO~NCwvAuFTyXop8`s)a4gz+Y)_YN?zLsseAA{BayWvL3 z&THXOcmo!}#c(}jo8;r2pt0eW#`^%60*}KMSPp|>G^j6Ti{@j9-a&KokkU7U`dTHN z3)!TB7_$p5YsM(`{oSDc)T5a^9i4nH25bY_>XrJ|t8lXSMiyNU!Iph+dlH)-CQWl} zHmf_v$;WR(p3Bgah`$UYTxr=FEypm;MZH`GmJweE?q_n{&Z?;9l?|YGAt{vaH9vI* zX>YL!oON~*@dKc>t21aMM!pZ4PqiLvO;`_^nlrUu)STT9(xEG;`!M> z-zuMV%5Kf)+LwI-N5HW;S*Z7+JU_vQuo>=xOW`884sHUaIb)w_O42x631uzhmc8BJ zL?{OBnZJi*wx*gEr~Fa)3-o*{r?sy)_|;?zYy_>9Ug@1b2|M6p(0tecsoLo$pX?t5 zex%;vUaFzyn;NKqevk=i{C@*pn|>foYef~vf8P5o zUCZw6a5V%SpA=0=J;_xAUVAk>r*Yc3_d^Uh9K~06~^ODLvwNB zz8SH@v39uA4&U;Gui4kz6w*qc#C1GZVa%*G3al_{t-f*X&Lf5qUzi9@h1@qsv!E$_ zn#EUP%@Sjr9a{C(M6LSFXl;RY{U?v3`<8--LutMc#zW)(Y2|YfD)d0;fgm2xzSOSwznYKyKy$VKv)C0;u z=jhWx=bT+2lbS;1^TFu{vY`|fz&e-=$<7!_PK)$yy$sZ*TRP{}cXSD4`aMjgji~5@-+UjNx@S-)>CTi$UMS?IraAjRQ%2@D3~1et&d!Hvx`^YS7#eR2o;R$B!z> ztY_AE&>4xwK~P;z!Lxl7R=;}*eucL|XJ&1Y=8b8sRG{%b5OiL>1`Yu`HtRRAZG=_e z_+v0}`J*@V2l=-pX}*v@z5Q2fkLLdZxCi!t_smK*IK+wT98hPAyFkB_egvtE%UR@e z&a{adn)9Cpm5+ko^GL_0gOpVtX-)FeT5$UDgT$RWf`)a}u@O#(R8&r;cR}ZVt3mDR zH_iq-o~j+k$iEwALTm4yERE9I^&ISj{h;=Cz-M;6wf1G}PEfn*Q$chUh1`AY1+J&V zchFq>hq<>E(s71cLOptZwbcOX_mbYp^YA5T+#dk-@ue^U{P>yd%_@gG>aTha8j~7- zj`V)iPlrJfq^nJ;3Ke>w{XCF3XK3MXjC;c51SAe-#D>5;Xj8zwJkzY>NMwmoP!BOq zLmG@6GoGJk#z%8MVkVW&De|EZ8qX;-y8a&;z+>tgMr*9*8^6-;Z)0E<U%uM{M?q`tE3h0i=a+$7>Y3A^03r|t?JcxMdC}Uhy^B{vNLUGb;YVPoG%0(8 z>+Nt2==~;>$}8V&SPfD58rFl}Lu>2NK=SCF_W=1p&m-St?Z``ue|v> NdVZAfz__OQ{spA-X955K diff --git a/vignettes/Get_started.Rmd b/vignettes/Get_started.Rmd deleted file mode 100644 index e76d1046..00000000 --- a/vignettes/Get_started.Rmd +++ /dev/null @@ -1,19 +0,0 @@ ---- -title: "Get started" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Get started} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- - -```{r, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>" -) -``` - -```{r setup, eval = FALSE} -library(ibis.iSDM) -``` From 94c8ba2f8caa2ca931aa0492537c8636c86228ec Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Sun, 25 Aug 2024 12:09:01 +0200 Subject: [PATCH 09/21] Test and documentation fixes. kmeans addition to `predictor_derivate()` --- NEWS.md | 2 +- R/add_predictors.R | 11 ++-- R/engine_glm.R | 6 +++ R/threshold.R | 12 ++--- R/utils-predictors.R | 95 +++++++++++++++++++++++++++++---- R/utils-spatial.R | 14 +++-- man/add_predictors.Rd | 1 + man/engine_glm.Rd | 1 + man/get_rastervalue.Rd | 14 +++-- man/predictor_derivate.Rd | 12 +++-- man/predictor_transform.Rd | 12 +++-- man/threshold.Rd | 2 + tests/testthat/test_Scenarios.R | 2 +- tests/testthat/test_functions.R | 4 ++ 14 files changed, 147 insertions(+), 41 deletions(-) diff --git a/NEWS.md b/NEWS.md index 92aa5329..5a64614f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,7 +3,7 @@ #### New features * Support for 'modal' value calculations in `ensemble()`. * Support for 'superlearner' in `ensemble()`. -* Support for 'kmeans' derived threshold calculation in `threshold()` +* Support for 'kmeans' derived threshold calculation in `threshold()` and `predictor_derivate()`. * Support for future processing streamlined. See FAQ section for instructions #18. #### Minor improvements and bug fixes diff --git a/R/add_predictors.R b/R/add_predictors.R index 43f020c2..b70c9afc 100644 --- a/R/add_predictors.R +++ b/R/add_predictors.R @@ -60,6 +60,7 @@ NULL #' * \code{'interaction'} - Add interacting predictors. Interactions need to be specified (\code{"int_variables"})! #' * \code{'thresh'} - Add threshold derivate predictors. #' * \code{'hinge'} - Add hinge derivate predictors. +#' * \code{'kmeans'} - Add k-means derived factors. #' * \code{'bin'} - Add predictors binned by their percentiles. #' #' @note @@ -130,7 +131,7 @@ methods::setMethod( assertthat::assert_that(inherits(x, "BiodiversityDistribution"), is.Raster(env), all(transform == 'none') || all( transform %in% c('pca', 'scale', 'norm', 'windsor') ), - all(derivates == 'none') || all( derivates %in% c('thresh', 'hinge', 'quadratic', 'bin', 'interaction') ), + all(derivates == 'none') || all( derivates %in% c('thresh', 'hinge', 'quadratic', 'bin', 'kmeans', 'interaction') ), is.vector(derivate_knots) || is.numeric(derivate_knots), is.null(names) || assertthat::is.scalar(names) || is.vector(names), is.logical(explode_factors), @@ -753,7 +754,7 @@ methods::setMethod( # names = names = NULL; transform = 'none'; derivates = 'none'; derivate_knots = 4; int_variables = NULL;harmonize_na = FALSE; state = NULL # Try and match transform and derivatives arguments transform <- match.arg(transform, c('none','pca', 'scale', 'norm', 'windsor', 'percentile'), several.ok = FALSE) # Several ok set to FALSE as states are not working otherwise - derivates <- match.arg(derivates, c('none','thresh', 'hinge', 'quadratic', 'bin', 'interaction'), several.ok = TRUE) + derivates <- match.arg(derivates, c('none','thresh', 'hinge', 'quadratic', 'bin', 'kmeans', 'interaction'), several.ok = TRUE) assertthat::validate_that(inherits(env,'stars'), msg = 'Projection rasters need to be stars stack!') assertthat::assert_that(inherits(x, "BiodiversityScenario"), @@ -767,8 +768,8 @@ methods::setMethod( assertthat::validate_that(length(env) >= 1) # Get model object - obj <- x$get_model() - assertthat::assert_that(!(is.null(obj) || is.Waiver(obj)), + obj <- x$get_model(copy = TRUE) + assertthat::assert_that(!(isFALSE(obj) || is.Waiver(obj)), msg = "No model object found in scenario?") model <- obj$model @@ -856,7 +857,7 @@ methods::setMethod( # Get variable names varn <- obj$get_coefficients()[,1] # Are there any derivates present in the coefficients? - if(any( length( grep("hinge_|bin_|quadratic_|thresh_|interaction_", varn ) ) > 0 )){ + if(any( length( grep("hinge_|bin_|kmeans_|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))){ diff --git a/R/engine_glm.R b/R/engine_glm.R index 1e6a8912..bcb163eb 100644 --- a/R/engine_glm.R +++ b/R/engine_glm.R @@ -28,6 +28,11 @@ NULL #' This engine is essentially a wrapper for [stats::glm.fit()], however with customized #' settings to support offsets and weights. #' +#' If \code{"optim_hyperparam"} is set to \code{TRUE} in [`train()`], then a AIC +#' based step-wise (backwards) model selection is performed. +#' Generally however [`engine_glmnet`] should be the preferred package for models +#' with more than \code{>3} covariates. +#' #' @returns An [Engine]. #' #' @references @@ -43,6 +48,7 @@ NULL #' #' # Add GLM as an engine #' x <- distribution(background) |> engine_glm() +#' print(x) #' #' @name engine_glm NULL diff --git a/R/threshold.R b/R/threshold.R index 776661da..2a05ef2e 100644 --- a/R/threshold.R +++ b/R/threshold.R @@ -334,13 +334,13 @@ methods::setMethod( } else if(method == 'kmeans') { # K-means based clustering. Presence and absences are identified through # by getting the value within regular sampled values - val <- terra::spatSample(raster_thresh, size = 1e6, method = "regular", + ex <- terra::spatSample(raster_thresh, size = 1e6, method = "regular", na.rm = TRUE, exhaustive = TRUE) - val <- subset(val, complete.cases(val)) - if(nrow(val)<5) stop("Not enough values for clustering found...") - clus <- stats::kmeans(val, centers = 2) - tr <- clus$centers[which.min(clus$centers[,1])] - rm(clus, val) + ex <- subset(ex, complete.cases(ex)) + if(nrow(ex)<5) stop("Not enough values for clustering found...") + clus <- stats::kmeans(ex, centers = 2) + tr <- clus$centers[which.max(clus$centers[,1])] + rm(clus, ex) } else { # Optimized threshold statistics using the modEvA package # FIXME: Could think of porting these functions but too much effort for diff --git a/R/utils-predictors.R b/R/utils-predictors.R index a350ef12..9e7bce3d 100644 --- a/R/utils-predictors.R +++ b/R/utils-predictors.R @@ -51,10 +51,14 @@ #' @keywords utils #' #' @examples -#' \dontrun{ -#' # Where x is a SpatRaster -#' new_x <- predictor_transform(x, option = 'scale') -#' } +#' # Dummy raster +#' r_ori <- terra::rast(nrows = 10, ncols = 10, res = 0.05, xmin = -1.5, xmax = 1.5, ymin = -1.5, ymax = 1.5, vals = rnorm(3600,mean = .01,sd = .1)) +#' +#' # Normalize +#' r_norm <- predictor_transform(r_ori, option = 'norm') +#' new <- c(r_ori, r_norm) +#' names(new) <- c("original scale", "normalized units") +#' terra::plot(new) #' #' @export predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var = 0.8, state = NULL, method = NULL, ...){ @@ -351,6 +355,8 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var #' * \code{'bin'} - Creates a factor representation of a covariates by cutting the #' range of covariates by their percentiles. The number of percentile cuts and thus #' new derivates is specified via the parameter \code{'nknots'} (Default: \code{4}). +#' * \code{'kmeans'} Creates a factor representation of a covariates through a +#' [`kmeans()`] clustering. The number of clusters are specified via the parameter \code{'nknots'}. #' #' @return Returns the derived adjusted [`SpatRaster`] objects of identical resolution. #' @@ -358,13 +364,16 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var #' @keywords utils #' #' @examples -#' \dontrun{ -#' # Create a hinge transformation of one or multiple SpatRaster. -#' predictor_derivate(covs, option = "hinge", knots = 4) -#' } +#' # Dummy raster +#' r_ori <- terra::rast(nrows = 10, ncols = 10, res = 0.05, xmin = -1.5, xmax = 1.5, ymin = -1.5, ymax = 1.5, vals = rpois(3600, 10)) +#' +#' # Create a hinge transformation with 4 knots of one or multiple SpatRaster. +#' new <- predictor_derivate(r_ori, option = "hinge", knots = 4) +#' terra::plot(new) #' #' @export -predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, int_variables = NULL, method = NULL, ...){ +predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, + int_variables = NULL, method = NULL, ...){ assertthat::assert_that( is.Raster(env) || inherits(env, "stars"), !missing(env), @@ -382,7 +391,7 @@ predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, int_variab base::length(option) == 1 ) # Match argument. - option <- match.arg(option, c('none','quadratic', 'hinge', + option <- match.arg(option, c('none','quadratic', 'hinge', 'kmeans', 'thresh', 'bin', 'interaction'), several.ok = FALSE) @@ -600,6 +609,72 @@ predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, int_variab } } + # For k-means thresholding + if(option == 'kmeans'){ + if(is.Raster(env)){ + new_env <- terra::rast() + for(val in names(env)){ + # Also get the cut_off values + ex <- terra::values(env[[val]]) |> (\(.) subset(., stats::complete.cases(.)))() + if(!is.null(cutoffs)) k <- cutoffs else k <- nknots + cu <- stats::kmeans(ex,centers = k) + assertthat::assert_that(inherits(cu, "kmeans"), + msg = "K-means clustering failed...") + suppressWarnings( o <- terra::k_means(env[[val]], centers = cu$centers[,1]) ) + if(is.null(o)) next() + # Factorize and explode + o <- explode_factorized_raster( terra::as.factor(o), + name = paste0('kmeans_', val)) + for(i in 1:terra::nlyr(o)){ + names(o[[i]]) <- paste0('kmeans_',val,'_',round(cu$centers[i], 3)) + attr(o[[i]], "deriv.kmeans") <- cu$centers[i] + } + new_env <- c(new_env, o) + rm(o) + } + } else { + # For stats layers + for(val in names(env_list)){ + # FIXME: To be implemented once there is a need... + stop("KMeans for stars to be implemented...") + # Format cutoffs + cu <- cutoffs[which(cutoffs$deriv == val), 3] + cu <- strsplit(cu, "_") |> unlist() + # Remove any leading points + if(any(substr(cu,1, 1)==".")){ + cu[which(substr(cu,1, 1)==".")] <- gsub("^.","",cu[which(substr(cu,1, 1)==".")]) + } + suppressWarnings( cu <- as.numeric(cu) ) + nn <- terra::rast() + # If NA, set + if(is.na(cu[1]) || is.na(cu[2])){ + # Use the default knots for cutting and get knots + o <- makeBin(env_list[[val]][[1]], n = val, nknots = nknots, cutoffs = NULL) + suppressWarnings( cu <- strsplit(names(o), "_") |> + unlist() |> + as.numeric()) + cu <- subset(cu, stats::complete.cases(cu)) + cu <- matrix(cu,ncol=2,byrow = TRUE) # Convert to pmin and pmax + cu <- cbind(cu, 1:nrow(cu)) + } + for(k in 1:terra::nlyr(env_list[[val]])){ + newcu <- cu + # Set smallest and largest value to global minimum/maximum to account for rounding issues + newcu[1] <- terra::global(env_list[[val]][[k]], "min",na.rm=T)[,1] + newcu[nrow(newcu)*2] <- terra::global(env_list[[val]][[k]], "max",na.rm=T)[,1] + + o <- terra::classify(env_list[[val]][[k]], newcu, include.lowest=TRUE) + terra::time(o) <- terra::time( env_list[[val]][[k]] ) + names(o) <- paste0(val, "_",nrow(newcu)) + suppressWarnings( nn <- append(nn, o) ) + rm(o, newcu) + } + new_env[[val]] <- nn + } + invisible(gc()) + } + } + # Create interaction variables if(option == 'interaction'){ # Check whether interaction is provided or an attribute diff --git a/R/utils-spatial.R b/R/utils-spatial.R index 15091a53..a7c9c29b 100644 --- a/R/utils-spatial.R +++ b/R/utils-spatial.R @@ -1044,11 +1044,11 @@ get_ngbvalue <- function(coords, env, longlat = TRUE, field_space = c('x','y'), return(out) } -#' Function to extract directly the raster value of provided points +#' Function to extract point values directly from a SpatRaster #' #' @description This function simply extracts the values from a provided #' [`SpatRaster`], [`SpatRasterDataset`] or [`SpatRasterCollection`] object. For -#' points where or NA values were extracted a small buffer is applied to try and +#' points where or \code{NA} values were extracted a small buffer is applied to try and #' obtain the remaining values. #' #' @param coords A [`data.frame`], [`matrix`] or [`sf`] object. @@ -1066,10 +1066,14 @@ get_ngbvalue <- function(coords, env, longlat = TRUE, field_space = c('x','y'), #' @keywords utils #' #' @examples -#' \dontrun{ +#' # Dummy raster: +#' r <- terra::rast(nrows = 10, ncols = 10, res = 0.05, xmin = -1.5, xmax = 1.5, ymin = -1.5, ymax = 1.5, vals = rnorm(3600,mean = .5,sd = .1)) +#' # (dummy points) +#' pp <- terra::spatSample(r,20,as.points = TRUE) |> sf::st_as_sf() +#' #' # Extract values -#' vals <- get_rastervalue(coords, env) -#' } +#' vals <- get_rastervalue(pp, r) +#' head(vals) #' #' @export get_rastervalue <- function(coords, env, ngb_fill = TRUE, rm.na = FALSE){ diff --git a/man/add_predictors.Rd b/man/add_predictors.Rd index 40498c8a..8bd0bbc7 100644 --- a/man/add_predictors.Rd +++ b/man/add_predictors.Rd @@ -179,6 +179,7 @@ Available options for creating derivates are: \item \code{'interaction'} - Add interacting predictors. Interactions need to be specified (\code{"int_variables"})! \item \code{'thresh'} - Add threshold derivate predictors. \item \code{'hinge'} - Add hinge derivate predictors. +\item \code{'kmeans'} - Add k-means derived factors. \item \code{'bin'} - Add predictors binned by their percentiles. } } diff --git a/man/engine_glm.Rd b/man/engine_glm.Rd index fbef789d..8f0c4700 100644 --- a/man/engine_glm.Rd +++ b/man/engine_glm.Rd @@ -45,6 +45,7 @@ package='ibis.iSDM',mustWork = TRUE)) # Add GLM as an engine x <- distribution(background) |> engine_glm() +print(x) } \references{ diff --git a/man/get_rastervalue.Rd b/man/get_rastervalue.Rd index cc7a0e1f..052c40dd 100644 --- a/man/get_rastervalue.Rd +++ b/man/get_rastervalue.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils-spatial.R \name{get_rastervalue} \alias{get_rastervalue} -\title{Function to extract directly the raster value of provided points} +\title{Function to extract point values directly from a SpatRaster} \usage{ get_rastervalue(coords, env, ngb_fill = TRUE, rm.na = FALSE) } @@ -24,17 +24,21 @@ data point. \description{ This function simply extracts the values from a provided \code{\link{SpatRaster}}, \code{\link{SpatRasterDataset}} or \code{\link{SpatRasterCollection}} object. For -points where or NA values were extracted a small buffer is applied to try and +points where or \code{NA} values were extracted a small buffer is applied to try and obtain the remaining values. } \details{ It is essentially a wrapper for \code{\link[terra:extract]{terra::extract}}. } \examples{ -\dontrun{ +# Dummy raster: +r <- terra::rast(nrows = 10, ncols = 10, res = 0.05, xmin = -1.5, xmax = 1.5, ymin = -1.5, ymax = 1.5, vals = rnorm(3600,mean = .5,sd = .1)) +# (dummy points) +pp <- terra::spatSample(r,20,as.points = TRUE) |> sf::st_as_sf() + # Extract values -vals <- get_rastervalue(coords, env) -} +vals <- get_rastervalue(pp, r) +head(vals) } \keyword{utils} diff --git a/man/predictor_derivate.Rd b/man/predictor_derivate.Rd index d172db3e..a96f45e3 100644 --- a/man/predictor_derivate.Rd +++ b/man/predictor_derivate.Rd @@ -61,13 +61,17 @@ The number of thresholds and thus new derivates is specified via the parameter \item \code{'bin'} - Creates a factor representation of a covariates by cutting the range of covariates by their percentiles. The number of percentile cuts and thus new derivates is specified via the parameter \code{'nknots'} (Default: \code{4}). +\item \code{'kmeans'} Creates a factor representation of a covariates through a +\code{\link[=kmeans]{kmeans()}} clustering. The number of clusters are specified via the parameter \code{'nknots'}. } } \examples{ -\dontrun{ -# Create a hinge transformation of one or multiple SpatRaster. -predictor_derivate(covs, option = "hinge", knots = 4) -} +# Dummy raster + r_ori <- terra::rast(nrows = 10, ncols = 10, res = 0.05, xmin = -1.5, xmax = 1.5, ymin = -1.5, ymax = 1.5, vals = rpois(3600, 10)) + +# Create a hinge transformation with 4 knots of one or multiple SpatRaster. +new <- predictor_derivate(r_ori, option = "hinge", knots = 4) +terra::plot(new) } \seealso{ diff --git a/man/predictor_transform.Rd b/man/predictor_transform.Rd index f8287dc6..33eb27ca 100644 --- a/man/predictor_transform.Rd +++ b/man/predictor_transform.Rd @@ -75,10 +75,14 @@ statistical moments on which the models were trained for any variable transforma also to ensure that variable ranges are consistent among relative values. } \examples{ -\dontrun{ -# Where x is a SpatRaster -new_x <- predictor_transform(x, option = 'scale') -} +# Dummy raster +r_ori <- terra::rast(nrows = 10, ncols = 10, res = 0.05, xmin = -1.5, xmax = 1.5, ymin = -1.5, ymax = 1.5, vals = rnorm(3600,mean = .01,sd = .1)) + +# Normalize +r_norm <- predictor_transform(r_ori, option = 'norm') +new <- c(r_ori, r_norm) +names(new) <- c("original scale", "normalized units") +terra::plot(new) } \seealso{ diff --git a/man/threshold.Rd b/man/threshold.Rd index 9aae1ce0..745ee5eb 100644 --- a/man/threshold.Rd +++ b/man/threshold.Rd @@ -127,6 +127,8 @@ Requires the \code{"modEvA"} package to be installed. Requires the \code{"modEvA"} package to be installed. \item \code{'AUC'} = Determines the optimal AUC of presence records. Requires the \code{"modEvA"} package to be installed. +\item \code{'kmeans'} = Determines a threshold based on a 2 cluster k-means clustering. +The presence class is assumed to be the cluster with the larger mean. } } \examples{ diff --git a/tests/testthat/test_Scenarios.R b/tests/testthat/test_Scenarios.R index 1d2746be..20d6a34c 100644 --- a/tests/testthat/test_Scenarios.R +++ b/tests/testthat/test_Scenarios.R @@ -213,7 +213,7 @@ test_that('Scenarios and constraints', { expect_null(sc$get_limits()) # Add covariates in various transformations - sc <- scenario(fit) + sc <- scenario(fit, copy_model = TRUE) # Copy model here over for the test x <- sc |> add_predictors(pred_future, transform = "none") expect_length(x$get_predictor_names(), 9) suppressWarnings( diff --git a/tests/testthat/test_functions.R b/tests/testthat/test_functions.R index c5651f1f..233ee73f 100644 --- a/tests/testthat/test_functions.R +++ b/tests/testthat/test_functions.R @@ -167,6 +167,10 @@ test_that('Custom functions - Test gridded transformations and ensembles', { expect_match(attr(tr1, "method"), "percentile") expect_match(attr(tr1, "format"), "binary") + # Kmeans threshold + expect_no_error(tr2 <- threshold(r2, method = "kmeans")) + expect_match(attr(tr2, "method"), "kmeans") + expect_match(attr(tr2, "format"), "binary") # --- # }) From f7e2cdf72d68b731f8924cdf09ad841e7e0bd6a3 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Tue, 8 Oct 2024 21:38:24 +0200 Subject: [PATCH 10/21] Minor fixes and `nicheplot` visualization function --- NAMESPACE | 1 + NEWS.md | 2 + R/add_control_bias.R | 2 +- R/add_predictors.R | 17 +-- R/class-biodiversitydistribution.R | 2 +- R/engine_stan.R | 8 +- R/ensemble.R | 16 +-- R/ibis.iSDM-package.R | 1 + R/misc.R | 6 +- R/plot.R | 169 +++++++++++++++++++++++++- R/scenario.R | 2 +- R/threshold.R | 2 +- R/utils-predictors.R | 16 +-- R/utils-spatial.R | 28 +++-- R/utils-stan.R | 3 +- R/utils.R | 2 +- _pkgdown.yml | 2 + man/BiodiversityDistribution-class.Rd | 2 +- man/add_control_bias.Rd | 2 +- man/bivplot.Rd | 2 +- man/engine_glm.Rd | 5 + man/ibis_future.Rd | 2 + man/ibis_set_strategy.Rd | 2 +- man/modal.Rd | 4 +- man/nicheplot.Rd | 70 +++++++++++ man/run_parallel.Rd | 4 +- man/scenario.Rd | 2 +- 27 files changed, 316 insertions(+), 58 deletions(-) create mode 100644 man/nicheplot.Rd diff --git a/NAMESPACE b/NAMESPACE index 01528af1..0f685e84 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -125,6 +125,7 @@ export(mask.PredictorDataset) export(modal) export(new_id) export(new_waiver) +export(nicheplot) export(partial) export(partial.DistributionModel) export(partial_density) diff --git a/NEWS.md b/NEWS.md index 5a64614f..344e66fa 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,12 +1,14 @@ # ibis.iSDM 0.1.5 (current dev branch) #### New features +* New visualization function `nicheplot()` to visualize suitability across 2 axes * Support for 'modal' value calculations in `ensemble()`. * Support for 'superlearner' in `ensemble()`. * Support for 'kmeans' derived threshold calculation in `threshold()` and `predictor_derivate()`. * Support for future processing streamlined. See FAQ section for instructions #18. #### Minor improvements and bug fixes +* Now overwriting temporary data by default in `predictor_transform()` and similar functions. * Minor :bug: fix related to misaligned thresholds and negative exponential kernels. * :fire: :bug: fix for scenario projections that use different grain sizes than for inference. diff --git a/R/add_control_bias.R b/R/add_control_bias.R index 56cfd372..206495ed 100644 --- a/R/add_control_bias.R +++ b/R/add_control_bias.R @@ -77,7 +77,7 @@ #' estimating spatial sampling effort and habitat suitability for multiple species #' from opportunistic presence‐only data. Methods in Ecology and Evolution, 12(5), 933-945. #' -#' @seealso [add_control_extrapolation()] +#' @seealso [add_limits_extrapolation()] #' @keywords bias offset control #' @concept The spatial bias weighting was inspired by code in the \code{enmSdmX} package. #' diff --git a/R/add_predictors.R b/R/add_predictors.R index b70c9afc..eff56e8a 100644 --- a/R/add_predictors.R +++ b/R/add_predictors.R @@ -248,7 +248,7 @@ methods::setMethod( # Mask predictors with existing background layer if(bgmask){ - env <- terra::mask(env, mask = x$background) + env <- terra::mask(env, mask = x$background, overwrite = TRUE) # Reratify, work somehow only on stacks if(has_factors && any(is.factor(env)) ){ new_env <- env @@ -350,7 +350,7 @@ methods::setMethod( # If it is a raster if(is.Raster(x$background)){ # Check that background and range align, otherwise raise error - if(is_comparable_raster(layer, x$background)){ + if(!is_comparable_raster(layer, x$background)){ warning('Supplied range does not align with background! Aligning them now...') layer <- alignRasters(layer, x$background, method = 'bilinear', func = mean, cl = FALSE) } @@ -372,12 +372,12 @@ methods::setMethod( if(terra::global(ras1, "min", na.rm = TRUE) == terra::global(ras1, "max", na.rm = TRUE)){ o <- ras2 # Ensure that all layers have a minimum and a maximum - o[is.na(o)] <- 0; o <- terra::mask(o, x$background) + o[is.na(o)] <- 0; o <- terra::mask(o, x$background, overwrite = TRUE) names(o) <- c('elev_high') } else { o <- c(ras1, ras2) # Ensure that all layers have a minimum and a maximum - o[is.na(o)] <- 0; o <- terra::mask(o, x$background) + o[is.na(o)] <- 0; o <- terra::mask(o, x$background, overwrite = TRUE) names(o) <- c('elev_low', 'elev_high') } rm(ras1,ras2) @@ -553,7 +553,8 @@ methods::setMethod( # ras_range <- raster::rasterize(layer, temp, field = 1, background = NA) # } # } else { - ras_range <- terra::rasterize(layer, temp, field = 1, background = 0) + ras_range <- terra::rasterize(layer, temp, field = 1, + background = 0, overwrite = TRUE) # } # -------------- # @@ -565,8 +566,8 @@ methods::setMethod( names(dis) <- 'binary_range' } else if(method == 'distance'){ # Calculate the linear distance from the range - dis <- terra::gridDist(ras_range, target = 1) - dis <- terra::mask(dis, x$background) + dis <- terra::gridDist(ras_range, target = 1, overwrite = TRUE) + dis <- terra::mask(dis, x$background, overwrite = TRUE) # If max distance is specified if(!is.null(distance_max) && !is.infinite(distance_max)){ dis[dis > distance_max] <- NA # Set values above threshold to NA @@ -581,7 +582,7 @@ methods::setMethod( # Set NA to 0 and mask again dis[is.na(dis)] <- 0 - dis <- terra::mask(dis, x$background) + dis <- terra::mask(dis, x$background, overwrite = TRUE) names(dis) <- 'distance_range' } diff --git a/R/class-biodiversitydistribution.R b/R/class-biodiversitydistribution.R index e32ad92a..ae447dad 100644 --- a/R/class-biodiversitydistribution.R +++ b/R/class-biodiversitydistribution.R @@ -142,7 +142,7 @@ BiodiversityDistribution <- R6::R6Class( #' @description #' Specify new limits to the background #' @param x A [`list`] object with method and limit type. - #' @seealso [add_control_extrapolation()] + #' @seealso [add_limits_extrapolation()] #' @return This object. set_limits = function(x){ # Specify list diff --git a/R/engine_stan.R b/R/engine_stan.R index 2e6647ae..a6687392 100644 --- a/R/engine_stan.R +++ b/R/engine_stan.R @@ -581,7 +581,7 @@ engine_stan <- function(x, newdata = full@data, offset = (full$w), family = fam, # Family - mode = self$stan_param$type # Type + type = self$stan_param$type # Type ) # Convert full to raster @@ -660,7 +660,7 @@ engine_stan <- function(x, newdata = full@data, offset = (full$w), family = fam, - mode = type # Linear predictor + type = type # Linear predictor ) # Fill output with summaries of the posterior @@ -766,7 +766,7 @@ engine_stan <- function(x, newdata = df_temp, offset = df_temp$w, family = fam, - mode = type) # Linear predictor + type = type) # Linear predictor # FIXME: Something wrong here I guess # Also attach the partial variable @@ -848,7 +848,7 @@ engine_stan <- function(x, newdata = df_partial@data, offset = df_partial$w, family = fam, - mode = type # Linear predictor + type = type # Linear predictor ) # Get container diff --git a/R/ensemble.R b/R/ensemble.R index 53dd5a91..5404ed35 100644 --- a/R/ensemble.R +++ b/R/ensemble.R @@ -253,16 +253,16 @@ methods::setMethod( names(ras) <- paste0('model', 1:terra::nlyr(ras)) ex <- terra::extract(ras, point, ID = FALSE) ex <- cbind(point[,field_occurrence], ex) - fit <- glm( - formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> as.formula(), - family = binomial(),data = ex + fit <- stats::glm( + formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> stats::as.formula(), + family = stats::binomial(),data = ex ) # Now predict output with the meta-learner new <- emptyraster(ras) new[which(!is.na(ras[[1]])[])] <- terra::predict( fit, ras, na.rm = FALSE, type = "response", cores = getOption('ibis.nthread')) - attr(new, "superlearner.coefficients") <- coef(fit) + attr(new, "superlearner.coefficients") <- stats::coef(fit) try({ rm(ex,fit) },silent = TRUE) } @@ -409,16 +409,16 @@ methods::setMethod( names(ras) <- paste0('model', 1:terra::nlyr(ras)) ex <- terra::extract(ras, point, ID = FALSE) ex <- cbind(point[,field_occurrence], ex) - fit <- glm( - formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> as.formula(), - family = binomial(),data = ex + fit <- stats::glm( + formula = paste(field_occurrence, "~", paste0(names(ras), collapse = ' + ')) |> stats::as.formula(), + family = stats::binomial(),data = ex ) # Now predict output with the meta-learner new <- emptyraster(ras) new[which(!is.na(ras[[1]])[])] <- terra::predict( fit, ras, na.rm = FALSE, type = "response", cores = getOption('ibis.nthread')) - attr(new, "superlearner.coefficients") <- coef(fit) + attr(new, "superlearner.coefficients") <- stats::coef(fit) try({ rm(ex,fit) },silent = TRUE) } # Rename diff --git a/R/ibis.iSDM-package.R b/R/ibis.iSDM-package.R index 31e9792f..5a3654e1 100644 --- a/R/ibis.iSDM-package.R +++ b/R/ibis.iSDM-package.R @@ -31,6 +31,7 @@ globalVariables(c("background", "band", "bi_class", "bias", "self", # Cores for parallel processing "cores", + "%dofuture%", # Global prediction function "predict_boom", "id", "included", "i", diff --git a/R/misc.R b/R/misc.R index 27dbfe03..27c35425 100644 --- a/R/misc.R +++ b/R/misc.R @@ -173,7 +173,7 @@ ibis_enable_parallel <- function(){ #' * \code{"slurm"} = To be implemented: Slurm linkage via batchtools. #' @param strategy A [`character`] with the strategy. #' @return Invisible -#' @seealso [future], [ibis_future_run] +#' @seealso [future], [ibis_future] #' @keywords misc #' @export ibis_set_strategy <- function(strategy = "sequential"){ @@ -222,6 +222,7 @@ ibis_set_threads <- function(threads = 2){ #' Make sure not to parallize predictions within existing clusters to avoid out-of-memory #' issues. #' +#' @param plan_exists A [`logical`] check on whether an existing [`future`] plan exists (Default: \code{FALSE}). #' @param cores A [`numeric`] number stating the number of cores to use. #' @param strategy A [`character`] denoting the strategy to be used for future. #' See help of [`future`] for options. (Default: \code{"multisession"}). @@ -367,8 +368,9 @@ chunk_data <- function(X, N = NULL, cores = parallel::detectCores(), index_only #' @param cores A [numeric] of the number of cores to use (Default: \code{1}). #' @param approach [`character`] for the parallelization approach taken (Options: #' \code{"parallel"} or \code{"future"}). -#' @param export_package A [`vector`] with packages to export for use on parallel +#' @param export_packages A [`vector`] with packages to export for use on parallel #' nodes (Default: \code{NULL}). +#' @param ... Any other parameter passed on. #' #' @details By default, the [parallel] package is used for parallel computation, #' however an option exists to use the [future] package instead. diff --git a/R/plot.R b/R/plot.R index 546d15fb..54c81dd7 100644 --- a/R/plot.R +++ b/R/plot.R @@ -57,7 +57,7 @@ plot.Engine <- function(x,...) x$plot(...) #' @export plot.BiodiversityScenario <- function(x,...) x$plot(...) -#' Bivariate plot wrapper for distribution objects +#' Bivariate prediction plot for distribution objects #' #' @description Often there is an intention to display not only the predictions #' made with a SDM, but also the uncertainty of the prediction. Uncertainty be @@ -127,7 +127,7 @@ methods::setMethod( is.character(col) || is.vector(col), is.null(title) || is.character(title), is.null(fname) || is.character(fname), - isTRUE(plot) || is.character(fname) + isTRUE(plot) ) # Check whether object is a raster, otherwise extract object if(is.Raster(mod)){ @@ -217,3 +217,168 @@ methods::setMethod( return(finalPlot) } ) + +#' Niche plot wrapper for distribution objects +#' +#' @description +#' The suitability of any given area for a biodiversity feature can in +#' many instances be complex and non-linear. Visualizing obtained suitability +#' predictions (e.g. from [`train()`]) against underlying predictors might help +#' to explain the underlying gradients of the niche. +#' +#' Supported Inputs for this function are either single trained \code{ibis.iSDM} +#' [`DistributionModel`] objects or alternatively a set of three [`SpatRaster`] objects. +#' In both cases, users have to make sure that \code{"xvar"} and \code{"yvar"} are set +#' accordingly. +#' +#' @param mod A trained [`DistributionModel`] or alternatively a [`SpatRaster`] +#' object with \code{prediction} model within. +#' @param xvar A [`character`] denoting the predictor on the x-axis. Alternatively a [`SpatRaster`] +#' object can be provided. +#' @param yvar A [`character`] denoting the predictor on the y-axis. Alternatively a [`SpatRaster`] +#' object can be provided. +#' @param plot A [`logical`] indication of whether the result is to be plotted +#' (Default: \code{TRUE})? +#' @param fname A [`character`] specifying the output file name a created figure +#' should be written to. +#' @param title Allows to respecify the title through a [`character`] (Default: \code{NULL}). +#' @param ... Other engine specific parameters. +#' +#' @return Saved niche plot in \code{'fname'} if specified, otherwise plot. +#' +#' @seealso [partial], [plot.DistributionModel] +#' @keywords misc +#' @examples +#' # Make quick prediction +#' background <- terra::rast(system.file('extdata/europegrid_50km.tif', +#' package='ibis.iSDM',mustWork = TRUE)) +#' virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM'), 'points',quiet = TRUE) +#' ll <- list.files(system.file('extdata/predictors/',package = 'ibis.iSDM',mustWork = TRUE),full.names = TRUE) +#' +#' # Load them as rasters +#' predictors <- terra::rast(ll);names(predictors) <- tools::file_path_sans_ext(basename(ll)) +#' +#' # Add GLM as an engine and predict +#' fit <- distribution(background) |> +#' add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', +#' name = 'Virtual points',docheck = FALSE) |> +#' add_predictors(predictors, transform = 'none',derivates = 'none') |> +#' engine_glm() |> +#' train() +#' +#' # Plot niche for prediction for temperature and forest cover +#' nicheplot(fit, xvar = "bio01_mean_50km", yvar = "CLC3_312_mean_50km" ) +#' @export +#' @name nicheplot +NULL + +#' @rdname nicheplot +#' @export +methods::setGeneric( + "nicheplot", + signature = methods::signature("mod"), + function(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL,...) standardGeneric("nicheplot")) + +#' @rdname nicheplot +methods::setMethod( + "nicheplot", + methods::signature(mod = "ANY"), + function(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL,...) { + # Generic checks + assertthat::assert_that(is.logical(plot), + is.character(xvar) || is.Raster(xvar), + is.character(yvar) || is.Raster(yvar), + is.null(title) || is.character(title), + is.null(fname) || is.character(fname), + isTRUE(plot) + ) + # Check whether object is a raster, otherwise extract object + if(is.Raster(mod)){ + obj <- mod + # Check x and y variables are correct + assertthat::assert_that( + is.Raster(xvar) && is.Raster(yvar), + msg = "SpatRaster objects need to be supplied as xvar and yvar!" + ) + # Align if mismatching + if(!is_comparable_raster(obj, xvar)){ + warning('xvariable not aligned with prediction. Aligning them now...') + xvar <- alignRasters(xvar, obj, method = 'bilinear', func = mean, cl = FALSE) + } + if(!is_comparable_raster(obj, yvar)){ + warning('yvariable not aligned with prediction. Aligning them now...') + yvar <- alignRasters(yvar, obj, method = 'bilinear', func = mean, cl = FALSE) + } + + } else { + assertthat::assert_that(inherits(mod, "DistributionModel"), + is.Raster(mod$get_data()), + msg = "The nicheplot function currently only works with fitted distribution objects!") + # Check that distribution object has a prediction + assertthat::assert_that("prediction" %in% mod$show_rasters(), + is.Raster(mod$get_data()), + msg = "No prediction found in the provided object.") + obj <- mod$get_data()[[1]] # Get the first layer + + # Also get the xvar/yvar + if(is.character(xvar)) xvar <- mod$model$predictors_object$get_data()[[xvar]] + if(is.character(yvar)) yvar <- mod$model$predictors_object$get_data()[[yvar]] + } + + # Check that all Raster objects are there + assertthat::assert_that( + is.Raster(xvar), is.Raster(yvar), is.Raster(obj), + terra::hasValues(obj), + msg = "Layers are not in spatial format?" + ) + + # Define default title + if(is.null(title)){ + if(is.Raster(mod)) tt <- names(obj) else tt <- paste0("\n (",mod$model$runname,")") + title <- paste("Niche plot for prediction ",tt) + } + + # Define variable names + xvar_lab <- names(xvar) + yvar_lab <- names(yvar) + col_lab <- names(obj) + + # Now check number of cells and extract. If too large, sample at random + o <- c(obj, xvar, yvar) + names(o) <- c("mean", "xvar", "yvar") + if(terra::ncell(o)>10000){ + # Messenger + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Visualization]','green','Sampling at random grid cells for extraction.') + ex <- terra::spatSample(o, size = 10000, method = "random", + as.df = TRUE, na.rm = TRUE) + } else { + # Extract + ex <- terra::as.data.frame(o, xy = FALSE, na.rm = TRUE, time = FALSE) + } + assertthat::assert_that(nrow(ex)>0) + + # Now plot + viz <- ggplot2::ggplot() + + ggplot2::theme_classic(base_size = 20) + + ggplot2::geom_point(data = ex, ggplot2::aes(x = xvar, y = yvar, colour = mean, alpha = mean)) + + ggplot2::scale_colour_gradientn(colours = ibis_colours$sdm_colour) + + ggplot2::guides(colour = ggplot2::guide_colorbar(title = col_lab), alpha = "none") + + ggplot2::theme(legend.position = "bottom", + legend.title = ggplot2::element_text(vjust = 1), + legend.key.size = ggplot2::unit(1, "cm")) + + ggplot2::labs( + title = title, + x = xvar_lab, + y = yvar_lab + ) + + # Print the plot + if(plot){ + print(viz) + } + if(is.character(fname)){ + cowplot::ggsave2(filename = fname, plot = viz) + } + return(viz) + } +) diff --git a/R/scenario.R b/R/scenario.R index aa1d6921..f07cfad3 100644 --- a/R/scenario.R +++ b/R/scenario.R @@ -19,7 +19,7 @@ NULL #' #' @note #' If a limit has been defined already during [train()], for example by adding -#' an extrapolation limit [add_control_extrapolation()], this zonal layer can be +#' an extrapolation limit [add_limits_extrapolation()], this zonal layer can be #' reused for the projections. **Note: This effectively fixes the projections to certain areas.** #' #' @examples diff --git a/R/threshold.R b/R/threshold.R index 2a05ef2e..521b9f3d 100644 --- a/R/threshold.R +++ b/R/threshold.R @@ -336,7 +336,7 @@ methods::setMethod( # by getting the value within regular sampled values ex <- terra::spatSample(raster_thresh, size = 1e6, method = "regular", na.rm = TRUE, exhaustive = TRUE) - ex <- subset(ex, complete.cases(ex)) + ex <- subset(ex, stats::complete.cases(ex)) if(nrow(ex)<5) stop("Not enough values for clustering found...") clus <- stats::kmeans(ex, centers = 2) tr <- clus$centers[which.max(clus$centers[,1])] diff --git a/R/utils-predictors.R b/R/utils-predictors.R index 9e7bce3d..b03331bc 100644 --- a/R/utils-predictors.R +++ b/R/utils-predictors.R @@ -179,7 +179,7 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var perc <- terra::global(env, fun = function(z) terra::quantile(z, probs = seq(0,1, length.out = 11), na.rm = TRUE)) } perc <- unique(perc) - out <- terra::classify(env, t(perc)) |> terra::as.int() + out <- terra::classify(env, t(perc), overwrite = TRUE) |> terra::as.int() attr(out, "transform_params") <- perc } else { out <- lapply(env_list, function(x) { @@ -191,7 +191,7 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var perc <- unique(perc) # For terra need to loop here as classify does not support multiple columns o <- terra::rast() - for(i in 1:nrow(perc)) o <- suppressWarnings( c(o, terra::classify(x[[i]], rcl = t(perc)[,i]) |> terra::as.int() )) + for(i in 1:nrow(perc)) o <- suppressWarnings( c(o, terra::classify(x[[i]], rcl = t(perc)[,i], overwrite = TRUE) |> terra::as.int() )) return(o) }) } @@ -262,7 +262,7 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var envMask <- !sum(terra::app(env, is.na)) assertthat::assert_that(terra::global(envMask, "sum")[,1]>0, msg = 'A predictor is either NA only or no valid values across all layers') - env <- terra::mask(env, envMask, maskvalues = 0) + env <- terra::mask(env, envMask, maskvalues = 0, overwrite = TRUE) # Sample covariance from stack and fit PCA covMat <- terra::layerCor(env, fun = "cov", na.rm = TRUE) @@ -597,7 +597,7 @@ predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, newcu[1] <- terra::global(env_list[[val]][[k]], "min",na.rm=T)[,1] newcu[nrow(newcu)*2] <- terra::global(env_list[[val]][[k]], "max",na.rm=T)[,1] - o <- terra::classify(env_list[[val]][[k]], newcu, include.lowest=TRUE) + o <- terra::classify(env_list[[val]][[k]], newcu, include.lowest=TRUE, overwrite = TRUE) terra::time(o) <- terra::time( env_list[[val]][[k]] ) names(o) <- paste0(val, "_",nrow(newcu)) suppressWarnings( nn <- append(nn, o) ) @@ -663,7 +663,7 @@ predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, newcu[1] <- terra::global(env_list[[val]][[k]], "min",na.rm=T)[,1] newcu[nrow(newcu)*2] <- terra::global(env_list[[val]][[k]], "max",na.rm=T)[,1] - o <- terra::classify(env_list[[val]][[k]], newcu, include.lowest=TRUE) + o <- terra::classify(env_list[[val]][[k]], newcu, include.lowest=TRUE, overwrite = TRUE) terra::time(o) <- terra::time( env_list[[val]][[k]] ) names(o) <- paste0(val, "_",nrow(newcu)) suppressWarnings( nn <- append(nn, o) ) @@ -845,7 +845,7 @@ predictor_homogenize_na <- function(env, fill = FALSE, fill_method = 'ngb', retu # Remove grid cells that are equal to the number of layers (all values NA) none_area <- mask_na == nl none_area[none_area == 0 ] <- NA - mask_na <- terra::mask(mask_na, mask = none_area, inverse = TRUE) + mask_na <- terra::mask(mask_na, mask = none_area, inverse = TRUE, overwrite = TRUE) # Should any fill be conducted? if(fill){ @@ -854,7 +854,7 @@ predictor_homogenize_na <- function(env, fill = FALSE, fill_method = 'ngb', retu # Otherwise just homogenize NA values across predictors if(terra::global(mask_na,'max',na.rm = TRUE)[,1] > 0){ mask_all <- mask_na == 0; mask_all[mask_all == 0] <- NA - env <- terra::mask(env, mask = mask_all) + env <- terra::mask(env, mask = mask_all, overwrite = TRUE) } } # Should NA coordinates of cells where 1 or more predictor is NA be @@ -1016,7 +1016,7 @@ makeBin <- function(v, n, nknots, cutoffs = NULL){ } # Make cuts and explode out <- explode_factorized_raster( - terra::classify(v, cu) + terra::classify(v, cu, overwrite = TRUE) ) # Format threshold names diff --git a/R/utils-spatial.R b/R/utils-spatial.R index a7c9c29b..44cb91be 100644 --- a/R/utils-spatial.R +++ b/R/utils-spatial.R @@ -344,7 +344,8 @@ create_zonaloccurrence_mask <- function(df, zones = NULL, buffer_width = NULL, c # Align with template if set if(!is.null(template)){ if(terra::compareGeom(zones, template, stopOnError = FALSE)){ - zones <- terra::resample(zones, template, method = "near", threads = getOption("ibis.nthread")) + zones <- terra::resample(zones, template, method = "near", + threads = getOption("ibis.nthread"), overwrite = TRUE) } } } @@ -357,8 +358,8 @@ create_zonaloccurrence_mask <- function(df, zones = NULL, buffer_width = NULL, c buf <- sf::st_buffer(x = df, dist = buffer_width, nQuadSegs = 50) ) # Rasterize - zones <- terra::rasterize(buf, template, field = 1, background = 0) - zones <- terra::mask(zones, template) + zones <- terra::rasterize(buf, template, field = 1, background = 0, overwrite = TRUE) + zones <- terra::mask(zones, template, overwrite = TRUE) # Ratify zones <- terra::droplevels(zones) } @@ -629,9 +630,9 @@ st_kde <- function(points, background, bandwidth = 3){ # Resample output for small point mismatches if(!terra::compareGeom(out, background, stopOnError = FALSE)){ - out <- terra::resample(out, background, threads = getOption("ibis.nthread")) + out <- terra::resample(out, background, threads = getOption("ibis.nthread"), overwrite = TRUE) } - out <- terra::mask(out, background) + out <- terra::mask(out, background, overwrite = TRUE) names(out) <- "kde__coordinates" rm(matrix, coords) return( out ) @@ -737,7 +738,7 @@ polygon_to_points <- function(poly, template, field_occurrence ) { ) # Rasterize the polygon to - out <- terra::rasterize(x = poly, y = template, field = field_occurrence) + out <- terra::rasterize(x = poly, y = template, field = field_occurrence, overwrite = TRUE) # Construct new point data co <- terra::xyFromCell(out, cell = which(!is.na(out[])) ) |> as.data.frame() @@ -867,11 +868,12 @@ alignRasters <- function(data, template, method = "bilinear", func = mean, cl = if(sf::st_crs(data) != sf::st_crs(template)){ # Project Raster layer data <- terra::project(data, terra::crs(template), - method = method, threads = getOption("ibis.nthread")) + method = method, + threads = getOption("ibis.nthread"), overwrite = TRUE) } # Crop raster to template - data <- terra::crop(data, template, snap = "out") + data <- terra::crop(data, template, snap = "out", overwrite = TRUE) # Aggregate to minimal scale if(is.Raster(template)){ @@ -879,12 +881,14 @@ alignRasters <- function(data, template, method = "bilinear", func = mean, cl = factor <- floor(data@ncols/template@ncols) data <- terra::aggregate(data, fact = factor, fun = func, - cores = ifelse(cl, getOption("ibis.nthread"), 1)) + cores = ifelse(cl, getOption("ibis.nthread"), 1), + overwrite = TRUE) } } else { # Resample with target method - ras <- terra::rasterize(template, data) - data <- terra::resample(data, ras, method = method, threads = getOption("ibis.nthread")) + ras <- terra::rasterize(template, data, overwrite = TRUE) + data <- terra::resample(data, ras, method = method, + threads = getOption("ibis.nthread"), overwrite = TRUE) } return(data) } @@ -1520,7 +1524,7 @@ thin_observations <- function(data, background, env = NULL, method = "random", r # Take coordinates of supplied data and rasterize coords <- sf::st_coordinates(data) - ras <- terra::rasterize(coords, background, fun = sum) # Get the number of observations per grid cell + ras <- terra::rasterize(coords, background, fun = sum, overwrite = TRUE) # Get the number of observations per grid cell # Lower and upper bounds for thinning totake <- c(lower = remainpoints, upper = max(terra::global(ras, "min", na.rm = TRUE)[,1], diff --git a/R/utils-stan.R b/R/utils-stan.R index f45b78a3..f60726c0 100644 --- a/R/utils-stan.R +++ b/R/utils-stan.R @@ -335,7 +335,8 @@ run_stan <- function( model_code, data = list(), #' * The brms R-package. #' #' @export -posterior_predict_stanfit <- function(obj, form, newdata, type = "predictor", family = NULL, offset = NULL, draws = NULL){ +posterior_predict_stanfit <- function(obj, form, newdata, type = "predictor", + family = NULL, offset = NULL, draws = NULL){ assertthat::assert_that( inherits(obj, "stanfit") || inherits(obj, "CmdStanFit"), is.formula(form), diff --git a/R/utils.R b/R/utils.R index d3f3b06f..3ff76625 100644 --- a/R/utils.R +++ b/R/utils.R @@ -62,7 +62,7 @@ text_green <- function(text) { paste0('\033[32m',text,'\033[39m') } #' Calculate the mode of a provided vector #' -#' @param A [`vector`] of values or characters. +#' @param x A [`vector`] of values or characters. #' @param na.rm [`logical`] whether \code{NA} values are to be removed (Default: \code{TRUE}) #' #' @keywords utils, misc diff --git a/_pkgdown.yml b/_pkgdown.yml index ad4c8a41..d9e5dd68 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -104,6 +104,8 @@ reference: desc: Key functions to summarize, validate or extract information from trained models. contents: - plot + - bivplot + - nicheplot - print - summary - coef diff --git a/man/BiodiversityDistribution-class.Rd b/man/BiodiversityDistribution-class.Rd index fb2830f0..a05c3b10 100644 --- a/man/BiodiversityDistribution-class.Rd +++ b/man/BiodiversityDistribution-class.Rd @@ -28,7 +28,7 @@ names(x) } \seealso{ -\code{\link[=add_control_extrapolation]{add_control_extrapolation()}} +\code{\link[=add_limits_extrapolation]{add_limits_extrapolation()}} \code{\link[=add_latent_spatial]{add_latent_spatial()}} diff --git a/man/add_control_bias.Rd b/man/add_control_bias.Rd index 60517694..2f292bb4 100644 --- a/man/add_control_bias.Rd +++ b/man/add_control_bias.Rd @@ -123,7 +123,7 @@ from opportunistic presence‐only data. Methods in Ecology and Evolution, 12(5) } } \seealso{ -\code{\link[=add_control_extrapolation]{add_control_extrapolation()}} +\code{\link[=add_limits_extrapolation]{add_limits_extrapolation()}} } \concept{The spatial bias weighting was inspired by code in the \code{enmSdmX} package.} \keyword{bias} diff --git a/man/bivplot.Rd b/man/bivplot.Rd index 3a4e01a5..6528dbda 100644 --- a/man/bivplot.Rd +++ b/man/bivplot.Rd @@ -3,7 +3,7 @@ \name{bivplot} \alias{bivplot} \alias{bivplot,ANY-method} -\title{Bivariate plot wrapper for distribution objects} +\title{Bivariate prediction plot for distribution objects} \usage{ bivplot( mod, diff --git a/man/engine_glm.Rd b/man/engine_glm.Rd index 8f0c4700..023b1f5d 100644 --- a/man/engine_glm.Rd +++ b/man/engine_glm.Rd @@ -37,6 +37,11 @@ for \code{\link[=ensemble]{ensemble()}} of small models (a practice common for r \details{ This engine is essentially a wrapper for \code{\link[stats:glm]{stats::glm.fit()}}, however with customized settings to support offsets and weights. + +If \code{"optim_hyperparam"} is set to \code{TRUE} in \code{\link[=train]{train()}}, then a AIC +based step-wise (backwards) model selection is performed. +Generally however \code{\link{engine_glmnet}} should be the preferred package for models +with more than \code{>3} covariates. } \examples{ # Load background diff --git a/man/ibis_future.Rd b/man/ibis_future.Rd index 9fc662ef..761af892 100644 --- a/man/ibis_future.Rd +++ b/man/ibis_future.Rd @@ -12,6 +12,8 @@ ibis_future( ) } \arguments{ +\item{plan_exists}{A \code{\link{logical}} check on whether an existing \code{\link{future}} plan exists (Default: \code{FALSE}).} + \item{cores}{A \code{\link{numeric}} number stating the number of cores to use.} \item{strategy}{A \code{\link{character}} denoting the strategy to be used for future. diff --git a/man/ibis_set_strategy.Rd b/man/ibis_set_strategy.Rd index fe9fb26b..190f11b9 100644 --- a/man/ibis_set_strategy.Rd +++ b/man/ibis_set_strategy.Rd @@ -26,6 +26,6 @@ Currently supported strategies are: } } \seealso{ -\link{future}, \link{ibis_future_run} +\link{future}, \link{ibis_future} } \keyword{misc} diff --git a/man/modal.Rd b/man/modal.Rd index 5cdc6ae1..b8db6be7 100644 --- a/man/modal.Rd +++ b/man/modal.Rd @@ -7,9 +7,9 @@ modal(x, na.rm = TRUE) } \arguments{ -\item{na.rm}{\code{\link{logical}} whether \code{NA} values are to be removed (Default: \code{TRUE})} +\item{x}{A \code{\link{vector}} of values or characters.} -\item{A}{\code{\link{vector}} of values or characters.} +\item{na.rm}{\code{\link{logical}} whether \code{NA} values are to be removed (Default: \code{TRUE})} } \value{ The most common (mode) estimate. diff --git a/man/nicheplot.Rd b/man/nicheplot.Rd new file mode 100644 index 00000000..cac0c716 --- /dev/null +++ b/man/nicheplot.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{nicheplot} +\alias{nicheplot} +\alias{nicheplot,ANY-method} +\title{Niche plot wrapper for distribution objects} +\usage{ +nicheplot(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL, ...) + +\S4method{nicheplot}{ANY}(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL, ...) +} +\arguments{ +\item{mod}{A trained \code{\link{DistributionModel}} or alternatively a \code{\link{SpatRaster}} +object with \code{prediction} model within.} + +\item{xvar}{A \code{\link{character}} denoting the predictor on the x-axis. Alternatively a \code{\link{SpatRaster}} +object can be provided.} + +\item{yvar}{A \code{\link{character}} denoting the predictor on the y-axis. Alternatively a \code{\link{SpatRaster}} +object can be provided.} + +\item{plot}{A \code{\link{logical}} indication of whether the result is to be plotted +(Default: \code{TRUE})?} + +\item{fname}{A \code{\link{character}} specifying the output file name a created figure +should be written to.} + +\item{title}{Allows to respecify the title through a \code{\link{character}} (Default: \code{NULL}).} + +\item{...}{Other engine specific parameters.} +} +\value{ +Saved niche plot in \code{'fname'} if specified, otherwise plot. +} +\description{ +The suitability of any given area for a biodiversity feature can in +many instances be complex and non-linear. Visualizing obtained suitability +predictions (e.g. from \code{\link[=train]{train()}}) against underlying predictors might help +to explain the underlying gradients of the niche. + +Supported Inputs for this function are either single trained \code{ibis.iSDM} +\code{\link{DistributionModel}} objects or alternatively a set of three \code{\link{SpatRaster}} objects. +In both cases, users have to make sure that \code{"xvar"} and \code{"yvar"} are set +accordingly. +} +\examples{ +# Make quick prediction +background <- terra::rast(system.file('extdata/europegrid_50km.tif', +package='ibis.iSDM',mustWork = TRUE)) +virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM'), 'points',quiet = TRUE) +ll <- list.files(system.file('extdata/predictors/',package = 'ibis.iSDM',mustWork = TRUE),full.names = TRUE) + +# Load them as rasters +predictors <- terra::rast(ll);names(predictors) <- tools::file_path_sans_ext(basename(ll)) + +# Add GLM as an engine and predict +fit <- distribution(background) |> +add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', +name = 'Virtual points',docheck = FALSE) |> +add_predictors(predictors, transform = 'none',derivates = 'none') |> +engine_glm() |> +train() + +# Plot niche for prediction for temperature and forest cover +nicheplot(fit, xvar = "bio01_mean_50km", yvar = "CLC3_312_mean_50km" ) +} +\seealso{ +\link{partial}, \link{plot.DistributionModel} +} +\keyword{misc} diff --git a/man/run_parallel.Rd b/man/run_parallel.Rd index 85506f22..8b1a4e5f 100644 --- a/man/run_parallel.Rd +++ b/man/run_parallel.Rd @@ -24,8 +24,10 @@ core or parallel \link{apply} call.} \item{approach}{\code{\link{character}} for the parallelization approach taken (Options: \code{"parallel"} or \code{"future"}).} -\item{export_package}{A \code{\link{vector}} with packages to export for use on parallel +\item{export_packages}{A \code{\link{vector}} with packages to export for use on parallel nodes (Default: \code{NULL}).} + +\item{...}{Any other parameter passed on.} } \description{ Some computations take considerable amount of time to execute. diff --git a/man/scenario.Rd b/man/scenario.Rd index 382b961d..237307e4 100644 --- a/man/scenario.Rd +++ b/man/scenario.Rd @@ -30,7 +30,7 @@ that contains the projections of a model. } \note{ If a limit has been defined already during \code{\link[=train]{train()}}, for example by adding -an extrapolation limit \code{\link[=add_control_extrapolation]{add_control_extrapolation()}}, this zonal layer can be +an extrapolation limit \code{\link[=add_limits_extrapolation]{add_limits_extrapolation()}}, this zonal layer can be reused for the projections. \strong{Note: This effectively fixes the projections to certain areas.} } \examples{ From c033af2f0ce463ce8d22223e27894190e5c2f13c Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 10 Oct 2024 14:24:28 +0200 Subject: [PATCH 11/21] Nicheplot wrapper function for occurrence points #87 --- NEWS.md | 2 +- R/plot.R | 245 +++++++++++++++++++++++++++++++++++++---------- man/nicheplot.Rd | 42 +++++++- 3 files changed, 230 insertions(+), 59 deletions(-) diff --git a/NEWS.md b/NEWS.md index 344e66fa..f834db9b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,7 @@ # ibis.iSDM 0.1.5 (current dev branch) #### New features -* New visualization function `nicheplot()` to visualize suitability across 2 axes +* New visualization function `nicheplot()` to visualize suitability across 2 axes #87. * Support for 'modal' value calculations in `ensemble()`. * Support for 'superlearner' in `ensemble()`. * Support for 'kmeans' derived threshold calculation in `threshold()` and `predictor_derivate()`. diff --git a/R/plot.R b/R/plot.R index 54c81dd7..80d73302 100644 --- a/R/plot.R +++ b/R/plot.R @@ -218,7 +218,7 @@ methods::setMethod( } ) -#' Niche plot wrapper for distribution objects +#' Niche plot for distribution objects #' #' @description #' The suitability of any given area for a biodiversity feature can in @@ -228,8 +228,10 @@ methods::setMethod( #' #' Supported Inputs for this function are either single trained \code{ibis.iSDM} #' [`DistributionModel`] objects or alternatively a set of three [`SpatRaster`] objects. -#' In both cases, users have to make sure that \code{"xvar"} and \code{"yvar"} are set -#' accordingly. +#' In both cases, users can specify \code{"xvar"} and \code{"yvar"} explicitly +#' or leave them empty. In the latter case a principal component analysis (PCA) +#' is conducted on the full environmental stack (loaded from [`DistributionModel`] +#' or supplied separately). #' #' @param mod A trained [`DistributionModel`] or alternatively a [`SpatRaster`] #' object with \code{prediction} model within. @@ -237,11 +239,16 @@ methods::setMethod( #' object can be provided. #' @param yvar A [`character`] denoting the predictor on the y-axis. Alternatively a [`SpatRaster`] #' object can be provided. +#' @param envvars A [`SpatRaster`] object containing all environmental variables. Only +#' used if \code{xvar} and \code{yvar} is empty (Default: \code{NULL}). +#' @param overlay_data A [`logical`] on whether training data should be overlaid +#' on the plot. Only used for [`DistributionModel`] objects (Default: \code{FALSE}). #' @param plot A [`logical`] indication of whether the result is to be plotted #' (Default: \code{TRUE})? #' @param fname A [`character`] specifying the output file name a created figure #' should be written to. #' @param title Allows to respecify the title through a [`character`] (Default: \code{NULL}). +#' @param pal An optional [`vector`] with continuous custom colours (Default: \code{NULL}). #' @param ... Other engine specific parameters. #' #' @return Saved niche plot in \code{'fname'} if specified, otherwise plot. @@ -277,21 +284,34 @@ NULL methods::setGeneric( "nicheplot", signature = methods::signature("mod"), - function(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL,...) standardGeneric("nicheplot")) + function(mod, xvar = NULL, yvar = NULL, envvars = NULL, overlay_data = FALSE, + plot = TRUE, fname = NULL, title = NULL, pal = NULL, ...) standardGeneric("nicheplot")) #' @rdname nicheplot methods::setMethod( "nicheplot", methods::signature(mod = "ANY"), - function(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL,...) { + function(mod, xvar = NULL, yvar = NULL, envvars = NULL, overlay_data = FALSE, + plot = TRUE, fname = NULL, title = NULL, pal = NULL, ...) { # Generic checks - assertthat::assert_that(is.logical(plot), - is.character(xvar) || is.Raster(xvar), - is.character(yvar) || is.Raster(yvar), + assertthat::assert_that( + is.null(xvar) || (is.character(xvar) || is.Raster(xvar)), + is.null(yvar) || (is.character(yvar) || is.Raster(yvar)), + is.null(envvars) || is.Raster(envvars), + is.logical(overlay_data), is.null(title) || is.character(title), is.null(fname) || is.character(fname), - isTRUE(plot) + is.logical(plot), + is.null(pal) || is.vector(pal), + msg = "Provide correct parameters (see help file)." ) + check_package("ggplot2") # Should be loaded by default + + # Check specific on x/y variables + assertthat::assert_that((is.null(xvar) && is.null(yvar)) || + (is.character(xvar) && is.character(yvar)), + msg = "Both x and y variable names must be specified!") + # Check whether object is a raster, otherwise extract object if(is.Raster(mod)){ obj <- mod @@ -300,17 +320,31 @@ methods::setMethod( is.Raster(xvar) && is.Raster(yvar), msg = "SpatRaster objects need to be supplied as xvar and yvar!" ) - # Align if mismatching - if(!is_comparable_raster(obj, xvar)){ - warning('xvariable not aligned with prediction. Aligning them now...') - xvar <- alignRasters(xvar, obj, method = 'bilinear', func = mean, cl = FALSE) - } - if(!is_comparable_raster(obj, yvar)){ - warning('yvariable not aligned with prediction. Aligning them now...') - yvar <- alignRasters(yvar, obj, method = 'bilinear', func = mean, cl = FALSE) + + # Check if set + if(!is.null(xvar) && !is.null(yvar)){ + # Align if mismatching + if(!is_comparable_raster(obj, xvar)){ + warning('xvariable not aligned with prediction. Aligning them now...') + xvar <- alignRasters(xvar, obj, method = 'bilinear', func = mean, cl = FALSE) + } + if(!is_comparable_raster(obj, yvar)){ + warning('yvariable not aligned with prediction. Aligning them now...') + yvar <- alignRasters(yvar, obj, method = 'bilinear', func = mean, cl = FALSE) + } + } else { + assertthat::assert_that(is.Raster(envvars), + terra::nlyr(envvars)>1, + msg = "A multi layer environmental stack has to be supplied directly!") + + if(!is_comparable_raster(obj, envvars)){ + warning('Predictorstack not aligned with prediction. Aligning them now...') + envvars <- alignRasters(envvars, obj, method = 'bilinear', func = mean, cl = FALSE) + } } } else { + # Distribution model objects # assertthat::assert_that(inherits(mod, "DistributionModel"), is.Raster(mod$get_data()), msg = "The nicheplot function currently only works with fitted distribution objects!") @@ -320,17 +354,37 @@ methods::setMethod( msg = "No prediction found in the provided object.") obj <- mod$get_data()[[1]] # Get the first layer - # Also get the xvar/yvar - if(is.character(xvar)) xvar <- mod$model$predictors_object$get_data()[[xvar]] - if(is.character(yvar)) yvar <- mod$model$predictors_object$get_data()[[yvar]] + # Check if set + if(!is.null(xvar) && !is.null(yvar)){ + assertthat::assert_that(is.character(xvar), is.character(yvar), + msg = "Specify predictor names for both xvar and yvar.") + # Check that variables are present + assertthat::assert_that( + xvar %in% mod$model$predictors_names, yvar %in% mod$model$predictors_names, + msg = "Variables not used in underlying model?" + ) + # Also get the xvar/yvar + if(is.character(xvar)) xvar <- mod$model$predictors_object$get_data()[[xvar]] + if(is.character(yvar)) yvar <- mod$model$predictors_object$get_data()[[yvar]] + } else { + if(is.null(envvars)){ + envvars <- mod$model$predictors_object$get_data() + } else { + assertthat::assert_that(is.Raster(envvars), + terra::nlyr(envvars)>1, + msg = "A multi layer environmental stack has to be supplied directly!") } + } } - # Check that all Raster objects are there - assertthat::assert_that( - is.Raster(xvar), is.Raster(yvar), is.Raster(obj), - terra::hasValues(obj), - msg = "Layers are not in spatial format?" - ) + # Get training data if set + if(overlay_data){ + assertthat::assert_that(inherits(mod, "DistributionModel"), + msg = "Data overlay currently only works with a fitted model object!") + # Collect Biodiversity occurrence data + occ <- collect_occurrencepoints(mod$model, + include_absences = FALSE, + addName = TRUE,tosf = TRUE) + } # Define default title if(is.null(title)){ @@ -338,47 +392,132 @@ methods::setMethod( title <- paste("Niche plot for prediction ",tt) } - # Define variable names - xvar_lab <- names(xvar) - yvar_lab <- names(yvar) - col_lab <- names(obj) - - # Now check number of cells and extract. If too large, sample at random - o <- c(obj, xvar, yvar) - names(o) <- c("mean", "xvar", "yvar") - if(terra::ncell(o)>10000){ - # Messenger - if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Visualization]','green','Sampling at random grid cells for extraction.') - ex <- terra::spatSample(o, size = 10000, method = "random", - as.df = TRUE, na.rm = TRUE) + # Define colour palette if not set + if(is.null(pal)){ + pal <- ibis_colours$sdm_colour } else { - # Extract - ex <- terra::as.data.frame(o, xy = FALSE, na.rm = TRUE, time = FALSE) + assertthat::assert_that(length(pal)>=1) } - assertthat::assert_that(nrow(ex)>0) - # Now plot - viz <- ggplot2::ggplot() + - ggplot2::theme_classic(base_size = 20) + - ggplot2::geom_point(data = ex, ggplot2::aes(x = xvar, y = yvar, colour = mean, alpha = mean)) + - ggplot2::scale_colour_gradientn(colours = ibis_colours$sdm_colour) + + # ----------- # + if(is.null(xvar) && is.null(yvar)){ + # No specific variables found. Conduct a principle component analysis + # and predict for the first two axes. + assertthat::assert_that(is.Raster(envvars)) + pca <- terra::prcomp(envvars, maxcell = 10000) + rpca <- terra::predict(envvars, pca, index=1:2) + + # Now check number of cells and extract. If too large, sample at random + o <- c(obj, rpca) + names(o) <- c("mean", "PC1", "PC2") + if(terra::ncell(o)>10000){ + # Messenger + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Visualization]','green','Sampling at random grid cells for extraction.') + ex <- terra::spatSample(o, size = 10000, method = "random", + as.df = TRUE, na.rm = TRUE) + } else { + # Extract + ex <- terra::as.data.frame(o, xy = FALSE, na.rm = TRUE, time = FALSE) + } + assertthat::assert_that(nrow(ex)>0) + + # Define variable names + xvar_lab <- "PC1" + yvar_lab <- "PC2" + col_lab <- names(obj) + + # Now plot + viz <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = 20) + + ggplot2::geom_point(data = ex, ggplot2::aes(x = PC1, y = PC2, colour = mean, alpha=mean)) + + ggplot2::scale_colour_gradientn(colours = pal) + ggplot2::guides(colour = ggplot2::guide_colorbar(title = col_lab), alpha = "none") + ggplot2::theme(legend.position = "bottom", legend.title = ggplot2::element_text(vjust = 1), legend.key.size = ggplot2::unit(1, "cm")) + - ggplot2::labs( - title = title, - x = xvar_lab, - y = yvar_lab + ggplot2::labs( + title = title, + x = xvar_lab, + y = yvar_lab + ) + + # Should the training data be overlaid? + if(overlay_data){ + pp <- terra::extract(o, occ, ID = FALSE) + pp$name <- as.factor( occ$name ) + + viz <- viz + + ggplot2::geom_point(data = pp, + ggplot2::aes(x = PC1, y = PC2), + col = "black", + size = 1.5,show.legend = TRUE) + + ggplot2::labs(subtitle = "Training data (black)") + } + + } else { + # Make plot for two variables which should have been collected above. + # Check that all Raster objects are there + assertthat::assert_that( + is.Raster(xvar), is.Raster(yvar), is.Raster(obj), + terra::hasValues(obj), + msg = "Layers are not in spatial format?" ) + # Define variable names + xvar_lab <- names(xvar) + yvar_lab <- names(yvar) + col_lab <- names(obj) + + # Now check number of cells and extract. If too large, sample at random + o <- c(obj, xvar, yvar) + names(o) <- c("mean", "xvar", "yvar") + if(terra::ncell(o)>10000){ + # Messenger + if(getOption('ibis.setupmessages', default = TRUE)) myLog('[Visualization]','green','Sampling at random grid cells for extraction.') + ex <- terra::spatSample(o, size = 10000, method = "random", + as.df = TRUE, na.rm = TRUE) + } else { + # Extract + ex <- terra::as.data.frame(o, xy = FALSE, na.rm = TRUE, time = FALSE) + } + assertthat::assert_that(nrow(ex)>0) + + + # Now plot + viz <- ggplot2::ggplot() + + ggplot2::theme_bw(base_size = 20) + + ggplot2::geom_point(data = ex, ggplot2::aes(x = xvar, y = yvar, colour = mean, alpha = mean)) + + ggplot2::scale_colour_gradientn(colours = pal) + + ggplot2::guides(colour = ggplot2::guide_colorbar(title = col_lab), alpha = "none") + + ggplot2::theme(legend.position = "bottom", + legend.title = ggplot2::element_text(vjust = 1), + legend.key.size = ggplot2::unit(1, "cm")) + + ggplot2::labs( + title = title, + x = xvar_lab, + y = yvar_lab + ) + + # Should the training data be overlaid? + if(overlay_data){ + pp <- terra::extract(o, occ, ID = FALSE) + pp$name <- as.factor( occ$name ) + + viz <- viz + + ggplot2::geom_point(data = pp, + ggplot2::aes(x = xvar, y = yvar), + col = "black", + size = 1.5,show.legend = TRUE) + + ggplot2::labs(subtitle = "Training data (black)") + } + } + # Print the plot if(plot){ - print(viz) + return(viz) } if(is.character(fname)){ cowplot::ggsave2(filename = fname, plot = viz) } - return(viz) } ) diff --git a/man/nicheplot.Rd b/man/nicheplot.Rd index cac0c716..5b430bf1 100644 --- a/man/nicheplot.Rd +++ b/man/nicheplot.Rd @@ -3,11 +3,33 @@ \name{nicheplot} \alias{nicheplot} \alias{nicheplot,ANY-method} -\title{Niche plot wrapper for distribution objects} +\title{Niche plot for distribution objects} \usage{ -nicheplot(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL, ...) +nicheplot( + mod, + xvar = NULL, + yvar = NULL, + envvars = NULL, + overlay_data = FALSE, + plot = TRUE, + fname = NULL, + title = NULL, + pal = NULL, + ... +) -\S4method{nicheplot}{ANY}(mod, xvar, yvar, plot = TRUE, fname = NULL, title = NULL, ...) +\S4method{nicheplot}{ANY}( + mod, + xvar = NULL, + yvar = NULL, + envvars = NULL, + overlay_data = FALSE, + plot = TRUE, + fname = NULL, + title = NULL, + pal = NULL, + ... +) } \arguments{ \item{mod}{A trained \code{\link{DistributionModel}} or alternatively a \code{\link{SpatRaster}} @@ -19,6 +41,12 @@ object can be provided.} \item{yvar}{A \code{\link{character}} denoting the predictor on the y-axis. Alternatively a \code{\link{SpatRaster}} object can be provided.} +\item{envvars}{A \code{\link{SpatRaster}} object containing all environmental variables. Only +used if \code{xvar} and \code{yvar} is empty (Default: \code{NULL}).} + +\item{overlay_data}{A \code{\link{logical}} on whether training data should be overlaid +on the plot. Only used for \code{\link{DistributionModel}} objects (Default: \code{FALSE}).} + \item{plot}{A \code{\link{logical}} indication of whether the result is to be plotted (Default: \code{TRUE})?} @@ -27,6 +55,8 @@ should be written to.} \item{title}{Allows to respecify the title through a \code{\link{character}} (Default: \code{NULL}).} +\item{pal}{A \code{\link{vector}} with continious colours with viridis plasma by default (Default: \code{NULL}).} + \item{...}{Other engine specific parameters.} } \value{ @@ -40,8 +70,10 @@ to explain the underlying gradients of the niche. Supported Inputs for this function are either single trained \code{ibis.iSDM} \code{\link{DistributionModel}} objects or alternatively a set of three \code{\link{SpatRaster}} objects. -In both cases, users have to make sure that \code{"xvar"} and \code{"yvar"} are set -accordingly. +In both cases, users can specify \code{"xvar"} and \code{"yvar"} explicitly +or leave them empty. In the latter case a principal component analysis (PCA) +is conducted on the full environmental stack (loaded from \code{\link{DistributionModel}} +or supplied separately). } \examples{ # Make quick prediction From e31617110afec430b0a993f55f568b25e666d8df Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Sun, 13 Oct 2024 13:33:09 +0200 Subject: [PATCH 12/21] Derivate range predictor helper #129 --- R/utils-predictors.R | 214 +++++++++++++++++++++++++++++++++++++- man/nicheplot.Rd | 2 +- man/predictor_derivate.Rd | 7 +- 3 files changed, 217 insertions(+), 6 deletions(-) diff --git a/R/utils-predictors.R b/R/utils-predictors.R index b03331bc..5782c0db 100644 --- a/R/utils-predictors.R +++ b/R/utils-predictors.R @@ -329,7 +329,8 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var #' #' @param env A [`SpatRaster`] object. #' @param option A [`vector`] stating whether predictors should be preprocessed in any -#' way (Options: \code{'none'}, \code{'quadratic'}, \code{'hinge'}, \code{'thresh'}, \code{'bin'}). +#' way (Options: \code{'none'}, \code{'quadratic'}, \code{'hinge'}, +#' \code{'kmeans'}, \code{'thresh'}, \code{'bin'}). #' @param nknots The number of knots to be used for the transformation (Default: \code{4}). #' @param deriv A [`vector`] with [`character`] of specific derivates to create (Default: \code{NULL}). #' @param int_variables A [`vector`] with length greater or equal than \code{2} @@ -371,6 +372,10 @@ predictor_transform <- function(env, option, windsor_props = c(.05,.95), pca.var #' new <- predictor_derivate(r_ori, option = "hinge", knots = 4) #' terra::plot(new) #' +#' # Or a quadratic transformation +#' new2 <- predictor_derivate(r_ori, option = "quad", knots = 4) +#' terra::plot(new2) +#' #' @export predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, int_variables = NULL, method = NULL, ...){ @@ -565,7 +570,7 @@ predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, for(val in names(env)){ suppressWarnings( o <- makeBin(env[[val]], n = val, nknots = nknots, cutoffs = cutoffs) ) if(is.null(o)) next() - new_env <- c(new_env, o) + suppressWarnings( new_env <- c(new_env, o) ) rm(o) } } else { @@ -629,7 +634,7 @@ predictor_derivate <- function(env, option, nknots = 4, deriv = NULL, names(o[[i]]) <- paste0('kmeans_',val,'_',round(cu$centers[i], 3)) attr(o[[i]], "deriv.kmeans") <- cu$centers[i] } - new_env <- c(new_env, o) + suppressWarnings( new_env <- c(new_env, o) ) rm(o) } } else { @@ -1007,7 +1012,7 @@ makeBin <- function(v, n, nknots, cutoffs = NULL){ if(anyDuplicated(cu)){ # If duplicated quantiles (e.g. 0, 0, 0.2..), sample from a larger number - cu <- terra::quantile(v[], probs = seq(0, 1, by = 1/(nknots*2)) ) + cu <- terra::quantile(v[], probs = seq(0, 1, by = 1/(nknots*2)), na.rm = TRUE ) cu <- cu[-which(duplicated(cu))] # Remove duplicated cuts if(length(cu)<=2) return( NULL ) if(length(cu) > nknots){ @@ -1031,6 +1036,207 @@ makeBin <- function(v, n, nknots, cutoffs = NULL){ return(out) } +#' Recreate a derivative variable based on their range +#' +#' @description +#' The purpose of this function is to create the range from several derivative +#' variables. The information to do so is taken from the variable name and it +#' is assumed that those have been created by [`predictor_derivate()`] function. +#' +#' This function return the range of values from the original data that fall within +#' the set of coefficients. Currently only positive coefficients are taken by default. +#' +#' @details +#' * This function really only makes sense for \code{'bin'}, \code{'thresh'} and +#' \code{'hinge'} transformations. +#' +#' * For \code{'hinge'} the combined \code{min} is returned. +#' +#' @note +#' This is rather an internal function created for a specific use and project. It +#' might be properly described in an example later. +#' +#' @param env The original variable stacks as [`SpatRaster`] or [`stars`]. +#' @param varname A [`character`] of the variable name. Needs to be present in +#' \code{"env"}. +#' @param co A set of coefficients obtained via [`stats::coef()`] and a +#' [`BiodiversityDistribution`] object. +#' @param to_binary A [`logical`] flag if the output should be converted to binary +#' format or left in the original units (Default: \code{FALSE}). +#' +#' @returns A [`SpatRaster`] object containing the predictor range. +#' @examples +#' \dontrun{ +#' # Assuming derivates of temperatue have been created for a model, this +#' # recreates the range over which they apply. +#' deriv <- create_derivate_range(env, varname = "Temperature", +#' co = coef(fit), to_binary = TRUE) +#' } +#' +#' @author Martin Jung +#' @keywords internal, utils +#' @noRd +create_derivate_range <- function(env, varname, co, to_binary = FALSE){ + assertthat::assert_that( + is.Raster(env) || inherits(env, "stars"), + is.character(varname) && length(varname)==1, + is.data.frame(co) || is.character(co), + is.logical(to_binary) + ) + + if(is.data.frame(co)){ + if(nrow(co)==0) { + message("No valid coefficients found?") + return(NULL) + } + } + if(!(varname %in% names(env))){ + message("Variable not found in environmental stack!") + return(NULL) + } + # --- # + + # Get the deriv names from the coefficients + # If character is supplied, assume those are all positive. + if(is.character(co)){ + co <- data.frame(Feature = co, Beta = 0.01) + } + deriv <- co[,1] + if(is.data.frame(deriv)) deriv <- deriv[[1]] # For Tibble + + # Now split the names use base R + cu <- base::strsplit(deriv, "_") + df <- data.frame() + for(i in 1:length(cu)){ # Number of derivs + o <- as.data.frame(cu[[i]] |> t()) + # Also check for actual variable coverage + if(o[1,1] %in% c("thresh")){ + # FIXME: Why does this use points rather than _ ? + check <- paste0(o[,c(2:(ncol(o)-1))],collapse = '_') + } else { + check <- paste0(o[,c(2:(ncol(o)-2))],collapse = '_') + } + if(check == varname){ + df <- rbind(df, cbind(co[i,], o) ) + } + } + assertthat::assert_that(nrow(df)>0, + msg = "Coefficient derivate not found for variable?") + # Split and get the derivative option + df <- split(df, df$V1) + assertthat::assert_that(length(df)==1, + msg = "Currently this works only for a single option.") + # Match + option <- match.arg(names(df), c('hinge', 'thresh', 'bin'), + several.ok = FALSE) + + # Get first entry (only one) + o <- df[[1]] + + # Get lowest and highest values from all positive coefficients + if(utils::hasName(o, "Beta")) { + ind <- which(o$Beta>0) + if(length(ind)==0){ + message("Only negative coefficients found...") + return(NULL) + } + } else { + message("Unpredictable territory. Function has been created for linear coefficients...") + # No Beta found. Simply take all values here + ind <- 1:nrow(o) + } + + # Get all valid values + vals <- suppressWarnings( + o[ind, c(ncol(o)-1,ncol(o))] |> base::unlist() |> + as.numeric() + ) + assertthat::assert_that(!all(is.na(vals)), + msg = "No valid values found in variable names?") + + if(option %in% c("bin", "thresh")){ + # These are simply thresholds so within the range + if(option == "thresh"){ + lb <- o[, ncol(o)] |> as.numeric() |> min() + + # Small helper function + do <- function(z, lb){ + z[zub] <- 0 + return(z) + } + + # Create output + if(inherits(env, "stars")){ + out <- stars_to_raster(env[varname]) + out <- lapply(out, function(z) do(z, lb, ub)) + } else { + out <- env[[varname]] + out <- do(out, lb, ub) + } + } + + } else if (option == "hinge") { + # Here it gets a bit more tricky as the hinge transformations need to be reproduced + out <- terra::rast() + for(i in 1:nrow(o[ind, c(ncol(o)-1,ncol(o))])){ + new <- emptyraster(env) + cu <- c( o[ind, c(ncol(o)-1,ncol(o))][i,1], o[ind, c(ncol(o)-1,ncol(o))][i,2] ) + # Remove any leading points + if(any(substr(cu,1, 1)==".")){ + cu[which(substr(cu,1, 1)==".")] <- gsub("^.","",cu[which(substr(cu,1, 1)==".")]) + } + cu <- as.numeric(cu) + + new[] <- hingeval(env[[varname]][],cu[1], cu[2]) + names(new) <- o$Feature[ind][i] + suppressWarnings(out <- c(out, new)) + rm(new) + } + # Now for the spatial mask, simply take the minimum + out <- min(out) + + } else { + stop("Not yet implemented") + } + + # For stars derived lists, reduce back to raster + if(is.list(out)){ + out <- Reduce("c",out) + } + + # Return binary layer or subset + if(to_binary){ + out[out!=0] <- 1 + } + + assertthat::assert_that(is.Raster(out), + ifelse(is.Raster(out), + terra::hasValues(out), + terra::hasValues(out[[1]]))) + return(out) +} + #### Filter predictor functions ---- #' Filter a set of correlated predictors to fewer ones diff --git a/man/nicheplot.Rd b/man/nicheplot.Rd index 5b430bf1..33a364bd 100644 --- a/man/nicheplot.Rd +++ b/man/nicheplot.Rd @@ -55,7 +55,7 @@ should be written to.} \item{title}{Allows to respecify the title through a \code{\link{character}} (Default: \code{NULL}).} -\item{pal}{A \code{\link{vector}} with continious colours with viridis plasma by default (Default: \code{NULL}).} +\item{pal}{An optional \code{\link{vector}} with continuous custom colours (Default: \code{NULL}).} \item{...}{Other engine specific parameters.} } diff --git a/man/predictor_derivate.Rd b/man/predictor_derivate.Rd index a96f45e3..ac5df5d1 100644 --- a/man/predictor_derivate.Rd +++ b/man/predictor_derivate.Rd @@ -18,7 +18,8 @@ predictor_derivate( \item{env}{A \code{\link{SpatRaster}} object.} \item{option}{A \code{\link{vector}} stating whether predictors should be preprocessed in any -way (Options: \code{'none'}, \code{'quadratic'}, \code{'hinge'}, \code{'thresh'}, \code{'bin'}).} +way (Options: \code{'none'}, \code{'quadratic'}, \code{'hinge'}, +\code{'kmeans'}, \code{'thresh'}, \code{'bin'}).} \item{nknots}{The number of knots to be used for the transformation (Default: \code{4}).} @@ -73,6 +74,10 @@ new derivates is specified via the parameter \code{'nknots'} (Default: \code{4}) new <- predictor_derivate(r_ori, option = "hinge", knots = 4) terra::plot(new) +# Or a quadratic transformation +new2 <- predictor_derivate(r_ori, option = "quad", knots = 4) +terra::plot(new2) + } \seealso{ predictor_transform From 7ca9bc0b719317ef9f3f5f8fe4e0c40117c70464 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 17 Oct 2024 16:12:57 +0200 Subject: [PATCH 13/21] Slacking package and moving this to `insights` --- R/utils-predictors.R | 201 ------------------------------------------- 1 file changed, 201 deletions(-) diff --git a/R/utils-predictors.R b/R/utils-predictors.R index 5782c0db..888d24ed 100644 --- a/R/utils-predictors.R +++ b/R/utils-predictors.R @@ -1036,207 +1036,6 @@ makeBin <- function(v, n, nknots, cutoffs = NULL){ return(out) } -#' Recreate a derivative variable based on their range -#' -#' @description -#' The purpose of this function is to create the range from several derivative -#' variables. The information to do so is taken from the variable name and it -#' is assumed that those have been created by [`predictor_derivate()`] function. -#' -#' This function return the range of values from the original data that fall within -#' the set of coefficients. Currently only positive coefficients are taken by default. -#' -#' @details -#' * This function really only makes sense for \code{'bin'}, \code{'thresh'} and -#' \code{'hinge'} transformations. -#' -#' * For \code{'hinge'} the combined \code{min} is returned. -#' -#' @note -#' This is rather an internal function created for a specific use and project. It -#' might be properly described in an example later. -#' -#' @param env The original variable stacks as [`SpatRaster`] or [`stars`]. -#' @param varname A [`character`] of the variable name. Needs to be present in -#' \code{"env"}. -#' @param co A set of coefficients obtained via [`stats::coef()`] and a -#' [`BiodiversityDistribution`] object. -#' @param to_binary A [`logical`] flag if the output should be converted to binary -#' format or left in the original units (Default: \code{FALSE}). -#' -#' @returns A [`SpatRaster`] object containing the predictor range. -#' @examples -#' \dontrun{ -#' # Assuming derivates of temperatue have been created for a model, this -#' # recreates the range over which they apply. -#' deriv <- create_derivate_range(env, varname = "Temperature", -#' co = coef(fit), to_binary = TRUE) -#' } -#' -#' @author Martin Jung -#' @keywords internal, utils -#' @noRd -create_derivate_range <- function(env, varname, co, to_binary = FALSE){ - assertthat::assert_that( - is.Raster(env) || inherits(env, "stars"), - is.character(varname) && length(varname)==1, - is.data.frame(co) || is.character(co), - is.logical(to_binary) - ) - - if(is.data.frame(co)){ - if(nrow(co)==0) { - message("No valid coefficients found?") - return(NULL) - } - } - if(!(varname %in% names(env))){ - message("Variable not found in environmental stack!") - return(NULL) - } - # --- # - - # Get the deriv names from the coefficients - # If character is supplied, assume those are all positive. - if(is.character(co)){ - co <- data.frame(Feature = co, Beta = 0.01) - } - deriv <- co[,1] - if(is.data.frame(deriv)) deriv <- deriv[[1]] # For Tibble - - # Now split the names use base R - cu <- base::strsplit(deriv, "_") - df <- data.frame() - for(i in 1:length(cu)){ # Number of derivs - o <- as.data.frame(cu[[i]] |> t()) - # Also check for actual variable coverage - if(o[1,1] %in% c("thresh")){ - # FIXME: Why does this use points rather than _ ? - check <- paste0(o[,c(2:(ncol(o)-1))],collapse = '_') - } else { - check <- paste0(o[,c(2:(ncol(o)-2))],collapse = '_') - } - if(check == varname){ - df <- rbind(df, cbind(co[i,], o) ) - } - } - assertthat::assert_that(nrow(df)>0, - msg = "Coefficient derivate not found for variable?") - # Split and get the derivative option - df <- split(df, df$V1) - assertthat::assert_that(length(df)==1, - msg = "Currently this works only for a single option.") - # Match - option <- match.arg(names(df), c('hinge', 'thresh', 'bin'), - several.ok = FALSE) - - # Get first entry (only one) - o <- df[[1]] - - # Get lowest and highest values from all positive coefficients - if(utils::hasName(o, "Beta")) { - ind <- which(o$Beta>0) - if(length(ind)==0){ - message("Only negative coefficients found...") - return(NULL) - } - } else { - message("Unpredictable territory. Function has been created for linear coefficients...") - # No Beta found. Simply take all values here - ind <- 1:nrow(o) - } - - # Get all valid values - vals <- suppressWarnings( - o[ind, c(ncol(o)-1,ncol(o))] |> base::unlist() |> - as.numeric() - ) - assertthat::assert_that(!all(is.na(vals)), - msg = "No valid values found in variable names?") - - if(option %in% c("bin", "thresh")){ - # These are simply thresholds so within the range - if(option == "thresh"){ - lb <- o[, ncol(o)] |> as.numeric() |> min() - - # Small helper function - do <- function(z, lb){ - z[zub] <- 0 - return(z) - } - - # Create output - if(inherits(env, "stars")){ - out <- stars_to_raster(env[varname]) - out <- lapply(out, function(z) do(z, lb, ub)) - } else { - out <- env[[varname]] - out <- do(out, lb, ub) - } - } - - } else if (option == "hinge") { - # Here it gets a bit more tricky as the hinge transformations need to be reproduced - out <- terra::rast() - for(i in 1:nrow(o[ind, c(ncol(o)-1,ncol(o))])){ - new <- emptyraster(env) - cu <- c( o[ind, c(ncol(o)-1,ncol(o))][i,1], o[ind, c(ncol(o)-1,ncol(o))][i,2] ) - # Remove any leading points - if(any(substr(cu,1, 1)==".")){ - cu[which(substr(cu,1, 1)==".")] <- gsub("^.","",cu[which(substr(cu,1, 1)==".")]) - } - cu <- as.numeric(cu) - - new[] <- hingeval(env[[varname]][],cu[1], cu[2]) - names(new) <- o$Feature[ind][i] - suppressWarnings(out <- c(out, new)) - rm(new) - } - # Now for the spatial mask, simply take the minimum - out <- min(out) - - } else { - stop("Not yet implemented") - } - - # For stars derived lists, reduce back to raster - if(is.list(out)){ - out <- Reduce("c",out) - } - - # Return binary layer or subset - if(to_binary){ - out[out!=0] <- 1 - } - - assertthat::assert_that(is.Raster(out), - ifelse(is.Raster(out), - terra::hasValues(out), - terra::hasValues(out[[1]]))) - return(out) -} - #### Filter predictor functions ---- #' Filter a set of correlated predictors to fewer ones From 7a5875369a7a369e1526de02ff452ccef288cdde Mon Sep 17 00:00:00 2001 From: Martin Jung <3788377+Martin-Jung@users.noreply.github.com> Date: Tue, 29 Oct 2024 13:57:21 +0100 Subject: [PATCH 14/21] Update train.R Changed 0 to NA by default here --- R/train.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/train.R b/R/train.R index 7be713ef..f84abb0e 100644 --- a/R/train.R +++ b/R/train.R @@ -1813,7 +1813,7 @@ methods::setMethod( o <- terra::mask(out$get_data("prediction"), layer) } else { # Default! Leaves rest of background to 0 - o <- terra::mask(out$get_data("prediction"), layer, updatevalue = 0) + o <- terra::mask(out$get_data("prediction"), layer, updatevalue = NA) } out <- out$set_data("prediction", o) try({ rm(layer, o) }) From e124d8bb355e9120b6873abc20b32dc1b154e825 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Tue, 29 Oct 2024 14:43:40 +0100 Subject: [PATCH 15/21] Fix issue with NA predictions --- R/train.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/train.R b/R/train.R index f84abb0e..b64dbb14 100644 --- a/R/train.R +++ b/R/train.R @@ -1820,6 +1820,10 @@ methods::setMethod( } out$settings$set("has_limits", TRUE) } else { + # set all NAs in prediction to NAs according in predictors + o <- terra::mask(out$get_data("prediction"), out$model$predictors_object$get_data()[[1]], + updatevalue = NA) + out <- out$set_data("prediction", o) out$settings$set("has_limits", FALSE) } From b4cf9bde2667a3a9111d428e49540b9041c64049 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Tue, 29 Oct 2024 16:17:32 +0100 Subject: [PATCH 16/21] Fixing CI and adding tryCatch to train masking --- R/train.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/R/train.R b/R/train.R index b64dbb14..5fbb168b 100644 --- a/R/train.R +++ b/R/train.R @@ -1820,10 +1820,14 @@ methods::setMethod( } out$settings$set("has_limits", TRUE) } else { + if(settings$get('inference_only')==FALSE){ # set all NAs in prediction to NAs according in predictors - o <- terra::mask(out$get_data("prediction"), out$model$predictors_object$get_data()[[1]], - updatevalue = NA) - out <- out$set_data("prediction", o) + o <- tryCatch(expr = {terra::mask(out$get_data("prediction"), out$model$predictors_object$get_data()[[1]], + updatevalue = NA)}, error = function(e) NA) + if (inherits(x = o, what = "SpatRaster")) { + if(terra::hasValues(o)) {out <- out$set_data("prediction", o)} else {warning("Issue while masking prediction")} + } else {warning("Issue while fetching predictors object")} + } out$settings$set("has_limits", FALSE) } From 534d69b0aa51397762de83fd319facd8fddc0269 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Wed, 30 Oct 2024 10:15:17 +0100 Subject: [PATCH 17/21] Fix issue with predictor NA cells for each engine due to predictor integration loop --- R/engine_bart.R | 3 +++ R/engine_breg.R | 3 +++ R/engine_gdb.R | 3 +++ R/engine_glm.R | 3 +++ R/engine_glmnet.R | 3 +++ R/engine_scampr.R | 3 +++ R/engine_stan.R | 4 ++++ R/engine_xgboost.R | 3 +++ R/train.R | 8 -------- 9 files changed, 25 insertions(+), 8 deletions(-) diff --git a/R/engine_bart.R b/R/engine_bart.R index 37e03d21..214f13d5 100644 --- a/R/engine_bart.R +++ b/R/engine_bart.R @@ -95,6 +95,9 @@ engine_bart <- function(x, # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Set up dbarts control with some parameters, rest default dc <- dbarts::dbartsControl(keepTrees = TRUE, # Keep trees n.burn = nburn, diff --git a/R/engine_breg.R b/R/engine_breg.R index 8719732a..be8c4ec9 100644 --- a/R/engine_breg.R +++ b/R/engine_breg.R @@ -81,6 +81,9 @@ engine_breg <- function(x, # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Set up the parameter list params <- list( iter = iter, diff --git a/R/engine_gdb.R b/R/engine_gdb.R index 0059d3bc..c537fbd2 100644 --- a/R/engine_gdb.R +++ b/R/engine_gdb.R @@ -103,6 +103,9 @@ engine_gdb <- function(x, # Burn in the background template <- terra::rasterize(background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Set up boosting control bc <- mboost::boost_control(mstop = iter, nu = learning_rate, diff --git a/R/engine_glm.R b/R/engine_glm.R index bcb163eb..fc52220f 100644 --- a/R/engine_glm.R +++ b/R/engine_glm.R @@ -90,6 +90,9 @@ engine_glm <- function(x, # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Specify default control if(is.null(control)){ control <- stats::glm.control() diff --git a/R/engine_glmnet.R b/R/engine_glmnet.R index 92d43a84..e10ab760 100644 --- a/R/engine_glmnet.R +++ b/R/engine_glmnet.R @@ -114,6 +114,9 @@ engine_glmnet <- function(x, # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Set up the parameter list params <- list( alpha = alpha, diff --git a/R/engine_scampr.R b/R/engine_scampr.R index ce70ae66..e3dedd1f 100644 --- a/R/engine_scampr.R +++ b/R/engine_scampr.R @@ -98,6 +98,9 @@ engine_scampr <- function(x, # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Set up the parameter list params <- list( type = type, diff --git a/R/engine_stan.R b/R/engine_stan.R index a6687392..d178eeb1 100644 --- a/R/engine_stan.R +++ b/R/engine_stan.R @@ -113,9 +113,13 @@ engine_stan <- function(x, # If predictor existing, use them template <- emptyraster(x$predictors$get_data() ) } + # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Define new engine object of class eg <- Engine diff --git a/R/engine_xgboost.R b/R/engine_xgboost.R index 79c427a5..63c0479d 100644 --- a/R/engine_xgboost.R +++ b/R/engine_xgboost.R @@ -115,6 +115,9 @@ engine_xgboost <- function(x, # Burn in the background template <- terra::rasterize(x$background, template, field = 0) + # mask template where all predictor layers are NA; change na.rm = FALSE for comeplete.cases + if (!is.Waiver(x$predictors)) template <- terra::mask(template, sum(x$predictors$get_data(), na.rm = TRUE)) + # Set up the parameter list params <- list( booster = booster, diff --git a/R/train.R b/R/train.R index 5fbb168b..f84abb0e 100644 --- a/R/train.R +++ b/R/train.R @@ -1820,14 +1820,6 @@ methods::setMethod( } out$settings$set("has_limits", TRUE) } else { - if(settings$get('inference_only')==FALSE){ - # set all NAs in prediction to NAs according in predictors - o <- tryCatch(expr = {terra::mask(out$get_data("prediction"), out$model$predictors_object$get_data()[[1]], - updatevalue = NA)}, error = function(e) NA) - if (inherits(x = o, what = "SpatRaster")) { - if(terra::hasValues(o)) {out <- out$set_data("prediction", o)} else {warning("Issue while masking prediction")} - } else {warning("Issue while fetching predictors object")} - } out$settings$set("has_limits", FALSE) } From 3bd181caa3f39de29068a9b24864a52eda5ed70f Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Wed, 30 Oct 2024 11:50:40 +0100 Subject: [PATCH 18/21] Added `predictor_check()` function to exclude faulty variables --- R/train.R | 6 ++-- R/utils-predictors.R | 72 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 2 deletions(-) diff --git a/R/train.R b/R/train.R index f84abb0e..1f799799 100644 --- a/R/train.R +++ b/R/train.R @@ -516,12 +516,14 @@ methods::setMethod( # select only columns needed by equation if (model$biodiversity[[id]]$equation != "") { - env <- subset(env, select = c("ID", "x", "y", attr(stats::terms.formula(model$biodiversity[[id]]$equation), "term.labels"))) - } + # Check for common issues and exclude variables if affected (could be outsourced) + # --- Variance check --- + env <- predictor_check(env) + # Remove missing values as several engines can't deal with those easily miss <- stats::complete.cases(env) if(sum( !miss )>0 && getOption('ibis.setupmessages', default = TRUE)) { diff --git a/R/utils-predictors.R b/R/utils-predictors.R index 888d24ed..afb51cdb 100644 --- a/R/utils-predictors.R +++ b/R/utils-predictors.R @@ -1036,6 +1036,78 @@ makeBin <- function(v, n, nknots, cutoffs = NULL){ return(out) } +#### Check predictors ---- + +#' Helper function to check extracted predictors for issues +#' @description +#' Here we check the variables in a provided [`data.frame`] for known issues. +#' Note that this is done vertically (per column) and not horizontally (thus removing observations). +#' +#' If any of the conditions are satistified the entire predictor is removed from the model! +#' @details +#' Specifically checked are: +#' [*] Whether all values in a column are \code{NA}. +#' [*] Whether all values in a column are finite. +#' [*] Whether the variance of all variables is greater than 0. +#' +#' @param env A [`data.frame`] with all predictor variables. +#' @return A [`data.frame`] potentially with any variable names excluded. If the +#' function fails due to some reason it returns the original \code{env}. +#' +#' @keywords utils +#' +#' @examples +#' \dontrun{ +#' # Remove highly correlated predictors +#' env <- predictor_check( env ) +#' } +#' @author Martin Jung +#' @noRd +predictor_check <- function(env){ + assertthat::assert_that( + is.data.frame(env) + ) + # Dummy copy + dummy <- env + + # Check NaN + check_nan <- apply(env, 2, function(z) all(is.nan(z))) + if(any(check_nan)){ + if(getOption('ibis.setupmessages', default = TRUE)) { + myLog('[Setup]','yellow', 'Excluded ', paste0(names(which(check_nan)),collapse = "; "), + ' variables owing to exclusively NA data!' ) + } + env <- env |> dplyr::select(-dplyr::any_of(names(which(check_nan)))) + } + + # Check inifinites + check_infinite <- apply(env, 2, function(z) any( is.infinite(z) ) ) + if(any(check_infinite)){ + if(getOption('ibis.setupmessages', default = TRUE)) { + myLog('[Setup]','yellow', 'Excluded ', paste0(names(which(check_infinite)),collapse = "; "), + ' variables owing to observations with infinite values!' ) + } + env <- env |> dplyr::select(-dplyr::any_of(names(which(check_infinite)))) + } + + # Check variance + check_var <- apply(env, 2, function(z) var(z, na.rm = TRUE)) == 0 + if(any(check_var)){ + if(getOption('ibis.setupmessages', default = TRUE)) { + myLog('[Setup]','yellow', 'Excluded ', paste0(names(which(check_var)),collapse = "; "), + ' variables owing to zero variance!' ) + } + env <- env |> dplyr::select(-dplyr::any_of(names(which(check_var)))) + } + + # Check whether all columns have been removed, if so revert back for safety? + if(ncol(env)==0) env <- dummy + rm(dummy) + + # Return + return(env) +} + #### Filter predictor functions ---- #' Filter a set of correlated predictors to fewer ones From 2c09250a522a193ff954f6cabc76e8c8c37a272c Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Wed, 30 Oct 2024 12:54:10 +0100 Subject: [PATCH 19/21] Fix NA cell issue for xgboost projections --- R/engine_xgboost.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/engine_xgboost.R b/R/engine_xgboost.R index 63c0479d..ff19e72a 100644 --- a/R/engine_xgboost.R +++ b/R/engine_xgboost.R @@ -875,7 +875,8 @@ engine_xgboost <- function(x, if(nrow(newdata)==nrow(model$predictors)){ prediction <- try({model_to_background(model)}, silent = TRUE) prediction[] <- pred_xgb - prediction <- terra::mask(prediction, model$background) + mask_tmp <- sum(terra::rast(newdata_copy, crs = terra::crs(prediction))) + prediction <- terra::mask(prediction, mask_tmp) # make sure to only use nonNA cells } else { assertthat::assert_that(utils::hasName(newdata_copy,"x")&&utils::hasName(newdata_copy,"y"), msg = "Projection data.frame has no valid coordinates or differs in grain!") From b2b6dbdc4ca5dfdadc7c92c9f798a115f5b3e5b9 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Tue, 5 Nov 2024 10:26:17 +0100 Subject: [PATCH 20/21] Fix issue with sorting of predictor_types --- R/train.R | 37 ++++++++++++++++++++++++++++--------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/R/train.R b/R/train.R index 1f799799..8319f603 100644 --- a/R/train.R +++ b/R/train.R @@ -604,7 +604,10 @@ methods::setMethod( model[['biodiversity']][[id]][['predictors']] <- env model[['biodiversity']][[id]][['predictors_names']] <- names(env)[names(env) %notin% c("ID", "x", "y", "Intercept")] model[['biodiversity']][[id]][['predictors_types']] <- model[['predictors_types']][model[['predictors_types']][, "predictors"] %in% names(env), ] - } + # makes sure ordering is identical + sort_id <- match(model[['biodiversity']][[id]][['predictors_names']], model[['biodiversity']][[id]][['predictors_types']]$predictors) + model[['biodiversity']][[id]][['predictors_types']] <- model[['biodiversity']][[id]][['predictors_types']][sort_id, ] + } # If the method of integration is weights and there are more than 2 datasets, combine if(method_integration == "weight" && length(model$biodiversity)>=2){ @@ -914,7 +917,9 @@ methods::setMethod( pred_prs <- model$predictors_object$get_names() model$predictors_names <- pred_tmp model$predictors_types <- model$predictors_types[model$predictors_type$predictors %in% pred_tmp, ] - model$predictors <- model$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model$predictors_types <- model$predictors_types[match(model$predictors_names, model$predictors_types$predictors), ] + model$predictors <- dplyr::select(model$predictors, dplyr::any_of(c("x", "y", pred_tmp))) model$predictors_object <- model$predictors_object$clone(deep = TRUE) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) @@ -956,7 +961,9 @@ methods::setMethod( pred_prs <- model$predictors_object$get_names() model$predictors_names <- pred_tmp model$predictors_types <- model$predictors_types[model$predictors_type$predictors %in% pred_tmp, ] - model$predictors <- model$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model$predictors_types <- model$predictors_types[match(model$predictors_names, model$predictors_types$predictors), ] + model$predictors <- dplyr::select(model$predictors, dplyr::any_of(c("x", "y", pred_tmp))) model$predictors_object <- model$predictors_object$clone(deep = TRUE) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) @@ -990,7 +997,9 @@ methods::setMethod( model2$predictors_object <- model$predictors_object$clone(deep = TRUE) model2$predictors_names <- pred_tmp model2$predictors_types <- model2$predictors_types[model2$predictors_type$predictors %in% pred_tmp, ] - model2$predictors <- model2$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model2$predictors_types <- model2$predictors_types[match(model2$predictors_names, model2$predictors_types$predictors), ] + model2$predictors <- dplyr::select(model2$predictors, dplyr::any_of(c("x", "y", pred_tmp))) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model2$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) } @@ -1121,7 +1130,9 @@ methods::setMethod( model2$predictors_object <- model$predictors_object$clone(deep = TRUE) model2$predictors_names <- pred_tmp model2$predictors_types <- model2$predictors_types[model2$predictors_type$predictors %in% pred_tmp, ] - model2$predictors <- model2$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model2$predictors_types <- model2$predictors_types[match(model2$predictors_names, model2$predictors_types$predictors), ] + model2$predictors <- dplyr::select(model2$predictors, dplyr::any_of(c("x", "y", pred_tmp))) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model2$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) } @@ -1251,7 +1262,9 @@ methods::setMethod( model2$predictors_object <- model$predictors_object$clone(deep = TRUE) model2$predictors_names <- pred_tmp model2$predictors_types <- model2$predictors_types[model2$predictors_type$predictors %in% pred_tmp, ] - model2$predictors <- model2$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model2$predictors_types <- model2$predictors_types[match(model2$predictors_names, model2$predictors_types$predictors), ] + model2$predictors <- dplyr::select(model2$predictors, dplyr::any_of(c("x", "y", pred_tmp))) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model2$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) } @@ -1405,7 +1418,9 @@ methods::setMethod( model2$predictors_object <- model$predictors_object$clone(deep = TRUE) model2$predictors_names <- pred_tmp model2$predictors_types <- model2$predictors_types[model2$predictors_type$predictors %in% pred_tmp, ] - model2$predictors <- model2$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model2$predictors_types <- model2$predictors_types[match(model2$predictors_names, model2$predictors_types$predictors), ] + model2$predictors <- dplyr::select(model2$predictors, dplyr::any_of(c("x", "y", pred_tmp))) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model2$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) } @@ -1531,7 +1546,9 @@ methods::setMethod( model2$predictors_object <- model$predictors_object$clone(deep = TRUE) model2$predictors_names <- pred_tmp model2$predictors_types <- model2$predictors_types[model2$predictors_type$predictors %in% pred_tmp, ] - model2$predictors <- model2$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model2$predictors_types <- model2$predictors_types[match(model2$predictors_names, model2$predictors_types$predictors), ] + model2$predictors <- dplyr::select(model2$predictors, dplyr::any_of(c("x", "y", pred_tmp))) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model2$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) } @@ -1659,7 +1676,9 @@ methods::setMethod( model2$predictors_object <- model$predictors_object$clone(deep = TRUE) model2$predictors_names <- pred_tmp model2$predictors_types <- model2$predictors_types[model2$predictors_type$predictors %in% pred_tmp, ] - model2$predictors <- model2$predictors |> dplyr::select(dplyr::any_of(c("x", "y", pred_tmp))) + # make sure all in same order + model2$predictors_types <- model2$predictors_types[match(model2$predictors_names, model2$predictors_types$predictors), ] + model2$predictors <- dplyr::select(model2$predictors, dplyr::any_of(c("x", "y", pred_tmp))) if (length(pred_prs[!pred_prs %in% pred_tmp]) > 0){ model2$predictors_object$rm_data(pred_prs[!pred_prs %in% pred_tmp]) } From 6875ffcc77298149bc0b7bc17ada94e50f5d371f Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 7 Nov 2024 20:29:33 +0100 Subject: [PATCH 21/21] Small helper function for object size and validation fixes --- NAMESPACE | 2 + R/utils.R | 105 ++++++++++++++++++++++++++++++++++++++++++++ R/validate.R | 16 +++++-- _pkgdown.yml | 1 + man/objects_size.Rd | 36 +++++++++++++++ 5 files changed, 157 insertions(+), 3 deletions(-) create mode 100644 man/objects_size.Rd diff --git a/NAMESPACE b/NAMESPACE index 0f685e84..36c99004 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -126,6 +126,7 @@ export(modal) export(new_id) export(new_waiver) export(nicheplot) +export(objects_size) export(partial) export(partial.DistributionModel) export(partial_density) @@ -172,3 +173,4 @@ import(terra) importFrom(foreach,"%do%") importFrom(foreach,"%dopar%") importFrom(stats,effects) +importFrom(utils,object.size) diff --git a/R/utils.R b/R/utils.R index 3ff76625..91c408a5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -632,3 +632,108 @@ collect_occurrencepoints <- function(model, include_absences = FALSE, } return(locs) } + +#' @title Shows size of objects in the R environment +#' @description Shows the size of the objects currently in the R environment. +#' Helps to locate large objects cluttering the R environment and/or +#' causing memory problems during the execution of large workflows. +#' +#' @param n Number of objects to show, Default: `10` +#' @return A data frame with the row names indicating the object name, +#' the field 'Type' indicating the object type, 'Size' indicating the object size, +#' and the columns 'Length/Rows' and 'Columns' indicating the object dimensions if applicable. +#' +#' @examples +#' if(interactive()){ +#' +#' #creating dummy objects +#' x <- matrix(runif(100), 10, 10) +#' y <- matrix(runif(10000), 100, 100) +#' +#' #reading their in-memory size +#' objects_size() +#' +#' } +#' @author Bias Benito +#' @rdname objects_size +#' @importFrom utils object.size +#' @export +objects_size <- function(n = 10) { + + .ls.objects <- function ( + pos = 1, + pattern, + order.by, + decreasing=FALSE, + head=FALSE, + n=5 + ){ + + napply <- function(names, fn) sapply( + names, + function(x) fn(get(x, pos = pos)) + ) + + names <- ls( + pos = pos, + pattern = pattern + ) + + obj.class <- napply( + names, + function(x) as.character(class(x))[1] + ) + + obj.mode <- napply( + names, + mode + ) + + obj.type <- ifelse( + is.na(obj.class), + obj.mode, + obj.class + ) + + obj.prettysize <- napply( + names, + function(x) {format(utils::object.size(x), units = "auto") } + ) + + obj.size <- napply( + names, + object.size + ) + + obj.dim <- t( + napply( + names, + function(x)as.numeric(dim(x))[1:2] + ) + ) + + vec <- is.na(obj.dim)[, 1] & (obj.type != "function") + + obj.dim[vec, 1] <- napply(names, length)[vec] + + out <- data.frame( + obj.type, + obj.prettysize, + obj.dim + ) + names(out) <- c("Type", "Size", "Length/Rows", "Columns") + if (!missing(order.by)) + out <- out[order(out[[order.by]], decreasing=decreasing), ] + if (head) + out <- head(out, n) + out + } + + .ls.objects( + order.by = "Size", + decreasing=TRUE, + head=TRUE, + n=n + ) + +} diff --git a/R/validate.R b/R/validate.R index 2d89f124..9a2d9c39 100644 --- a/R/validate.R +++ b/R/validate.R @@ -426,6 +426,10 @@ methods::setMethod( return(results) } + # R2 score + R2_Score <- function(pred, obs, na.rm = TRUE) { + return( 1 - sum((obs - pred)^2,na.rm = na.rm)/sum((obs - mean(obs,na.rm = na.rm))^2,na.rm = na.rm) ) + } # Function for Root-mean square error RMSE <- function(pred, obs, na.rm = TRUE) { sqrt(mean((pred - obs)^2, na.rm = na.rm)) @@ -434,6 +438,10 @@ methods::setMethod( MAE <- function(pred, obs, na.rm = TRUE) { mean(abs(pred - obs), na.rm = na.rm) } + # Mean Absolute Percentage Error Loss + MAPE <- function(pred, obs, na.rm = TRUE){ + mean(abs((obs - pred)/obs), na.rm = TRUE) + } # Function for log loss/cross-entropy loss. Poisson_LogLoss <- function(y_pred, y_true) { eps <- 1e-15 @@ -458,21 +466,23 @@ methods::setMethod( modelid = id, name = name, method = method, - metric = c('n','rmse', 'mae', + metric = c('n', 'r2', 'rmse', 'mae', 'mape', 'logloss','normgini', 'cont.boyce'), value = NA ) # - # out$value[out$metric=='n'] <- nrow(df2) # Number of records + out$value[out$metric=='r2'] <- R2_Score(pred = df2$pred, obs = df2[[point_column]]) # R2 out$value[out$metric=='rmse'] <- RMSE(pred = df2$pred, obs = df2[[point_column]]) # RMSE out$value[out$metric=='mae'] <- MAE(pred = df2$pred, obs = df2[[point_column]]) # Mean absolute error + out$value[out$metric=='mape'] <- MAPE(pred = df2$pred, obs = df2[[point_column]]) # Mean Absolute Percentage Error Loss out$value[out$metric=='normgini'] <- NormalizedGini(y_pred = df2$pred, y_true = df2[[point_column]]) if(!is.null(mod)){ if( any( sapply(mod$model$biodiversity, function(x) x$family) == "binomial" ) ){ - LogLoss <- function(y_pred, y_true) { - y_pred <- pmax(y_pred, 1e-15) + LogLoss <- function(y_pred, y_true, eps = 1e-15) { + y_pred <- pmax(pmin(y_pred, 1 - eps), eps) LogLoss <- -mean(y_true * log(y_pred) + (1 - y_true) * log(1 - y_pred)) return(LogLoss) } diff --git a/_pkgdown.yml b/_pkgdown.yml index d9e5dd68..8a7f075b 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -136,6 +136,7 @@ reference: - predictor_derivate - predictor_filter - interpolate_gaps + - objects_size - run_stan - wrap_stanmodel - sanitize_names diff --git a/man/objects_size.Rd b/man/objects_size.Rd new file mode 100644 index 00000000..e98d5662 --- /dev/null +++ b/man/objects_size.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{objects_size} +\alias{objects_size} +\title{Shows size of objects in the R environment} +\usage{ +objects_size(n = 10) +} +\arguments{ +\item{n}{Number of objects to show, Default: \code{10}} +} +\value{ +A data frame with the row names indicating the object name, +the field 'Type' indicating the object type, 'Size' indicating the object size, +and the columns 'Length/Rows' and 'Columns' indicating the object dimensions if applicable. +} +\description{ +Shows the size of the objects currently in the R environment. +Helps to locate large objects cluttering the R environment and/or +causing memory problems during the execution of large workflows. +} +\examples{ +if(interactive()){ + + #creating dummy objects + x <- matrix(runif(100), 10, 10) + y <- matrix(runif(10000), 100, 100) + + #reading their in-memory size + objects_size() + +} +} +\author{ +Bias Benito +}