From 14b2e52790a0be65fe7e98d54164e2ab3f19bbf3 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Fri, 10 Nov 2023 16:08:47 +0100 Subject: [PATCH 01/20] Bug fixed and minor improvments to thin_observations --- DESCRIPTION | 6 +- NEWS.md | 7 +- R/utils-spatial.R | 311 +++++++++++------- man/thin_observations.Rd | 31 +- tests/testthat/test_functions.R | 14 +- .../articles/01_data_preparationhelpers.Rmd | 4 +- 6 files changed, 234 insertions(+), 139 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5933fb2b..39b0b740 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.0 +Version: 0.1.1 Authors@R: c(person(given = "Martin", family = "Jung", @@ -72,7 +72,9 @@ Suggests: geosphere, cubelyr, testthat (>= 3.0.0), - xgboost + xgboost, + spatstat.geom, + spatstat.explore URL: https://iiasa.github.io/ibis.iSDM/ BugReports: https://github.com/iiasa/ibis.iSDM/issues RoxygenNote: 7.2.3 diff --git a/NEWS.md b/NEWS.md index 157f7767..733a6ff4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,9 @@ -# ibis.iSDM 0.1.0 (current dev branch) +# ibis.iSDM 0.1.1 (current dev branch) + +#### Minor improvements and bug fixes +* Several bug fixes in `thin_observations` and `global` argument for bias-method + +# ibis.iSDM 0.1.0 #### New features * Added a small convenience wrapper to add model outputs to another model `add_predictors_model()` diff --git a/R/utils-spatial.R b/R/utils-spatial.R index 46f1457f..61314480 100644 --- a/R/utils-spatial.R +++ b/R/utils-spatial.R @@ -1224,15 +1224,20 @@ explode_factorized_raster <- function(ras, name = NULL){ #' effectively removes data prior to any estimation and its use should be #' considered with care (see also Steen et al. 2021). #' -#' @details Currently implemented thinning methods: +#' @details #' -#' * \code{"random"}: Samples at random up to number of \code{"minpoints"} across all occupied grid cells. -#' Does not account for any spatial or environmental distance between -#' observations. -#' * \code{"bias"}: This option removed explicitly points that are considered biased (parameter \code{"env"}) only. -#' Points are preferentially thinned from grid cells which are in the 25% most -#' biased (larger values assumed greater bias) and have high point density. -#' Thins the observations up to \code{"minpoints"}. +#' All methods only remove points from "over-sampled" grid cells/areas. These are +#' defined as all cells/area which either have more points than \code{minpoints} or +#' more points than the global minimum point count per cell (whichever is larger). +#' +#' Currently implemented thinning methods: +#' +#' * \code{"random"}: Samples at random across all over-sampled grid cells returning +#' at minimum \code{"minpoints"} . +#' Does not account for any spatial or environmental distance between observations. +#' * \code{"bias"}: This option removes explicitly points that are considered biased (parameter \code{"env"}) only. +#' Points are only thinned from grid cells which are above the bias quantile (larger values +#' equals greater bias). Thins the observations up to \code{"minpoints"}. #' * \code{"zones"}: Assesses for each observation that it falls with a maximum of \code{"minpoints"} into #' each occupied zone. Careful: If the zones are relatively wide this can #' remove quite a few observations. @@ -1244,7 +1249,7 @@ explode_factorized_raster <- function(ras, name = NULL){ #' iteratively until the minimum distance between points is crossed. The #' \code{"mindistance"} parameter has to be set for this function to work. #' -#' @param df A [`sf`] or [`data.frame`] object with observed occurrence points. +#' @param data A [`sf`] object with observed occurrence points. #' All methods threat presence-only and presence-absence occurrence points #' equally. #' @param background A [`SpatRaster`] object with the background of the study @@ -1255,11 +1260,18 @@ explode_factorized_raster <- function(ras, name = NULL){ #' @param method A [`character`] of the method to be applied (Default: #' \code{"random"}). #' @param minpoints A [`numeric`] giving the number of data points at minimum to -#' take (Default: \code{10}). +#' remain (Default: \code{10}). #' @param mindistance A [`numeric`] for the minimum distance of neighbouring #' observations (Default: \code{NULL}). -#' @param zones A [`SpatRaster`] to be supplied when option \code{"method"} is +#' @param zones A [`SpatRaster`] to be supplied when option \code{"zones"} is #' chosen (Default: \code{NULL}). +#' @param probs A [`numeric`] used as quantile threshold in \code{"bias"} method. +#' (Default: \code{0.75}). +#' @param global A [`logical`] if during \code{"bias"} method global or local, extracted +#' bias values are used as threshold. (Default: \code{TRUE}). +#' @param centers A [`numeric`] used as number of centers for \code{"environmental"} method. +#' (Default: \code{NULL}). If not set, automatically set to three or nlayers - 1 (whatever +#' is bigger). #' @param verbose [`logical`] of whether to print some statistics about the #' thinning outcome (Default: \code{TRUE}). #' @examples @@ -1276,207 +1288,272 @@ explode_factorized_raster <- function(ras, name = NULL){ #' * Steen, V. A., Tingley, M. W., Paton, P. W., & Elphick, C. S. (2021). Spatial thinning and class balancing: Key choices lead to variation in the performance of species distribution models with citizen science data. Methods in Ecology and Evolution, 12(2), 216-226. #' @keywords utils #' @export -thin_observations <- function(df, background, env = NULL, method = "random", minpoints = 10, mindistance = NULL, - zones = NULL, verbose = TRUE){ +thin_observations <- function(data, background, env = NULL, method = "random", minpoints = 10, mindistance = NULL, + zones = NULL, probs = 0.75, global = TRUE, centers = NULL, verbose = TRUE){ assertthat::assert_that( - inherits(df, "sf") || inherits(df, "data.frame"), - nrow(df) > 0, + inherits(data, "sf"), + nrow(data) > 0, is.Raster(background), is.Raster(env) || is.null(env), is.character(method), is.numeric(minpoints) && minpoints > 0, is.null(mindistance) || is.numeric(mindistance), - is.Raster(zones) || is.null(zones) + (is.Raster(zones) && is.factor(zones)) || is.null(zones), + is.numeric(probs) && probs > 0 && probs < 1 && length(probs)==1, + is.logical(global), + is.null(centers) || is.numeric(centers) ) check_package("dplyr") # Match method method <- match.arg(method, choices = c("random", "spatial", "bias", "environmental", "zones"), several.ok = FALSE) - # Label background with id - bg <- background - bg[] <- 1:terra::ncell(bg) - bg <- terra::mask(bg, background) - - # Check that environment has the same projection - if(is.Raster(env) && method == "environmental"){ - assertthat::assert_that( terra::compareGeom(bg, env, stopOnError = FALSE) ) - } # Check that CRS is the same as background - if(sf::st_crs(df) != sf::st_crs(bg)){ + if(sf::st_crs(data) != sf::st_crs(background)){ message("Projection is different from input data. Reprojecting!") - df <- df |> sf::st_transform(crs = sf::st_crs(bg)) + data <- data |> sf::st_transform(crs = sf::st_crs(background)) } # Take coordinates of supplied data and rasterize - coords <- sf::st_coordinates( df ) - ras <- terra::rasterize(coords, bg) # Get the number of observations per grid cell + coords <- sf::st_coordinates(data) + ras <- terra::rasterize(coords, background, fun = sum) # Get the number of observations per grid cell - # Bounds for thining - totake <- c(lower = minpoints, upper = max( terra::global(ras, "min", na.rm = TRUE)[,1], minpoints)) + # Bounds for thinning + # MH: Would be nice if upper is either for cells (random, bias) or zones/cluster + totake <- c(lower = minpoints, upper = max(terra::global(ras, "min", na.rm = TRUE)[,1], minpoints)) # -- # if(method == "random"){ # For each unique grid cell id, get the minimum value up to a maximum of the # points by sampling at random from the occupied grid cells - # Output vector - sel <- vector() + # extract cell id for each point + ex <- cbind(id = 1:nrow(coords), + terra::extract(ras, coords, cell = TRUE)) - ex <- data.frame(id = 1:nrow(coords), - cid = terra::extract(bg, coords)[,1] - ) - ex <- subset(ex, stats::complete.cases(ex)) # Don't need missing points + # remove NA points + ex <- subset(ex, stats::complete.cases(ex)) - ex <- dplyr::left_join(ex, - ex |> dplyr::group_by(cid) |> dplyr::summarise(N = dplyr::n()), - by = "cid" - ) - # Points to take - sel <- append(sel, ex$id[which(ex$N <= min(totake))] ) + # Points to return + sel <- ex$id[which(ex$sum <= totake[["lower"]])] # For those where we have more than the minimum, take at random the upper # limits of observations - ex$oversampled <- ifelse(ex$N >= totake["upper"], 1, 0) - if(dplyr::n_distinct(ex$oversampled) > 1){ + ex$oversampled <- ifelse(ex$sum > totake[["upper"]], 1, 0) + if(sum(ex$oversampled) > 1){ # If there any oversampled # Now sample at random up to the maximum amount. - o <- ex |> dplyr::filter(oversampled == 1) |> - dplyr::group_by(cid) |> - dplyr::slice_sample(n = min(totake)) - if(nrow(o)>0) sel <- append(sel, o$id) - rm(o) + o <- dplyr::filter(ex, oversampled == 1) |> + dplyr::group_by(cell) |> + dplyr::slice_sample(n = totake[["lower"]]) + if(nrow(o) > 0) sel <- c(sel, o$id) } + if(anyDuplicated(sel)) sel <- unique(sel) + try({rm(o, ex)}, silent = TRUE) - try({rm(ex)},silent = TRUE) } else if(method == "bias"){ - assertthat::assert_that(is.Raster(env), - terra::nlyr(env)==1, + assertthat::assert_that(terra::nlyr(env)==1, msg = "Bias requires a single SpatRaster layer given to env.") - sel <- vector() - # Convert bias layer into percentile (largest being) - bias_perc <- terra::global(env, fun = quantile, na.rm = TRUE)[["X75."]] + # make sure name is known + names(env) <- "bias" # Now extract - ex <- data.frame(id = 1:nrow(coords), - cid = terra::extract(bg, coords)[,1], - pres = terra::extract(ras, coords)[,1], - bias = terra::extract(env, coords)[,1] - ) - ex <- subset(ex, stats::complete.cases(ex)) # Don't need missing points + ex <- cbind(id = 1:nrow(coords), + terra::extract(ras, coords, cells = TRUE), + terra::extract(env, coords)) + + # remove NA points + ex <- subset(ex, stats::complete.cases(ex)) + + # Points to return + sel <- ex$id[which(ex$sum <= totake[["lower"]])] + + # Convert bias layer into percentile (largest being) + if (global) { + bias_perc <- terra::global(env, fun = quantile, probs = probs, na.rm = TRUE)[,1] + } else { + bias_perc <- stats::quantile(ex$bias, probs = probs)[[1]] + } + # Now identify those to be thinned - ex$tothin <- ifelse((ex$bias >= bias_perc) & (ex$pres < totake[1]), 1, 0) + ex$tothin <- ifelse((ex$bias >= bias_perc) & (ex$sum > totake[["upper"]]), 1, 0) # Now thin those points that are to be thinned - if(length(unique(ex$tothin))>1){ - ss <- ex |> dplyr::filter(tothin == 1) |> - dplyr::group_by(cid) |> - dplyr::slice_sample(n = totake[1], weight_by = bias, replace = T) |> - dplyr::distinct() - - # Points to take - sel <- append(sel, ex$id[ex$tothin==0] ) - sel <- append(sel, ss$id ) - try({rm(ss, ex)},silent = TRUE) + if(sum(ex$tothin) > 1){ + o <- dplyr::filter(ex, tothin == 1) |> + dplyr::group_by(cell) |> + # MH: If grouped by cell the weight doesnt make sense cause all points have same value + dplyr::slice_sample(n = totake[["lower"]], weight_by = bias) + if(nrow(o) > 0) sel <- c(sel, o$id) } + if(anyDuplicated(sel)) sel <- unique(sel) + suppressWarnings(try({rm(o, ex)})) + } else if(method == "zones"){ # Thinning by zones - assertthat::assert_that(is.Raster(zones), - is.factor(zones)) + assertthat::assert_that(terra::nlyr(zones)==1) - if(!terra::compareGeom(bg, zones, stopOnError = FALSE)){ - zones <- alignRasters(zones, bg, method = "near", func = terra::modal, cl = FALSE) + if(!terra::compareGeom(background, zones, stopOnError = FALSE)){ + zones <- alignRasters(zones, background, method = "near", func = terra::modal, cl = FALSE) } - # Output vector - sel <- vector() + # make sure name is known + names(zones) <- "zone" - ex <- data.frame(id = 1:nrow(coords), - cid = terra::extract(bg, coords)[,1], - zones = terra::extract(zones, coords)[,1] - ) - # Now for each zone, take the minimum amount at random - ss <- ex |> - dplyr::group_by(zones) |> - dplyr::slice_sample(n = max(totake[1]), replace = TRUE) |> - dplyr::distinct() + # extract cell id and zones + ex <- cbind(id = 1:nrow(coords), + terra::extract(zones, coords, cells = TRUE)) - # Take the zone data points - sel <- append(sel, ss$id ) - try({rm(ss, ex)},silent = TRUE) + # remove NA points + ex <- subset(ex, stats::complete.cases(ex)) + + # count points per zone + ex <- dplyr::left_join(x = ex, y = dplyr::group_by(ex, zone) |> + dplyr::summarise(sum = dplyr::n()), + by = "zone") + + # Points to return + sel <- ex$id[which(ex$sum <= totake[["lower"]])] + + # Now identify those to be thinned + ex$tothin <- ifelse(ex$sum > totake[["upper"]], 1, 0) + if(sum(ex$tothin) > 1){ + o <- dplyr::filter(ex, tothin == 1) |> + dplyr::group_by(zone) |> + dplyr::slice_sample(n = totake[["lower"]]) + if(nrow(o) > 0) sel <- c(sel, o$id) + } + + if(anyDuplicated(sel)) sel <- unique(sel) + suppressWarnings(try({rm(o, ex)})) } else if(method == "environmental"){ # Environmental clustering - if(!terra::compareGeom(bg, env, stopOnError = FALSE)){ - env <- alignRasters(env, bg, method = "near", func = terra::modal, cl = FALSE) + if(!terra::compareGeom(background, env, stopOnError = FALSE)){ + env <- alignRasters(env, background, method = "near", func = terra::modal, cl = FALSE) } + # If there are any factors, explode if(any(is.factor(env))){ env <- explode_factorized_raster(env) } - # Output vector - sel <- vector() + # pick number of clusters automatically + if (is.null(centers)) centers <- max(3, terra::nlyr(env) - 1) # Get a matrix of all environmental data, also with coordinates # However first normalize all data stk <- terra::as.data.frame( predictor_transform(env, option = "norm"), - xy = TRUE) + xy = TRUE, cell = TRUE) - stk$cid <- 1:nrow(stk) stk <- subset(stk, stats::complete.cases(stk)) # Cluster - E <- stats::kmeans(x = subset(stk, select = -cid), - centers = ncol(stk)-1, iter.max = 50) + E <- stats::kmeans(x = subset(stk, select = -cell), + centers = centers, iter.max = 50) stk$cluster <- E$cluster # Now fill an empty raster and re-xtract new <- emptyraster(env) - new[stk$cid] <- stk$cluster + new[stk$cell] <- stk$cluster + names(new) <- "cluster" - # Now re-extract and sampling points - ex <- data.frame(id = 1:nrow(coords), - cid = terra::extract(bg, coords)[,1], - zones = terra::extract(new, coords)[,1] - ) + # extract cell id and zones + ex <- cbind(id = 1:nrow(coords), + terra::extract(new, coords, cells = TRUE)) - # Now for each zone, take the minimum amount at random - ss <- ex |> - dplyr::group_by(zones) |> - dplyr::slice_sample(n = max(totake[1]), replace = TRUE) |> - dplyr::distinct() + # remove NA points + ex <- subset(ex, stats::complete.cases(ex)) - # Take the zone data points - sel <- append(sel, ss$id ) + # count points per cluster + ex <- dplyr::left_join(x = ex, y = dplyr::group_by(ex, cluster) |> + dplyr::summarise(sum = dplyr::n()), + by = "cluster") + + # Points to return + sel <- ex$id[which(ex$sum <= totake[["lower"]])] + + # Now identify those to be thinned + ex$tothin <- ifelse(ex$sum > totake[["upper"]], 1, 0) + if(sum(ex$tothin) > 1){ + o <- dplyr::filter(ex, tothin == 1) |> + dplyr::group_by(cluster) |> + dplyr::slice_sample(n = totake[["lower"]]) + if(nrow(o) > 0) sel <- c(sel, o$id) + } + + if(anyDuplicated(sel)) sel <- unique(sel) + suppressWarnings(try({rm(o, ex, E, stk, new)})) - try({rm(new, stk, ss, ex, E)},silent = TRUE) } else if(method == "spatial"){ # Spatial thinning stop("Not yet implemented!") + + # check_package("spatstat.geom") + # check_package("spatstat.explore") + # + # # convert data to ppp object + # bg_owin <- spatstat.geom::as.owin(terra::as.data.frame(background, xy = TRUE)[, c(1,2)]) + # coords_ppp <- suppressWarnings(spatstat.geom::as.ppp(X = coords, W = bg_owin)) + # + # # convert to raster + # lambda_xy <- spatstat.explore::density.ppp(coords_ppp) |> + # terra::rast() + # + # # set CRS + # terra::crs(lambda_xy) <- terra::crs(background) + # names(lambda_xy) <- "lambda" + # + # # Now extract + # ex <- cbind(id = 1:nrow(coords), + # terra::extract(ras, coords, cells = TRUE), + # terra::extract(lambda_xy, coords)) + # + # # remove NA points + # ex <- subset(ex, stats::complete.cases(ex)) + # + # # Points to return + # sel <- ex$id[which(ex$sum <= totake[["lower"]])] + # + # # For those where we have more than the minimum, take at random the upper + # # limits of observations + # ex$oversampled <- ifelse(ex$sum > totake[["upper"]], 1, 0) + # if(sum(ex$oversampled) > 1){ + # # If there any oversampled + # # Now sample at random up to the maximum amount. + # o <- dplyr::filter(ex, oversampled == 1) |> + # dplyr::group_by(cell) |> + # # MH: Same as bias, above doesnt make sense grouped for cell + # dplyr::slice_sample(n = totake[["lower"]], weight_by = lambda) + # if(nrow(o) > 0) sel <- c(sel, o$id) + # } + # + # if(anyDuplicated(sel)) sel <- unique(sel) + # suppressWarnings(try({rm(o, ex, bg_owin, lambda_xy, coords_ppp)})) + } # check if any points were selected to thin if (length(sel) == 0){ message("No points were selected during thinning.") - return(df) + return(data) } # Return subsampled coordinates - out <- df[sel,] + out <- data[sel,] if(nrow(out)==0) { message("Thinning failed for some reason") - return(df) + return(data) } else { if(verbose){ message(paste0( "(", method, ")", " thinning completed! \n", - "Original number of records: ", nrow(df), "\n", + "Original number of records: ", nrow(data), "\n", "Number of retained records: ", nrow(out)) ) } diff --git a/man/thin_observations.Rd b/man/thin_observations.Rd index 538ec094..fd655656 100644 --- a/man/thin_observations.Rd +++ b/man/thin_observations.Rd @@ -5,18 +5,20 @@ \title{Functionality for geographic and environmental thinning} \usage{ thin_observations( - df, + data, background, env = NULL, method = "random", minpoints = 10, mindistance = NULL, zones = NULL, + probs = 0.75, + centers = NULL, verbose = TRUE ) } \arguments{ -\item{df}{A \code{\link{sf}} or \code{\link{data.frame}} object with observed occurrence points. +\item{data}{A \code{\link{sf}} object with observed occurrence points. All methods threat presence-only and presence-absence occurrence points equally.} @@ -31,14 +33,21 @@ method is set to \code{"environmental"} or \code{"bias"} (Default: \code{"random"}).} \item{minpoints}{A \code{\link{numeric}} giving the number of data points at minimum to -take (Default: \code{10}).} +remain (Default: \code{10}).} \item{mindistance}{A \code{\link{numeric}} for the minimum distance of neighbouring observations (Default: \code{NULL}).} -\item{zones}{A \code{\link{SpatRaster}} to be supplied when option \code{"method"} is +\item{zones}{A \code{\link{SpatRaster}} to be supplied when option \code{"zones"} is chosen (Default: \code{NULL}).} +\item{probs}{A \code{\link{numeric}} used as quantile threshold in \code{"bias"} method. +(Default: \code{0.75}).} + +\item{centers}{A \code{\link{numeric}} used as number of centers for \code{"environmental"} method. +(Default: \code{NULL}). If not set, automatically set to three or nlayers - 1 (whatever +is bigger).} + \item{verbose}{\code{\link{logical}} of whether to print some statistics about the thinning outcome (Default: \code{TRUE}).} } @@ -55,15 +64,17 @@ effectively removes data prior to any estimation and its use should be considered with care (see also Steen et al. 2021). } \details{ +Most methods only remove points from "over-sampled" grid cells. These are +defined as all cells which either have more points than \code{minpoints} or +more points than the global minimum point count per cell (whichever is larger). + Currently implemented thinning methods: \itemize{ \item \code{"random"}: Samples at random up to number of \code{"minpoints"} across all occupied grid cells. -Does not account for any spatial or environmental distance between -observations. -\item \code{"bias"}: This option removed explicitly points that are considered biased (parameter \code{"env"}) only. -Points are preferentially thinned from grid cells which are in the 25\% most -biased (larger values assumed greater bias) and have high point density. -Thins the observations up to \code{"minpoints"}. +Does not account for any spatial or environmental distance between observations. +\item \code{"bias"}: This option removes explicitly points that are considered biased (parameter \code{"env"}) only. +Points are only thinned from grid cells which are above the bias quantile (larger values +equals greater bias). Thins the observations up to \code{"minpoints"}. \item \code{"zones"}: Assesses for each observation that it falls with a maximum of \code{"minpoints"} into each occupied zone. Careful: If the zones are relatively wide this can remove quite a few observations. diff --git a/tests/testthat/test_functions.R b/tests/testthat/test_functions.R index 63b73cd8..f9492ffb 100644 --- a/tests/testthat/test_functions.R +++ b/tests/testthat/test_functions.R @@ -215,27 +215,27 @@ test_that('Test data preparation convenience functions', { # --- # # Apply thinning methods - pp1 <- thin_observations(df = virtual_points, background = background, - method = "random", minpoints = 100,verbose = FALSE) + pp1 <- thin_observations(data = virtual_points, background = background, + method = "random", minpoints = 3,verbose = FALSE) expect_gt(nrow(pp1),0) # - # - expect_error(pp2 <- thin_observations(df = virtual_points, background = background, + expect_error(pp2 <- thin_observations(data = virtual_points, background = background, method = "bias", verbose = FALSE)) - pp2 <- thin_observations(df = virtual_points, background = background, + pp2 <- thin_observations(data = virtual_points, background = background, env = predictors$hmi_mean_50km, method = "bias", verbose = FALSE) expect_gt(nrow(pp2),0) # - # - pp3 <- thin_observations(df = virtual_points, background = background, + pp3 <- thin_observations(data = virtual_points, background = background, zones = as.factor(predictors$koeppen_50km), method = "zones", verbose = FALSE) expect_gt(nrow(pp3),0) # - # - pp4 <- thin_observations(df = virtual_points, background = background, + pp4 <- thin_observations(data = virtual_points, background = background, env = predictors, method = "environmental", verbose = FALSE) expect_gt(nrow(pp4),0) - # pp5 <- thin_observations(df = virtual_points, background = background, + # pp5 <- thin_observations(data = virtual_points, background = background, # env = predictors, # method = "spatial", verbose = FALSE) # expect_gt(nrow(pp5),0) diff --git a/vignettes/articles/01_data_preparationhelpers.Rmd b/vignettes/articles/01_data_preparationhelpers.Rmd index 9e6eaadf..d0d8ff23 100644 --- a/vignettes/articles/01_data_preparationhelpers.Rmd +++ b/vignettes/articles/01_data_preparationhelpers.Rmd @@ -175,7 +175,7 @@ for an alternative implementation and rationale for thinning. plot(virtual_species['Observed'], main = "Original data") # Random thinning. Note the messages of number of thinned points -point1 <- thin_observations(df = virtual_species, +point1 <- thin_observations(data = virtual_species, background = background, method = 'random', minpoints = 1 # Retain at minimum one point per grid cell! @@ -187,7 +187,7 @@ plot(point1['Observed'], main = "Random thinning") # across the niche defined by a set of covariates covariates <- terra::rast(list.files(system.file("extdata/predictors/", package = "ibis.iSDM", mustWork = TRUE), "*.tif",full.names = TRUE)) -point2 <- thin_observations(df = virtual_species, +point2 <- thin_observations(data = virtual_species, background = background, env = covariates, method = 'environmental', From 14318ea05f96cec6c4ad83b6c1bfd5ef6a1dfa00 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Fri, 10 Nov 2023 15:11:39 +0000 Subject: [PATCH 02/20] Update CITATION.cff --- CITATION.cff | 46 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 45 insertions(+), 1 deletion(-) diff --git a/CITATION.cff b/CITATION.cff index 7e8a407b..34bdef0d 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.0 +version: 0.1.1 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 @@ -732,6 +732,10 @@ references: - family-names: Weber given-names: Sebastian email: sdw.post@waebers.de + - family-names: Badr + given-names: Hamada S. + email: badr@jhu.edu + orcid: https://orcid.org/0000-0002-9808-2344 year: '2023' version: '>= 2.21.0' - type: software @@ -862,3 +866,43 @@ references: given-names: Jiaming email: jm.yuan@outlook.com year: '2023' +- type: software + title: spatstat.geom + abstract: 'spatstat.geom: Geometrical Functionality of the ''spatstat'' Family' + notes: Suggests + url: http://spatstat.org/ + repository: https://CRAN.R-project.org/package=spatstat.geom + authors: + - family-names: Baddeley + given-names: Adrian + email: Adrian.Baddeley@curtin.edu.au + orcid: https://orcid.org/0000-0001-9499-8382 + - family-names: Turner + given-names: Rolf + email: rolfturner@posteo.net + orcid: https://orcid.org/0000-0001-5521-5218 + - family-names: Rubak + given-names: Ege + email: rubak@math.aau.dk + orcid: https://orcid.org/0000-0002-6675-533X + year: '2023' +- type: software + title: spatstat.explore + abstract: 'spatstat.explore: Exploratory Data Analysis for the ''spatstat'' Family' + notes: Suggests + url: http://spatstat.org/ + repository: https://CRAN.R-project.org/package=spatstat.explore + authors: + - family-names: Baddeley + given-names: Adrian + email: Adrian.Baddeley@curtin.edu.au + orcid: https://orcid.org/0000-0001-9499-8382 + - family-names: Turner + given-names: Rolf + email: rolfturner@posteo.net + orcid: https://orcid.org/0000-0001-5521-5218 + - family-names: Rubak + given-names: Ege + email: rubak@math.aau.dk + orcid: https://orcid.org/0000-0002-6675-533X + year: '2023' From 2eab72fe72f3426dd84e5a5dbea89c8f7c1b9ac1 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Sun, 12 Nov 2023 12:55:06 +0100 Subject: [PATCH 03/20] Harmonizing `partial` and `spartial` parameters #80 --- NEWS.md | 3 +- R/engine_bart.R | 10 ++- R/engine_breg.R | 40 ++++++------ R/engine_gdb.R | 77 ++++++++++++------------ R/engine_glmnet.R | 60 +++++++++++------- R/engine_xgboost.R | 50 +++++++++------ R/partial.R | 11 ++-- R/utils-glmnet.R | 5 +- R/utils-scenario.R | 2 +- R/utils-spatial.R | 39 +++++++++++- README.Rmd | 2 +- README.md | 2 +- man/spartial.Rd | 7 ++- man/thin_observations.Rd | 11 +++- tests/testthat/test_trainOtherEngines.R | 41 ++++++++++++- vignettes/figures/IIASA-50_blue.png | Bin 108586 -> 0 bytes vignettes/figures/iiasa_logo_blue.png | Bin 0 -> 23073 bytes 17 files changed, 239 insertions(+), 121 deletions(-) delete mode 100644 vignettes/figures/IIASA-50_blue.png create mode 100644 vignettes/figures/iiasa_logo_blue.png diff --git a/NEWS.md b/NEWS.md index 733a6ff4..9db566ad 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,8 @@ # ibis.iSDM 0.1.1 (current dev branch) #### Minor improvements and bug fixes -* Several bug fixes in `thin_observations` and `global` argument for bias-method +* Several bug fixes in `thin_observations` and `global` argument for bias-method. +* Harmonization of parameters for `spartial()` and addressing #80 # ibis.iSDM 0.1.0 diff --git a/R/engine_bart.R b/R/engine_bart.R index d6c6594c..027e4491 100644 --- a/R/engine_bart.R +++ b/R/engine_bart.R @@ -555,11 +555,17 @@ engine_bart <- function(x, } }, # Spatial partial dependence plot option from embercardo - spartial = function(self, x.var = NULL, equal = FALSE, + spartial = function(self, x.var = NULL, newdata = NULL, equal = FALSE, smooth = 1, transform = TRUE, type = NULL){ fit <- self$get_data('fit_best') model <- self$model - predictors <- model$predictors_object$get_data() + if(is.null(newdata)){ + predictors <- model$predictors_object$get_data() + } else { + predictors <- newdata + assertthat::assert_that(x.var %in% colnames(predictors), + msg = 'Variable not in provided data!') + } assertthat::assert_that(x.var %in% attr(fit$fit$data@x,'term.labels'), msg = 'Variable not in predicted model' ) diff --git a/R/engine_breg.R b/R/engine_breg.R index 0ce48fa9..2740c574 100644 --- a/R/engine_breg.R +++ b/R/engine_breg.R @@ -632,7 +632,7 @@ engine_breg <- function(x, return(pred_part) }, # Spatial partial dependence plot - spartial = function(self, x.var, constant = NULL, plot = TRUE, type = NULL){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, plot = TRUE, type = NULL){ assertthat::assert_that(is.character(x.var) || is.null(x.var), "model" %in% names(self), is.null(constant) || is.numeric(constant), @@ -649,7 +649,15 @@ engine_breg <- function(x, mod <- self$get_data('fit_best') model <- self$model - df <- model$biodiversity[[length( model$biodiversity )]]$predictors + + # Check if newdata is defined, if yes use that one instead + if(!is.null(newdata)){ + df <- newdata + assertthat::assert_that(nrow(df) == nrow(model$biodiversity[[1]]$predictors)) + } else { + # df <- model$biodiversity[[1]]$predictors + df <- model$predictors + } df <- subset(df, select = attr(mod$terms, "term.labels")) w <- model$biodiversity[[1]]$expect # Also get exposure variable @@ -661,23 +669,20 @@ engine_breg <- function(x, } # Make spatial container for prediction - suppressWarnings( - df_partial <- sp::SpatialPointsDataFrame(coords = model$predictors[,c('x', 'y')], - data = model$predictors[, names(model$predictors) %notin% c('x','y')], - proj4string = sp::CRS(sp::proj4string(methods::as(model$background, "Spatial"))) - ) - ) - df_partial <- methods::as(df_partial, 'SpatialPixelsDataFrame') + template <- model_to_background(model) + # Assign a cellid to df to match the file later + # df$cellid <- # Add all others as constant if(is.null(constant)){ - for(n in names(df_partial)) if(n != x.var) df_partial[[n]] <- suppressWarnings( mean(model$predictors[[n]], na.rm = TRUE) ) + for(n in names(df)) if(n != x.var) df[[n]] <- suppressWarnings( mean(model$predictors[[n]], na.rm = TRUE) ) } else { - for(n in names(df_partial)) if(n != x.var) df_partial[[n]] <- constant + for(n in names(df)) if(n != x.var) df[[n]] <- constant } + if(any(model$predictors_types$type=="factor")){ lvl <- levels(model$predictors[[model$predictors_types$predictors[model$predictors_types$type=="factor"]]]) - df_partial[[model$predictors_types$predictors[model$predictors_types$type=="factor"]]] <- + df[[model$predictors_types$predictors[model$predictors_types$type=="factor"]]] <- factor(lvl[1], levels = lvl) # FIXME: Assigning the first level (usually reference) for now. But ideally find a way to skip factors from partial predictions } @@ -687,7 +692,7 @@ engine_breg <- function(x, pred_breg <- predict_boom( obj = mod, - newdata = df_partial@data, + newdata = df, w = unique(w)[2], # The second entry of unique contains the non-observed variables fam = fam, params = settings$data # Use the settings as list @@ -704,14 +709,7 @@ engine_breg <- function(x, pred_part$cv <- pred_part$sd / pred_part$mean # Now create spatial prediction - prediction <- try({emptyraster( model$predictors_object$get_data()[[1]] )},silent = TRUE) # Background - if(inherits(prediction, "try-error")){ - prediction <- terra::rast(model$predictors[,c("x", "y")], - crs = terra::crs(model$background), - type = "xyz") |> - emptyraster() - } - prediction <- fill_rasters(pred_part, prediction) + prediction <- fill_rasters(pred_part, template) # Do plot and return result if(plot){ diff --git a/R/engine_gdb.R b/R/engine_gdb.R index cb7090c7..fd5b502a 100644 --- a/R/engine_gdb.R +++ b/R/engine_gdb.R @@ -492,6 +492,7 @@ engine_gdb <- function(x, # Compute end of computation time settings$set('end.time', Sys.time()) # Also append boosting control option to settings + for(entry in names(params)) settings$set(entry, params[[entry]]) for(entry in names(bc)) settings$set(entry, bc[[entry]]) # Create output @@ -504,7 +505,6 @@ engine_gdb <- function(x, fits = list( "fit_best" = fit_gdb, "fit_cv" = cvm, - "params" = params, "fit_best_equation" = equation, "prediction" = prediction ), @@ -517,14 +517,12 @@ engine_gdb <- function(x, # Get model mod <- self$get_data('fit_best') model <- self$model + settings <- self$settings assertthat::assert_that(inherits(mod,'mboost'),msg = 'No model found!') - if(is.null(type)) type <- self$get_data('params')$type + if(is.null(type)) type <- settings$get('type') # Check that all variables are in provided data.frame assertthat::assert_that(all( as.character(mboost::extract(mod,'variable.names')) %in% names(newdata) )) - # Also get settings for bias values - settings <- self$settings - # Clamp? if( settings$get("clamp") ) newdata <- clamp_predictions(model, newdata) @@ -570,7 +568,8 @@ engine_gdb <- function(x, variables <- mboost::extract(self$get_data('fit_best'),'variable.names') assertthat::assert_that( all( x.var %in% variables), msg = 'x.var variable not found in model!' ) - if(is.null(type)) type <- self$get_data('params')$type + settings <- self$settings + if(is.null(type)) type <- settings$get('type') model <- self$model # Special treatment for factors @@ -669,7 +668,7 @@ engine_gdb <- function(x, return(out) }, # Spatial partial effect plots - spartial = function(self, x.var, constant = NULL, plot = TRUE, type = NULL, ...){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, plot = TRUE, type = NULL, ...){ assertthat::assert_that('fit_best' %in% names(self$fits), is.character(x.var), length(x.var) == 1) # Get model and make empty template @@ -678,43 +677,46 @@ engine_gdb <- function(x, # Also check that what is present in coefficients of model variables <- as.character( mboost::extract(mod,'variable.names') ) assertthat::assert_that(x.var %in% variables, - msg = "Variable not found in model!" ) + msg = "Variable not found in model! Regularized out?" ) + + if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) # Make template of target variable(s) - template <- try({ - emptyraster( self$model$predictors_object$get_data()[[1]] )}, - silent = TRUE) # Background - if(inherits(template, "try-error")){ - template <- terra::rast(model$predictors[,c("x", "y")], - crs = terra::crs(model$background), - type = "xyz") |> - emptyraster() - } + template <- model_to_background(model) # Get target variables and predict - target <- model$predictors + if(!is.null(newdata)){ + df <- newdata + } else { + df <- model$predictors + } + assertthat::assert_that(x.var %in% colnames(df), + msg = "Variable not found in provided data.") + # Set all variables other the target variable to constant if(is.null(constant)){ # Calculate mean nn <- model$predictors_types$predictors[which(model$predictors_types$type=='numeric')] - constant <- apply(target[,nn], 2, function(x) mean(x, na.rm=T)) + constant <- apply(df[,nn], 2, function(x) mean(x, na.rm=T)) for(v in variables[ variables %notin% x.var]){ - if(v %notin% names(target) ) next() - target[!is.na(target[v]),v] <- constant[v] + if(v %notin% colnames(df) ) next() + df[!is.na(df[v]),v] <- constant[v] } } else { - target[!is.na(target[,x.var]), variables] <- constant + df[!is.na(df[,x.var]), variables] <- constant } - target$rowid <- as.numeric( rownames(target) ) - assertthat::assert_that(nrow(target)==ncell(template)) + df$rowid <- as.numeric( rownames(df) ) + assertthat::assert_that(nrow(df)==ncell(template)) pp <- suppressWarnings( - mboost::predict.mboost(mod, newdata = target, which = x.var, - type = 'link', aggregate = 'sum') + mboost::predict.mboost(mod, newdata = df, which = x.var, + type = settings$get('type'), aggregate = 'sum') ) # If both linear and smooth effects are in model - if(length(target$rowid[which(!is.na(target[[x.var]]))] ) == length(pp[,ncol(pp)])){ - template[ target$rowid[which(!is.na(target[[x.var]]))] ] <- pp[,ncol(pp)] + if(length(df$rowid[which(!is.na(df[[x.var]]))] ) == length(pp[,ncol(pp)])){ + template[ df$rowid[which(!is.na(df[[x.var]]))] ] <- pp[,ncol(pp)] } else { template[] <- pp[, ncol(pp) ]} names(template) <- paste0('partial__',x.var) @@ -757,7 +759,8 @@ engine_gdb <- function(x, cofs$variable <- gsub('bols\\(|bbs\\(|bmono\\(', '', cofs$variable) cofs$variable <- sapply(strsplit(cofs$variable, ","), function(z) z[[1]]) cofs$variable <- gsub('\\)', '', cofs$variable) - names(cofs) <- c("Feature", "Weights", "Beta") + cofs <- cofs |> dplyr::select(variable, beta) + names(cofs) <- c("Feature", "Beta") return(cofs) }, # Spatial latent effect @@ -773,7 +776,8 @@ engine_gdb <- function(x, msg = 'No spatial effect found in model!') # Make template of target variable(s) - temp <- emptyraster( model$predictors_object$get_data() ) + template <- model_to_background(model) + # Get target variables and predict target <- self$model$predictors[,c('x','y')] @@ -781,17 +785,16 @@ engine_gdb <- function(x, mboost::predict.mboost(mod, newdata = target, which = c('x','y')) ) assertthat::assert_that(nrow(target)==nrow(y)) - temp[] <- y[,2] - names(temp) <- paste0('partial__','space') + template[] <- y[,2] + names(template) <- paste0('partial__','space') # Mask with background - temp <- terra::mask(temp, self$model$background ) + template <- terra::mask(template, model$background ) + # Plot both partial spatial partial if(plot){ - # Plot both partial spatial partial - terra::plot(temp, main = expression(f[partial]), col = ibis_colours$divg_bluegreen ) + terra::plot(template, main = expression(f[partial]), col = ibis_colours$divg_bluegreen ) } - - return(temp) + return(template) } ) diff --git a/R/engine_glmnet.R b/R/engine_glmnet.R index 26ced232..3833e1b7 100644 --- a/R/engine_glmnet.R +++ b/R/engine_glmnet.R @@ -543,16 +543,19 @@ engine_glmnet <- function(x, is.null(newdata) || is.data.frame(newdata), is.numeric(variable_length) ) - check_package("pdp") # Settings settings <- self$settings mod <- self$get_data('fit_best') model <- self$model - df <- model$biodiversity[[length( model$biodiversity )]]$predictors co <- stats::coef(mod) |> row.names() # Get model coefficient names # Set type if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) + + # Get data + df <- model$biodiversity[[length( model$biodiversity )]]$predictors # Match x.var to argument if(is.null(x.var)){ @@ -603,18 +606,31 @@ engine_glmnet <- function(x, assertthat::assert_that(all( x.var %in% colnames(df) ), msg = 'Variable not in predicted model.') + # HACK: Overwrite lambda to make sure pdp uses it. + mod$lambda.1se <- determine_lambda(mod) + # Inverse link function + ilf <- switch (settings$get('type'), + "link" = NULL, + "response" = ifelse(model$biodiversity[[1]]$family=='poisson', + exp, logistic) + ) + pp <- data.frame() pb <- progress::progress_bar$new(total = length(x.var)) for(v in x.var){ if(!is.Waiver(of)){ # Predict with offset - p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, ice = FALSE, center = FALSE, + p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, + ice = FALSE, center = FALSE, type = "regression", newoffset = of, + inv.link = ilf, plot = FALSE, rug = TRUE, train = df) } else { - p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, ice = FALSE, center = FALSE, - type = "regression", - plot = FALSE, rug = TRUE, train = df) + p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, + ice = FALSE, center = FALSE, + type = "regression", inv.link = ilf, + plot = FALSE, rug = TRUE, train = df + ) } p1 <- p1[,c(v, "yhat")] names(p1) <- c("partial_effect", "mean") @@ -636,10 +652,11 @@ engine_glmnet <- function(x, return(pp) }, # Spatial partial dependence plot - spartial = function(self, x.var, constant = NULL, plot = TRUE, type = NULL){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, plot = TRUE, type = NULL){ assertthat::assert_that(is.character(x.var), "model" %in% names(self), is.null(constant) || is.numeric(constant), + is.null(newdata) || is.data.frame(newdata), is.logical(plot), is.character(type) || is.null(type) ) @@ -654,8 +671,15 @@ engine_glmnet <- function(x, model <- self$model # For Integrated model, take the last one fam <- model$biodiversity[[length(model$biodiversity)]]$family - df <- model$predictors - df$w <- model$exposure + + # If new data is set + if(!is.null(newdata)){ + df <- newdata + } else { + df <- model$predictors + df$w <- model$exposure + } + assertthat::assert_that(all(x.var %in% colnames(df))) df$rowid <- 1:nrow(df) # Match x.var to argument x.var <- match.arg(x.var, names(df), several.ok = FALSE) @@ -687,21 +711,13 @@ engine_glmnet <- function(x, ) |> as.data.frame() # Now create spatial prediction - prediction <- try({ - emptyraster( model$predictors_object$get_data()[[1]] )}, - silent = TRUE) # Background - if(inherits(prediction, "try-error")){ - prediction <- terra::rast(model$predictors[,c("x", "y")], - crs = terra::crs(model$background), - type = "xyz") |> - emptyraster() - } - prediction[df_sub$rowid] <- pred_gn[,1] - names(prediction) <- paste0("spartial_",x.var) + template <- model_to_background(model) + template[df_sub$rowid] <- pred_gn[,1] + names(template) <- paste0("spartial_",x.var) # Do plot and return result - if(plot) terra::plot(prediction, col = ibis_colours$ohsu_palette) - return(prediction) + if(plot) terra::plot(template, col = ibis_colours$ohsu_palette) + return(template) }, # Convergence check has_converged = function(self){ diff --git a/R/engine_xgboost.R b/R/engine_xgboost.R index 008e7521..d3ee45d9 100644 --- a/R/engine_xgboost.R +++ b/R/engine_xgboost.R @@ -660,8 +660,17 @@ engine_xgboost <- function(x, assertthat::assert_that(is.character(x.var) || is.null(x.var)) if(!is.null(constant)) message("Constant is ignored for xgboost!") check_package("pdp") + + # Settings + settings <- self$settings mod <- self$get_data('fit_best') model <- self$model + + # Set type + if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) + df <- model$biodiversity[[length( model$biodiversity )]]$predictors df <- subset(df, select = mod$feature_names) if(!is.null(newdata)){ @@ -720,16 +729,27 @@ engine_xgboost <- function(x, all( names(df) == mod$feature_names ), msg = 'Variable not in predicted model.') + # Inverse link function + ilf <- switch (settings$get('type'), + "link" = NULL, + "response" = ifelse(model$biodiversity[[1]]$family=='poisson', + exp, logistic) + ) + pp <- data.frame() pb <- progress::progress_bar$new(total = length(x.var)) for(v in x.var){ if(!is.Waiver(of)){ # Predict with offset p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, ice = FALSE, center = FALSE, - plot = FALSE, rug = TRUE, newoffset = of, train = df) + plot = FALSE, rug = TRUE, + inv.link = ilf, + newoffset = of, train = df) } else { p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, ice = FALSE, center = FALSE, - plot = FALSE, rug = TRUE, train = df) + plot = FALSE, rug = TRUE, + inv.link = ilf, + train = df) } p1 <- p1[,c(x.var, "yhat")] names(p1) <- c("partial_effect", "mean") @@ -751,27 +771,23 @@ engine_xgboost <- function(x, return(pp) }, # Spatial partial dependence plot - spartial = function(self, x.var, constant = NULL, plot = TRUE, ...){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, plot = TRUE, ...){ assertthat::assert_that(is.character(x.var) || is.null(x.var), - "model" %in% names(self)) + "model" %in% names(self), + is.null(newdata) || is.data.frame(newdata)) # Get data mod <- self$get_data('fit_best') model <- self$model - params <- self$settings + settings <- self$settings x.var <- match.arg(x.var, model$predictors_names, several.ok = FALSE) # Get predictor df <- subset(model$predictors, select = mod$feature_names) # Convert all non x.vars to the mean + # Make template of target variable(s) - template <- try({emptyraster( model$predictors_object$get_data() )},silent = TRUE) - if(inherits(template, "try-error")){ - template <- terra::rast(model$predictors[,c("x", "y")], - crs = terra::crs(model$background), - type = "xyz") |> - emptyraster() - } + template <- model_to_background(model) # Set all variables other the target variable to constant if(!is.null(constant)){ @@ -784,7 +800,7 @@ engine_xgboost <- function(x, # df[!is.na(df[v]),v] <- as.numeric( constant[v] ) # } # } else { - df[!is.na(df[,x.var]), mod$feature_names[ mod$feature_names %notin% x.var]] <- constant + df[!is.na(df[,x.var]), mod$feature_names[ mod$feature_names %notin% x.var]] <- constant } df <- xgboost::xgb.DMatrix(data = as.matrix(df)) @@ -799,13 +815,7 @@ engine_xgboost <- function(x, as.data.frame() # Get only target variable pp <- subset(pp, select = x.var) - # suppressWarnings( - # pp <- predict( - # object = mod, - # newdata = df - # ) - # ) - # if(params$get('objective')[[1]]=="binary:logitraw") pp <- ilink(pp, "cloglog") + # if(settings$get('objective')[[1]]=="binary:logitraw") pp <- ilink(pp, "cloglog") assertthat::assert_that(terra::ncell(template) == nrow(pp)) # Fill output with summaries of the posterior diff --git a/R/partial.R b/R/partial.R index 4be9a7ad..1049f4d6 100644 --- a/R/partial.R +++ b/R/partial.R @@ -85,6 +85,8 @@ partial.DistributionModel <- function(mod, ...) mod$partial(...) #' is to be calculated. #' @param constant A [numeric] constant to be inserted for all other variables. #' Default calculates the [mean] per variable. +#' @param newdata A [`data.frame`] on which to calculate the spartial for. Can be +#' for example created from a raster file (Default: \code{NULL}). #' @param plot A [logical] indication of whether the result is to be plotted? #' @param ... Other engine specific parameters. #' @seealso [partial] @@ -105,25 +107,26 @@ partial.DistributionModel <- function(mod, ...) mod$partial(...) methods::setGeneric( "spartial", signature = methods::signature("mod","x.var"), - function(mod, x.var, constant = NULL, plot = FALSE, ...) standardGeneric("spartial")) + function(mod, x.var, constant = NULL, newdata = NULL, plot = FALSE, ...) standardGeneric("spartial")) #' @name spartial #' @rdname spartial #' @usage -#' \S4method{spartial}{ANY,character,ANY,logical}(mod,x.var,constant,plot,...) +#' \S4method{spartial}{ANY,character,ANY,ANY,logical}(mod,x.var,constant,newdata,plot,...) methods::setMethod( "spartial", methods::signature(mod = "ANY", x.var = "character"), - function(mod, x.var, constant = NULL, plot = FALSE, ...) { + function(mod, x.var, constant = NULL, newdata = NULL, plot = FALSE, ...) { assertthat::assert_that(!missing(x.var),msg = 'Specify a variable name in the model!') assertthat::assert_that(inherits(mod, "DistributionModel"), is.character(x.var), is.null(constant) || is.numeric(constant), + is.null(newdata) || is.data.frame(newdata), is.logical(plot) ) # Work around to call partial response directly if(inherits(mod,'DistributionModel')){ - spartial.DistributionModel(mod, x.var, constant, plot, ...) + spartial.DistributionModel(mod, x.var, constant, newdata, plot, ...) } else { stop('Spatial partial response calculation not supported!') } diff --git a/R/utils-glmnet.R b/R/utils-glmnet.R index ac6b49dc..acb7470e 100644 --- a/R/utils-glmnet.R +++ b/R/utils-glmnet.R @@ -157,7 +157,8 @@ tidy_glmnet_summary <- function(obj){ if(inherits(obj, "cva.glmnet")){ # Get best alpha alpha <- sapply(obj$modlist, function(z) min(z$cvup)) - ms <- stats::coef(obj, which = which.min(alpha)) |> + ms <- stats::coef(obj, which = which.min(alpha), + s = lambda) |> as.matrix() |> as.data.frame() } else { # Summarise coefficients within 1 standard deviation @@ -170,7 +171,7 @@ tidy_glmnet_summary <- function(obj){ ms <- subset(ms, mean != 0) # Remove regularized coefficients for some clean up. if(nrow(ms)>0){ # Reorder - ms <- ms[order(ms$mean,decreasing = TRUE),] # Sort + ms <- ms[order(ms$mean, decreasing = TRUE),] # Sort rownames(ms) <- NULL } else { ms <- data.frame() diff --git a/R/utils-scenario.R b/R/utils-scenario.R index 7ae366c6..9da09ca3 100644 --- a/R/utils-scenario.R +++ b/R/utils-scenario.R @@ -301,7 +301,7 @@ raster_to_stars <- function(obj){ new_env[[names(obj)[i]]] <- o } - new_env <- do.call(stars:::c.stars, new_env) + new_env <- do.call(c, new_env) assertthat::assert_that(inherits(new_env, "stars"), stars::st_dimensions(new_env) |> length() == 3) diff --git a/R/utils-spatial.R b/R/utils-spatial.R index 61314480..60fc6f5d 100644 --- a/R/utils-spatial.R +++ b/R/utils-spatial.R @@ -993,7 +993,44 @@ get_rastervalue <- function(coords, env, ngb_fill = TRUE, rm.na = FALSE){ return(ex) } -#' Create new raster stack from a given data.frame +#' Create background raster from a model object +#' +#' @description +#' This is an internal function that converts a model object +#' to a background layer that can be used to fill a prediction. +#' +#' @param model A [`list`] object created from a DistributionModel. +#' @keywords utils, internal +#' @return A [`SpatRaster-class`] object +#' @noRd +model_to_background <- function(model){ + assertthat::assert_that( + is.list(model), + inherits(model$background, "sf") || is.Raster(model$background) + ) + + # Try and create the template from the predictors object + template <- try({ + emptyraster( model$predictors_object$get_data()[[1]] )}, + silent = TRUE) # Background + + # If the template creation fails, create it from the model predictors + if(inherits(template, "try-error")){ + template <- try({ + terra::rast(model$predictors[,c("x", "y")], + crs = terra::crs(model$background), + type = "xyz") |> + emptyraster() + },silent = TRUE) + } + + # If that also failed, raise error + if(inherits(template, "try-error")) stop("No file to create a background raster from?") + assertthat::assert_that(is.Raster(template)) + return(template) +} + +#' Fill a raster stack with a given data.frame #' #' @param post A data.frame #' @param background A [`SpatRaster-class`] object for the background raster. diff --git a/README.Rmd b/README.Rmd index 6ea3f8a4..6fa809b2 100644 --- a/README.Rmd +++ b/README.Rmd @@ -55,7 +55,7 @@ Note that the package is in active development and parameters of some functions Jung, Martin. 2023. “An Integrated Species Distribution Modelling Framework for Heterogeneous Biodiversity Data.” Ecological Informatics, 102127, [DOI](https://doi.org/10.1016/j.ecoinf.2023.102127) -## Acknowledgement IIASA +## Acknowledgement IIASA **ibis.iSDM** is developed and maintained by the Biodiversity, Ecology and Conservation group at the International Institute for Applied Systems Analysis (IIASA), Austria. diff --git a/README.md b/README.md index 3d66fd19..a21250ef 100644 --- a/README.md +++ b/README.md @@ -60,7 +60,7 @@ Jung, Martin. 2023. “An Integrated Species Distribution Modelling Framework for Heterogeneous Biodiversity Data.” Ecological Informatics, 102127, [DOI](https://doi.org/10.1016/j.ecoinf.2023.102127) -## Acknowledgement IIASA +## Acknowledgement IIASA **ibis.iSDM** is developed and maintained by the Biodiversity, Ecology and Conservation group at the International Institute for Applied diff --git a/man/spartial.Rd b/man/spartial.Rd index 8d4c9e68..63e0bbb2 100644 --- a/man/spartial.Rd +++ b/man/spartial.Rd @@ -5,9 +5,9 @@ \alias{spartial.DistributionModel} \title{Obtain spatial partial effects of trained model} \usage{ -spartial(mod, x.var, constant = NULL, plot = FALSE, ...) +spartial(mod, x.var, constant = NULL, newdata = NULL, plot = FALSE, ...) -\S4method{spartial}{ANY,character,ANY,logical}(mod,x.var,constant,plot,...) +\S4method{spartial}{ANY,character,ANY,ANY,logical}(mod,x.var,constant,newdata,plot,...) \method{spartial}{DistributionModel}(mod, ...) } @@ -20,6 +20,9 @@ is to be calculated.} \item{constant}{A \link{numeric} constant to be inserted for all other variables. Default calculates the \link{mean} per variable.} +\item{newdata}{A \code{\link{data.frame}} on which to calculate the spartial for. Can be +for example created from a raster file (Default: \code{NULL}).} + \item{plot}{A \link{logical} indication of whether the result is to be plotted?} \item{...}{Other engine specific parameters.} diff --git a/man/thin_observations.Rd b/man/thin_observations.Rd index fd655656..12fc39e0 100644 --- a/man/thin_observations.Rd +++ b/man/thin_observations.Rd @@ -13,6 +13,7 @@ thin_observations( mindistance = NULL, zones = NULL, probs = 0.75, + global = TRUE, centers = NULL, verbose = TRUE ) @@ -44,6 +45,9 @@ chosen (Default: \code{NULL}).} \item{probs}{A \code{\link{numeric}} used as quantile threshold in \code{"bias"} method. (Default: \code{0.75}).} +\item{global}{A \code{\link{logical}} if during \code{"bias"} method global or local, extracted +bias values are used as threshold. (Default: \code{TRUE}).} + \item{centers}{A \code{\link{numeric}} used as number of centers for \code{"environmental"} method. (Default: \code{NULL}). If not set, automatically set to three or nlayers - 1 (whatever is bigger).} @@ -64,13 +68,14 @@ effectively removes data prior to any estimation and its use should be considered with care (see also Steen et al. 2021). } \details{ -Most methods only remove points from "over-sampled" grid cells. These are -defined as all cells which either have more points than \code{minpoints} or +All methods only remove points from "over-sampled" grid cells/areas. These are +defined as all cells/area which either have more points than \code{minpoints} or more points than the global minimum point count per cell (whichever is larger). Currently implemented thinning methods: \itemize{ -\item \code{"random"}: Samples at random up to number of \code{"minpoints"} across all occupied grid cells. +\item \code{"random"}: Samples at random across all over-sampled grid cells returning +at minimum \code{"minpoints"} . Does not account for any spatial or environmental distance between observations. \item \code{"bias"}: This option removes explicitly points that are considered biased (parameter \code{"env"}) only. Points are only thinned from grid cells which are above the bias quantile (larger values diff --git a/tests/testthat/test_trainOtherEngines.R b/tests/testthat/test_trainOtherEngines.R index fce212ba..b4b49cc6 100644 --- a/tests/testthat/test_trainOtherEngines.R +++ b/tests/testthat/test_trainOtherEngines.R @@ -59,6 +59,14 @@ test_that('Train a distribution model with XGboost', { expect_s3_class(mod$get_centroid(), "sf") expect_s3_class(tr$get_centroid(), "sf") + # Some partial calculations + expect_no_error(ex <- partial(mod, x.var = "CLC3_132_mean_50km")) + expect_s3_class(ex, 'data.frame') + + # Spartial + expect_no_error(ex <- spartial(mod, x.var = "CLC3_132_mean_50km")) + expect_s4_class(ex, "SpatRaster") + ex_sd <- ensemble(mod, mod, uncertainty = "sd") ex_range <- ensemble(mod, mod, uncertainty = "range") ex_pca <- ensemble(mod, mod, uncertainty = "pca") @@ -133,6 +141,9 @@ test_that('Train a distribution model with Breg', { expect_s3_class(mod$get_centroid(), "sf") expect_s3_class(tr$get_centroid(), "sf") + # Does normal spartial work as expected? + expect_no_error(ex <- spartial(mod, x.var = "CLC3_312_mean_50km") ) + ex <- ensemble(mod, mod) expect_s4_class(ex, "SpatRaster") @@ -141,7 +152,7 @@ test_that('Train a distribution model with Breg', { expect_s3_class(ex, 'data.frame') # Do ensemble spartials work - mod2 <- x |> train(only_linear = TRUE) + mod2 <- x |> train(only_linear = TRUE,verbose = FALSE) expect_no_error(ex <- ensemble_spartial(mod,mod2, x.var = "CLC3_312_mean_50km")) expect_true(is.Raster(ex)) @@ -190,6 +201,7 @@ test_that('Train a distribution model with GDB', { expect_s3_class(summary(mod), "data.frame") expect_s3_class(mod$show_duration(), "difftime") expect_equal(length(mod$show_rasters()), 1) # Now predictions found + expect_s3_class(mod$settings, "Settings") # --- # # Some checks @@ -205,6 +217,13 @@ test_that('Train a distribution model with GDB', { expect_s3_class(mod$get_centroid(), "sf") expect_s3_class(tr$get_centroid(), "sf") + # Nor conventional partials work + expect_no_error(ex <- partial(mod, x.var = "CLC3_312_mean_50km")) + expect_s3_class(ex, 'data.frame') + + # Do spartials work + expect_no_error(ex <- spartial(mod, x.var = "CLC3_312_mean_50km")) + ex <- ensemble(mod, mod) expect_s4_class(ex, "SpatRaster") @@ -213,7 +232,7 @@ test_that('Train a distribution model with GDB', { expect_s3_class(ex, 'data.frame') # Do ensemble spartials work - mod2 <- x |> train(only_linear = TRUE) + mod2 <- x |> train(only_linear = TRUE,verbose = FALSE) expect_no_error(ex <- ensemble_spartial(mod,mod2, x.var = "CLC3_312_mean_50km")) expect_true(is.Raster(ex)) @@ -223,6 +242,11 @@ test_that('Train a distribution model with GDB', { # Get layer expect_s4_class(mod |> get_data(), "SpatRaster") + # Expect data.frame + expect_s3_class(mod$get_coefficients(), 'data.frame') + + # Expect formula + expect_s3_class(mod$get_equation(), 'formula') }) # ---- # @@ -279,7 +303,18 @@ test_that('Train a distribution model with glmnet', { expect_s3_class(mod$get_centroid(), "sf") expect_s3_class(tr$get_centroid(), "sf") - ex <- ensemble(mod, mod) + # Partials and spartials + expect_no_error(ex <- partial(mod, x.var = "CLC3_312_mean_50km")) + expect_s3_class(ex, 'data.frame') + + # Spartial + expect_no_error(ex <- spartial(mod, x.var = "CLC3_312_mean_50km")) + expect_s4_class(ex, 'SpatRaster') + + suppressWarnings( + suppressMessages( mod2 <- train(x |> engine_glmnet(alpha = 0),verbose = FALSE) ) + ) + expect_no_error(ex <- ensemble(mod, mod2)) expect_s4_class(ex, "SpatRaster") # Do ensemble partials work? diff --git a/vignettes/figures/IIASA-50_blue.png b/vignettes/figures/IIASA-50_blue.png deleted file mode 100644 index 743de3607b32ad9f67a310fd7e38a6b71fd1e117..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 108586 zcmXtgcRbtQ_x}r}rBxj|Y^rKi)vghg8m0EAt*9+jtP-oWN)fHSslE3WX{$yBu{U{} zu~RdZi2Ty;=kfa^uh-+=`?}}cd(XM!JkPm_*40*{r(>oA0D%6b`U`ykxRDP4RKzPZ z06-yk=?qUUpna!q>IDFgHU9l5`~tkS0Du#C`Qo|Z`>fqXQ^=}JGoLP;#nH;1p&KoI zqvZ062Sa!Dm&vO<25M|9p_dc^3&E8a3+B#xj90$RZeF0bt}Mxu{63-2PIm62ZifmG zbNeWP!aO|+;9WbJj^Bd<9=Qmel5xVuukrhon~|#2HV~D- zoEm~B9)B`#K;Z;ihFPs`9$<5Q6-sKXYh=+>zz4j$VP{Zqu69W(-Tp&FQd|r(i*4jf zpnMuypp^8$uw439o3jOAh|G#9fD+`?AYGX+BQ%xuRw?sj9^7e(H`Y73@q4rtD2-I_ zxp^Y~Sp59%Z5axI5f5RVBwGvA(W@6ifUkY#e!;Vv@U5VgZM{bul!gO;`fjq8)k}Q2 z{YL7+9k{Fu)^dU}uT`GqPIt~#R=6z)kG;%SiMmnuGDBd(JW?sNplxxa_6<|1p67P$ z*l6DSVw>kR>}WrK;!N=XN$Kq8i=iba-B{TY&9a}To_~kRDhM4R!dc;jO-WR9k|eX? z;;tl?~WZrrafR;|qvVP7chn4rQCi7PxUxkv6(DRrD^jbP=abJ6UB()+WXsE0d zdjCJ7j*2efZ(hFXl9x=j`keZuw>(AQ)a^nsBnd zRYeHP`r=n6PzF2yy=A6ngo3+uH?Pshh@WcronbjL5s8QR5`|>6ez>qvPFB49V>KQP zxsr7PLtNe~($IuoxJt-r2u69#X$TYl7R+3nBv1ph=*x;>mUce+6lpcSs)?7wt=5}u z)&00xAG5`r+)B#9u668O2c@AIaBXsO{si;f@fCuD^THk$PK@`dXxj)N;7F3EEb^)> zp$70-uXZ_9O*_0dD17_$NMeYZZm%k;WRHK@i@r@eCi=t^$C7c^6D5rT{aQO=iBvGF zWtCxJuxWs$EyE5%5H+#NN~y?@qoYP+P<5@27l#2!p3R-uCActU5whj6GJYsh#m=JR zidcn06h2hp5D&rl1x!Y@33O&sB{D*k;aEpR(D*kk(M_;Fl zqCYUR@6E{nKKl07ExvQ7Cdl_e3I zAo?+#s3qn*ClU{fEvzdsJ_z$_|0JvLhgdgW;k6MZs}Z{(-$J>0egEVOi?U-ch`^{? z!MF9h`y+I*vo*n60V&n=R)g40#jQ@cNxM^Rw#8F_1&QGhWWsbdQ7`d`iXGZt7xze+ zDnCaj-g3#QQp*eBj6ip|YwjIyM_-T4ZW##(e&xxo{#*S0k}(LSfe2dqy^GD_DUx6| zYeZ+JRK=LEB47QMuHg%cZjTnzz&jclKHoLR@F1vl+0d(@WLC{0E(V=(aWlOxy8Gj9GS{ zam!t+2X~2dLCvcnI5;%Sc8>5QZW+9le$f#n-dgph_s4Pi`p>~df~==kNenp26C%flFOlN@a&IGyo*ZFv&k^yMi}S~YJEzG{ z=h2CcXYX9nphHbl1AmDES#yik*JrxTrB1UMkr7VRK>Eyixla@OuYv>0ch4T&Q7im; znUg9mhCR)iLXlcrAmHYF?Tspcvrcluu<)7s##x55Z+WMcFcEb6ZBji3bLGZ5>B6wO z3>G--AMPFFdVPA+qeNqr4)FEvoaEqPzR^_OA9_E(?*-Oo=q82}>)`lu>m8j{I=7?d zNM0H0-N3E{?Bp;ofa#D0>ohU>$u_HZJs^E-f9AGC6t|PL6t4p^O2?m8v(=-qE9i9m z6L|Lg#$Jb!(GAo#Onh4=P{XFxa;bO9uPpaR_|(!(toQw`#twXxLVV84;pF+z@jUzP z5w%>iI7l2^2Zkt0@f+??(3*2g+#-U-^tr@FuPd`Pu?Sj3>rcQWy*HZLZ5x)c%{puS!rvptCKyxgEmTo_CyBH#_k=Og_ znp^~luqR?X0HsDV|pmxb;?)Wt>Fu?2p<4q>kGxhxvZ zwZ)cbWiV}SHre1XiQ01r3#+Pd%?VjO>DoXpCHM(G$}KWexrvt-!qn6@#uK{!bM)&} zRT-A16G>KG@Zqp#h78w{6^anXjD9B!hS)_Zo zav9ZsL&P3w6M2*7Q~q>{p>?z89G90YTA%5#UvJyj|6!q2&C}IlKXr&TCGBfV@a>Zv zwg{NR8RSZWQZ&tfC+$d-;G`%?=*(*#3){&m_HZLvv4Cr2^$)UiIigcMircj~Q}%_|u`$1Sx$KoU;b5H|0$yY# z0IW69$$>LR-wL`Wcp_8z^xoINbFBAmTIuHF(Hui({QK;g9d}}2)_lzV$ubm+`7j6% zLE+A2&RWdZV;>D#+9AD6Txx$=$gVZCkjytN5)xdCYJ=l@cYb0s<~)5mJ0BZGY6t0T zLt{FvkQEBsvEp*L{yDETo0Ktgv6?;qSZh}qL`0DMv_%2tcVXGpHpA((d3!Nm(d`UZ zw=W%{=3N(iS)pem_yST~H~9o1O|RYN8MQ<45#wb*zEdBD`X{KA&%ZmRib|*I3bBA|zRZk`v9r zlX$pJ&(upVNz++}GT^-x$6^UM@!?Lc_kxl#)aC0^+q54GyS0HsrDZ&m;BMCn@6&3D z6l3yY8~{t^cV&J7LkSmU9QtfG<{*|(3k$^oEO)?J=gwgjS?sSHVqZ@GQNO*P6@1hA z$IL*&IKR96z{IcSHu%E;Hqk8i@Sd7h|0O8T+9Dk^xbCoPdOBVyW0Ko-EMPxC*b8Sw z-sUns?DHy2%|heM6SdpD8Jyqm%6{1249KzbdID2A8XhsviuvT`VKR|1?4>E;rFsiu zYUU|+Vy+wq{&rtR$5y_o`^aVHMD@rG+Rf2I+qI$ccwDfbp#sVWlN}%nHpB<1!7tQ$HahGzJawi5qb;7$isqq9MU1iHwQwD71TrSbPKhZ0Zw#$++j zJ00i#dvLebC57j=7j4%U4&1lUO4U#nUn^);k+-1UR>^fRo7RA%;fnMxH%B(YSyFdM z$(K&1M0s<0mV(`mqb~pVB5t`K+d$Lbituhv+P+=&L`a~@zy2NYpI_^@m`45jqqZ{! z&ho0{NtRBn1N%Q3$7sKbTJClXgXRAC(x9J#Um}EXkkA+scz&&^C?TYU{hLg^TE%T}#<@ z48th%=zLTK#2+5+aK%YH0?PGu3RePwv9@orhk>D0Q(2q1z;9MWR&xg3A|m%4=4<>t zY<1AGw5WCRR(VY-TiXU|zWZF6GS7t|DPYUYh(Q>Yz0w?g#v&QRJl0y=n}fMNa;ZWg z-lgo@5;Wpdv;dA^P7paON1F`Ew4m zH-;>CIY9C>wp_H<6!8=ZKQ1&irn4S6_w>K9lzG;4JM{7PR^7H|pXq$^E|hJu~b6S$i2sF0at5YhIDn=(Z(d#iehD z?r!hGx8u2h5m4@93q& z`GU2r5zRF@d|oviWGDe~HIM-qbZPN}E_DB@e!&Zrs?R5nePOvv?zLg@9=IK5T6aMf zy>3CUKneE?A@N5*sfl&6;Q)Q1%Qq1UMXCUhKxb-cL^2y7UVvqP*Ae%5`rpBaZl4PH z$i`c_q(s&I^fEv%>%e1dK&7lq8LC}6GN7~ns==HWFjOtD)yQy)Y`Y1t_KGmyQJeK2 z*QEnwouN`gH#~CtOybK#D89$zJ#@3Qv3C}z0Pnpk^mG8H82Rz0A><)fMPbIK%l>7> zdw6$UR(qemv&RVwkfQZfABm?x##$hZeXTqkr>zioHPqq$;eS?IakcZ%e~?E84RzRD zfpjWiycQ_cN6^Q#puS?f8!MV@xahBj3Y?hp^%*CrRpjB*tXDc2Lp5fiRzBg=EAc^j z$#Q^^Sk#JoKviHA`h*P6_{4gd0|F0~JQ<0&HMEK#a60Z7_Mpr5H$r40C*E+>#Sqy2 zhKm05=raQHLsjH4*2b@8*!PWJl~cxBc?GJOyR`*hm3aEw|kK?DJN;F z)O~6d7`9D=a*UZk$i!C$kAi}T2SppY$BNIHt5c=#;85qSadiF&YyOh&x8??S&YVNIGdZ3A5bNhKgJ7 zsIyOj;esyW*AbbdoDuXL2+S)N%37V(o+^Pm_}kVdo`&c>lswBvbGYu#R-Xm&=Xef! zv30bJU^DT}=Bjt?PH zM34C{g=|AyUDlET76*aBBeh@TI4k0chkZ$qFmjj zk4A2E7{BmB=R*7Kwg?;~;stso^1cD)AOR80c4$HX*@fJO#PN7;9h}RtM=d=-3M;b< zwZ@sqDU7(ju){0R$D6I25fke_um!+YLs}M&=&IgA)>iWYI6QS7ol$Tkii1lCd9rt) z{+!#Co%W=7TkISVnV{^j`D(S{rrJ6q&8d5DQ<~UKO?c8BJ>qQ+9m<9J(PC~Z$-Ye= za87d;jFGqMIjBd}!dCb|e`ZVvMW%+0i|_gD4(VY>*43gZ&tN%G9ufj(H&Uk6a_od} z#$*ZOP5OOF%DE{iCF?gt&F2H-@e@|hC%r<(yTzQjg;oRH)MJwk%rSwDn|0$Iq=w==#QRgt4vAgo{p0c3YvB8Phkc5uwkU(Ne&+ez$Y3#7V+q;hK2c0(N z$EPfeLh*fz!^I5Hx}Oec+(c>GJ<-N*qn@7C*Iacz<5L+o%CE)y7x&niPAaj3;wQ5g z*-!J|(=XW9YIEV(#W3IB{pdNoVC~a0K$Sk(SxT)pSIKnL*Dh;ZT7B2(;}0s&M+b*} zOQj9wXHj9kV-w)+B!^l~fAZZ0#BB>B(6zxDL0es@x+_7EJ`8^A{ZU?yf0LZu!q-nq z@sqvAO)n*S-)Ai|{A{)jIV1RW`*uid#39!@TcuTN{JLpeBNcPIv0l!J%~VIvn&ks= zf1RtVG!A6->A^5d-u*LJW=HQKE(yAne$-yo;wtg>XKvgmjrn5rC{opV)gM!o5#tgd z(G9kDH9 zt-yckUH*2DTn5sebSJ>>O+Q3hcB%6;0xBi0nr7EM+D?E@MyX%ojTv=NdfsE0Oaue zGzu=bRDh48w`>rskb@-DwI$r!7R!og*k4-$^(%{ii{N6g&F(hMPqd+jCQWx+q&8zo zZ6closEhNv_rkyJOF6#kP&{)F|AtMKKt0rRT0D{~pDyVgJ$q}ldf<~OfROm<>r+Xi z60f90v#(PH%})3kWJlPUh8cph{3@7z82sh#_N!HP(!V@*cAi;n<_(e!yfddhi$CLm zfrv$1%}r=%F3#G|6?j$TxQhl2SBETAIJ)qdIR*6XQi=Q4;JQJmEx50bqE^Mn-Vhw# zhyjP#!{~&&B0<@bn7Z1=>!|S`sOlkUM$9Y3Mn1@z_r&B>EoC_}U+=)=#?a?8Ftd>T zucD*9h6@nB4M~!`$Z83e-?-3DT&;6O_{n7t3yPhV$5tb7dq+VV?EB+He0mw?;^G~= z%r8(L-dCew0d2RbOH$h(hvH4OUw=DNzP%$UALu3?M%gZq1!x?+e3H_XT^N45YeN2KA*J&EcW3zs+4Ac;IeFj~AZ| z;C>3g0>$>xUW4DVPi8dlqZobMqpUuEg`;OW?-_)y{SAz5d%CrUh$wu%Pq+?`I-$=d z(D_yC{WEr<1Lk9Ar$<~Y!9$iI{I9IcUwGq}FvtT8`UG;%`5B4i%6wJCUU|DQ*bRVL zW2HsC|1)AId4H?u8?T+*i05}T(I7t#kz9HS-?(+F zzo*zVJlY_c4T*X$Uk@eVxNuBjh0KSDh$}&=o}(X<5Ic45(b3xAn$)qv6Ec~ulKkrX z;I~a&;y4)=2@t|7KEs3>$foT6qkFt|W0?reXaA6UIDY*2ji4xT!?1&B?%7ChI3 zw9T7IEUg-9Ht=c+YnZ5y4Ww9@Rq$~LUZjPcDpdz%u>M@^GPRC#4q}OpjRQazd(1q{ zI|dbz`k$EQbdsm0cZlcnZ?1PP)jeS37n>$V^3MD1#S-?@2APdbH!MV7LmBh?5{{~p zk{{S@v9v_bzVH5)y*e??%G}^Q=NcG&H8GL!R(Bd8eKfxotUJl$T z&sVm>3$RD;52=8}x{2KQu1HsR=gRXZOC}~U4#l5*r$zvB*L-jWeK+wDhk!M@;+1=<-W6-+{jt;sJGeKM43SAtb45Cp<(xNLH^YtPkNnA zeDA25p zbmm(?$IbjrEiK;bDTN{wwH56wjF0XXOZj+vRRl&pKi%Hr^wl80KujmQVU-bv_%m@;E zFCOZf-^;#FKyL>~atQ4)UVdjtIQ?rY_yjcJ>BZun4cG)B<3`eAUgx~)OZ0bVkV-i(+5L2pG3ps%3N%B$r`~cyR z>v{V|+gKXF8AfDb+=(YyB3{(r+xd2T*^3w8R06?`lsT5K`2f1<%?y`iSFHXC$*?qs zre}^0s~$&}`GG>WOg>&1UBBlo*ew2tj4t$7cEvaZ^_+R(@pllmh1CBlRCitJ!PEUI zLUK`bvjXCIQ(Q0!&6k%!M&HdtK5t$EA|}k2S=&UlM)}As$;)dO%-*}>3Oy1aLlI88 z#5*WGff++(2{NVKytsi9%z)&27DF5@;5(*GofJ^NzLf0Yfw&y1>{@Yapy^|Qq5T4$ zNcBDZRN&h!q>_Q*$p0cQpkE2;1!O#fdag3o?Noe(%;^?5XFdNxP%;fLQApI-avG(h zrv(HiE}RSc%HD+h144|f?-}Q=MaSCeZ%oSF?|U-f_=ka!kvA-!BgSd=My{wQ!FG$pb*% zO;xaYN{vCERY2y;(WO@$6!ZWv^Mz9d`S@g0vw|XqdtDjnN!DmVBq;Q$M=rW#d~1EA zOoBbZA4KLmyX;P;A*)JlZhu!L#D%#igdlgByGyV&Q8L|=0stzU)LS$Xz6nG9T=qP^ zrsh!tz@^c5?q2|Mq`>B{0X4$SMgR!aV;&G1SZtg4u${=m>T}pd0enY@$D1cY&AP4| zSYLWHw?d=>{`)U$f0Ug-Q#+_1FS#f$MR64XuB#_d25>zcP2D*<|KBjIk-K<5cB1K* z6=UqptY_D;d;pLwmPl!KeCogCxYE-go2IF#QA-JgYSZdBJ|H=rsVPKHiZncWMr#ZJ zBf|6x#wOdIZXa(C9$Zj1I#&n3Zl+r1mGy0kN>67L8hH+Sf|R*p<3P4kNa?e*3b%rq^R-h zN!LFzs$q(1!T{>FG$TC*tTar2ofa#Vq&F@*Z=U@vel3zyW#}~6v_@0QC2MH3Pv#}H zXi=IG1)xZEi9f!2QTvdvwI?S2Uf)qsIrQV$U^!WE5a#lxu@6Fyu-8$#nm5 z?;MTxHu{UqA7&_g9wE&1%!B}!FwcF|BE~un=QvdAm@3@LUxH)?$-?f_&oLcYPv4^l*#31lMaJ4f2X2X~SWSf<_(C{?Fz|GxDc`(K`snBAphCw<11F?Q z!5~*yn&7*IZ%X2DU8~~898I(b9P%IuSz@{CLer@!AHnWoSMl+H1C090rkyA7#gN~@Ug86!{p?~~ieX=*b(TEyGwy-R$dRgbwwcmD_2-cJw z^oX8@`4ie}Y>S4W58M=sqj1t8ZNb+S-F8wRFGO*wfDIvFB<|c+TPz*&B#k6ELlJT^ zkq~$FMxjS&krwigDacu-WD9rK+5Qq}UEM7QFc}m-pB@^&I9iK9M^*XZ0xlOjw2mUq zM8SmE(Yphuc;rbQ;YML-U^Ta>t8b<@b{*^8RE4uKzPy|N;s(^RfO{{%J^Sht+wF{^ zS!vea_Iu}}siKfO<~k9=uQ`oJ8g3MpMw>DQwSk=&=&SPUCNF3?_#J$%cq?i^r#L`x z4 zuzP*rOGV|6#h-SM?_zSUWbs zwHNj(!)`SB9NSGtTHkLn?XJB3Cc9SDkN8`-k$YEqc>2!a&)_GS9#-KBpLf2*NY00s zU(s*W&Tsc_G@32C!|&TWJ;E`cOtmmALVDlT-A^~#M(r%`)@v8tAROUL-Q zPW=)7AxC-ej^O-SgxwWO2k3q*liOw@=fvG{%`(xHosWz@t&%cuMf=#Iqf@)xF?rb^ zG2Hcm5zbx(FPPs{in0BbIUG$tb`5SAN-gD1fZj8pajKYFbA)W@Dt~zPJcilHWNO(z z;LWQKnb?SXm7MWfFA1kI(&cqLx}G`L!BlO}KuN#7KGfttKBILXVfQ!wh;L)q?o_iu zQn?I}j(GK0xzj?bktMmmaf=s1n!b;xNy3<(d}mB5_7ow_!;DLXeh^(E8EU7J`dwXy zFsqR7`Q6XpG~yfniwfuzm`c1D0yavzJB98oI=Jgazn8SJlZ@>VH`Rb;>{J;aQXXw_ z;8`K^HErC?xEp3A;pf$D^?cxf;c0L_iEs#IGgG^8Z)RisN|T(r<0xAgHh7 zGshnPw#qOyDu_h-i1ELvm>)LZ8bDUk#oK7EXKcT(6rXMbp+cPgyo&o6fu+3_vapmv zRE6wzG>{siXFof&2kMOfo%dzf%0bx|4_BSZIP6?V@E;j}_Ro(jFfG~VTASU)u`4Jv zpg;3+7F~Zl9D>;y%z0uy7I+@4KfymAY+fD!arOWE*AEv)Rdo1U(is`i2MLm|$#UVF zRtd8CT=vro_ERhG<3cPWC6JI#!|PVZdY>;u>Ejz}X<9=7NcaNc=d3}}(s~(`kBvoN z0sv+nbqf1VMtb8bp) zrs4s53|3>UAURHE>~cc7@cp!;hOJ52S{~;fB*&RVrLj=gD6rL>c1@Q-D?Q7U_R|@p zL%co{3WX}Ej2+?Np>=KS+(MQu-jKnTsz^iMD28nej8eSH<3k~$^sFE>4egX zI(Dlo(=)&M=HFC!{=TX9b50W;_A}{-R!%9iVErwrK)6dX= z<9WMx;atN%mn8ViKaF^g*#dnL)K*xnsUbgKv{MCEkh79HmEj-bJe4&Nnl^nM8H>Sw zwI6ABB)TL_gUke_E(%S9k?_ ziGM6J{?mS4$@jqTYsBNzvj$fx7xyzI%?~kuQ)QcNf_6a24ABo<#S@K>B*kIFd-oE% z9tT^qrFAW=o<`!^MR_K1sm)!LczJkGjxlk=2klSn3VOw0Sm;hQ=vP10>E(Im4<$A^ zn)5ySbMkin z_2m0o$Xfo@pq@SFB)>-?%eY|(tf^RLS|a`(3SkJvUasrXTdenzZ+oR_eT4Rr@)Q&3 zuj;Z>>x)hH67uPc!uglUjPxlJ&AAt%{RjNamXCQ*1=A zb%vk2Gq8GwHIU0CJ!)0$TwcN)+02MGSDkrlG9Bjp#}s&(T@67rP0dyj@j;-nciZCq z;_OF)af~Uir(TY4r01#}WRYA@)6QeE0^p%S6OXQ^HDJSb3-6~9G9|rJ>$kwx3Ll{- zMHV_b)}MLy+QQ89Fy(vSpwhiD$>6SqTQ##j<~p z&TK8`yiv8M{ou<|sK)KqP6?wL5c>5t{~TAYu!wyC|DTK+Eh*A@_gpi7^-WwGGqUQ; zo_%#I(RH>jYs^Qr9QRNyNJ5GV)Pw7xF?H>qmR-zEXDr%dYApqG4{gozwNU%96tor< zWpA89r0D7$9HKB2B^k^?N6Bl)1l{@tmZhk5nzg`ocUqa?OQ43k=-H~cLN3@ZojR=p zxJ0L#C(A(B!r;{B5VZ|-+d9t9-B|6_;%maI@;!e+wb|3U`*~*VEnGEK2-R)5mYSJy zxs*aQ*4@?W^I1+4i+QTG0HRNxe+$dqGKk|<|Du1@;PVch;p2PF2K2#D-U<7i!#f}1 znVUQ%p(btS)=L9=cl%;%hlpU!b=OyLSyE`3%Qdn0M?x@(D76 zGNl|`T;e~~C1hBCF*0l78S&iN{1NY);{R)qwbau($2+b|BKr%o>~P(srtwc#O*${Z z#dc_3tT^h02cnJ;(}Ch{<#O4Whqa(8|0zP!URkPttR-TxIe-w>etffJo%q$u!Up8=OABW*V&FEt_U6v}1h+x{ zD=;PO+4hB#NtoE)r=Y1KSwB}?tLYJFdx!Wd*#;@b=8Bp=u-_&2UI^~%Bs@q__0+<% z@O&EW=5s=gQOjI3;Lp!Znk3$9q_jAExmi6(Xl?ncy4Ao)^+1F-ZUJ?LR>5?=AE{*K zL#ph)ObwBD?fa>~lJZU{Io({lXFyPk>8{ky5k7OLf4YS(rS2nR*)Mm9f$d$z&vE-( zKII>kS#`=q9~6F*g@mr)v(cvUR#}hwTa&fdyME4z))dgs&P!^PbAzx7gd=etdCYEt z;o8=FyD&f zsd0^4Ed#?uTPngS&S8J=*IaRts%H!|dsui!tsghrzk5npWqBkCEe=0|dUiD0>TqQ~ zHrJSoVifyeTPRa!uMq?lh)9#wZY}av1Bs>9oXNb6)bO7sWail4Omk#=&djZrRGBm{ zhVr^sXx}7u%h@}ec`{AdOG@B~6?@lD;Q8FD5KPd~>Sel40DXP9?*_)<<^E{%oa`07 z?N2WUl1c`SI`wn$4XQ!*Gsl%E<`g!b`;9jX`RoF_ljf$X`PGj!GkblqI&?bBuIeVW zqnqr#{zkqQHl?f-$Nm=^z>g! z_{@46PF3Lk!kwMNAV=6`e7(QBSLv`DRQ0A-sozyac5g3hYId&__YY$dQ-@F; zh3navRT;B7|8=>;dl`>Br-S|5_m4{*_xZ;#YS}>J{6v`eUNmbm^61@?|02t1o)z;o5f!ukL>Jz?nBuTj4@KP1$>kk6s#Oa zJ;k0|HKaQdfsMIZHUa-VWnm{A1ZtWHo%?F+%537CI|Myup1V6Rv#x4;j=fG8K8v)O zIjTOH*@T=uto(w2C&HV<5;xfXUSA4Z9eb_`bz85~mN&;$mdN&bqCu&{TT(Xe2Zk*p ziXO7PQj}e(4?Ol#Ym^!J?1XTk@GLd6$94IIzEq5a1;4?@ts_u%2P&67SL=W{FW(Wh zLrh^2k(WA;#9D|^ZTa*aYf0Ia8_LhxrM%hoV7ZXAbmRojHA`wf8GKsXFj>^8b+TJb zMbqXW*xb5n7c|>;?w(||#CT|7mlKo`7^IO^Gj6WeyT$pOe(DukX81QdZwb`x;r*1} z48;NBMBjSDf0#k7g2xBMs`uI@orsP}@h)}-lP6Wx=L06xKFEeULMzGVS}IXhtQP#yt|Jf4BadG-Ufg}W~)BDVnZYQvTF~JIt%F zzNs3K(F~<5{UYl2nrtHpR{w}8I!c$0oJMHMUg8UtbY7rpqE(nWR%1$mg-4{wsrne) zi9bP&y=(7_pu1VR_^xxyOVRR-y7A4nxRAYx$Sr2GFJ7P;P8FhIEC8^Eg81{OHM9Th zAV@Dfmh5Ui2hhF(fOk(nGU|5xY4UUwmU@1fMWC5qeuR8r&n6oJcu-CB)gv;{!+P<~ z<;BwDn1D11G6eaNakN*~=V)i03miNjkj;hY9U9>Ti9I3%g&#P3vi@9OA>`h4{XnNb zAcb7cvPP3)7Z5=gvHRb(*&Q?i;QQm}F`xI?ls?dn{f1v#9W!M=t!(wpDv7tSHJ2fq z56|P73j1Z1h#Us3vkyt~H^(!buRm`lC}su;{-h<}5B&Z}E&Juc5r#2bE^_>ix3NjV z3q?-JPm(FA)K4xwBm=8qb~OCM*^LX?k3Z1ab_R7Z&ayl(%8?s(=928820}l^ckuSq zI_D`;69gyggumQN?J8&n33uiKfbJdoW6|-QBC*u~I&v%k;8wT_8Pj`vnT*mh;Z)jq z(d6F8jrh0SD9uayN|5aL002d0?>FwrJ8~D#ijPAzJOua^$=`^p@@{<5bJrL2f%FOa zlVMe-g!sXhu*HhvpZ_t@w)^tzzwkHr$Y`ltb_S2?&*(a} zcPkJ75juX}_vn{Ao6e6I<0LC~Z|py4uVi_GJW794IaRI|tS!t5Dp>TBt13ErLu~hE zMJD+d(Munq69dW3Kh|_~6e`&4tHVO#%~Jp}Jr7-ym-AK= zKVAnDmgGaoHyLr;!BLL1WNrC$U00)tTJVXtckU#<@`;=nS-hd%;gC`|mE7Nd(6D89 z+}r8iqx)C1$*e9HD<>IfX0Jl`z#}H8jg+1L%e|t{cyQ{!FBjr>AviufSn31&lyr%# zC&2#Z!{n*`T{``nS>)9HqK3v)yTR)Jl-^JRz?(1e2K4c@jmw|@@6&IaFD84heQy4z zt3YM3vXLy*WMco{Kwvhb$yo^>IaORQ37w{#GTtU9FL=~PWeBEg_Ge_oUQtBm4P12f zK~5-HqrX>s55#Zm9d+_!kRJ@bL&&gvs0OY6pUQR9`wq(Fs^Xea@p6%HQFpDqOiy{H zRRrlG#6g-|z?#CT!ti)`^YbhxnG6LnH)@Ic2YHNuj7R^31ng>ulG_c;WCJQYOY%b4 z&1fR|c4=tXtvn|*ZuDQPLQiS`=@Za#JMZ7im-m15_BmjAHe~MyEay`8*|S|?j>AJ} zq+ss&G3FnH+ucOAti!YJkJPuINNgb5c1ZYbx$S|5e?g-k$@0~urHDzP)jck10aUt7 zZ%V^6z~t5tYJX9w7Yv2|D!`Jh)RPdIpOs{Ly)+!4u3ehP;I_O2wj`;sj{NDC5!fA(A=&S3^p?G1At8y7wd6#a|Kt z{-kP&<~zzD!1r?!XBo)?%wS?1;cj?jww6u-ymO*t6!Iqw!u{8S`z*f>kNhU4e2bG& zKzN0cWqQ3g@{>^A^GBMo-*G*%w7~ZdY0oL(H?lTij&$V26ts=bZs$3vEsYvv9yF=ETPbB#p#v0K zF7f3_$dvYzC!e=^D5cpqyMc&KvbH*294NB9@siV)DU5xFp+z^HcOukLZd2%c3O|%>(Fp?V9 zjD39Y-$Ny95jGtq@@CT~@%lC2y}Tz&ua#I^88{Uwnr>xr8pEEGqi?r>^8Wb2(x_Yc};|Feei zqv;xstt-GtLeY<{y7c<&6E?T6(e$FO5O!kZ-WoS~2E1a>))89WbMvnOdPYsHO<>D` ztEmONRMBbC<20yfHOk46c(3`YVn}C;%(`6WcL=V#?ibZ|zMh7e_Gu|c~s~=Uga9p?J z*BKNUh(`VE`IM|cU)SvmhQ`S!AjV0RGn@2 z;wH?}FRV4rD1SHDhtv#tw_}!4g$SDq!II~%2(^a~)@9k}>R_{CPFl5ZwxvK;g6rs> zENt$B&ASM!{@-AAew;Tmp~`$Ik$)N6Glkva60Y>n+=ajOF=t{qogEPs8EW_}6w)^? z?I_KjxgoKLOiJ5Xd%`fiunLDj7mEU#m%$OOSfpt+>O7l?k#%wJYr;A8R|DD7ZX6fo z1V$Az*4yEke4=YLAxXv4{KNB%kc8m&`Ojy_Lt`<)%y*WdtmaEgQ+5>V+4jUMtJX%I z*b#IL?c;38jeH^0@K|404<;^k-yyS?CaWfQzQ}@vm|FQuKFIv0gZ%j<)9@lu|>;W&~I?(4SSE?d^jVVgMaVrhsVejX3z&g36gvT|B%mqg9w z2^J2rD2L<`KlE_XHxuK3uD1i!u~3qf$(I;9#_hV3panuuJX?BJ*YK3LI*a#W034L7 zxnmy)KCwh%OYvP6vk$7$zdrJ41l5{Yx3MSXP%_p&BvsPQL`7O6$0RbE*TW_XH0Ntt zJo*}k0v`1J)|W^UhUTRC#7cIn^|}hDQft4ki=pV1!@-Fe&wV;Ue4GnDh?tos6Pb^? zh#9T3;_1?Oi8+#(fk>akVd_BQf!5U6VCzgDvHjxK`j#ORA}iitXSPJLDBDc?OT(&^ zL)mDnJNFMSUeNy|>Z{|TdZPB1R2mVbOF=?HQkq3Xxpi&ACv z_(<5XQ)KKc-2QW#nBev6Z!2yaq(cE652RCkq)Cp++KVoNa;6)L*o#N+R6}@GY%IxJ zW8DHFqkw1Sl)}G15!=p-$B+Ar`L)f7jK_SilRMHk+J8~owAeV_uwJKOv&|0~F#Sw> zR@t;Hcr zvzJvk*I-=BkLFL=R+wH^&n3ez<$=LEt+A}a)dUa|sJlJCjo)^!km#kt3UvnpFPB{3 zcx22lcu(CJi;Q-`>3>`rI?A%!q4*^#M(~RjbiXp`VGe;oM=PvTO{57X=y7V1qG!Qe zKmW*&dalkETF+glIQnJ9_!p5UAweUlY|FuVcqkX}7A3XR!W2v{PdG$3rM@@M#^q-& zPw=6laKy1uEcCEto5hAj@r%wc?Zg{G3r#6@=b{IOTfCm8$xC}lR2MEw@TX20am;wS z3L#(l2IzQ#hz)lcYW0ltO0dxO$)O-LZNHSx&7h_d2+7VbN4hk9=nSpXI3QLGNb^%ChF}IsW;U%8Eist zAy!XecpQJf9&62ezLw9S(?gEdx|~38)dBx^Uy^{cr4$1_Q;iJoV?kgc73__W5+bC-`!JX#CezJ zW6;LRax|Jvep0f=Wz9ClAKz`Hd(8tAINacj(CywD_QWEjb|=xD5**@IlodmI{~$Vw zwznyD49E%B%5}{az-kvyC63sLExufEU$WZp(MSXP2M)WV9wt38T7l00jW5oywm%xa zhf^z&hQOwL25&#HM6+?z^eTF5-_;xoD70-)5}f&{?-cMscorHgXuL9yHc}yJ?wI7( zZ~+j{43(sU@MUXuDQ>=PdL)vfOn*OpOls1Y;nX;1LDzFAv0U7WQ%WVh8nHFMx$*Us!|;3X!7{Y+lvcsvmlm|L!YJC~8b3M&@j#|Mzz$9#oz<6os{-1rzy>A#Z>T5mY43+rBldTc&3*-T~VMauIt2QoQi_&l2lP!JV4RC zY(p(0!kXGX_cf_EESr-HG^104pBaF~ z*7{zYiFxb6sJO=f7$J&9_{%(xhQ#Y05X5ByvuJxBhT%8jisps90Mp4FQ2X-9mH^de zIAy9I5b3B<EF|)-W;f%|Xi=>>02Pem0=+W~EVrIHL;n5$7%a&# zI|{_HLtVt{?Nf!P9emtxfIxX4h+6&YZGj@)On_+36taYZwLV4lAuBr8&V*og?17!0YY@1p~z?`9UK=}My zCRh29&g8MZgjB&6CfoGS0l=U1%)Yu01cPL!{yHwk_G0Q0SRm%4;LL4(SWvuk-f6rt zpXVy?jj1(!-G<$GKJ$4G$ooV8&+oQlH!Pnstw1x9 zGN|#v)KQ*q6*nH<_6N6SrT3Z}kej3ULZ0|-g)sw4kzoML;IhP*4}xp`4HOUO;kj>P z&P3MD-&FbhEqmbIY;5oolF<;#d{Ibd2^zXGAQs}<+mC2{Hu%P-{k_aga_7_qsi7C> za9R58*S{bnMG-%DS8ndwuF3i;E(e5`>m0I36(AQ?cs=(JGx~C88rVw;APK*9LYFs5 zj%58)#T9g%76_I(XMY~qr<;>S?_E%bNXvp_Dafy@ZWi# zG_o%Crl^VM_-@4_^uwvIrGgpRvJ|AQxAuKa!)XQcKuV)oRqZANl`sTmYar)YOGA0} z*VP%TkWy@0i2M%_=IQNFN_?k;J&TZz@F3G7$Xr&MX>0fjEk* z^T9+qISj!BpN))i4Y#nsYLVaq5xzz8d_`wFhSEq^V!`|Un?|pT+}^1>qAkBknta!2 z7yy;U0Qa~?E7-wfH|#PJJ>!Pdmxj^7HRgWSqZps5o%TwOz|5Sd1It&qCDV%Jw)>}f3fdS?SA=8H|G!ALQel*eRnpMIXK zYH0B5oNi&5^xeQ*mCf!6_h`q$q82!!X()xIbkOaclE<$JCkUuYRj9;W|+0ub)^Lk3bBv&li`yUbgDshl&rUO&>IY`3?mgYy#-44 znl3Ac+q&ZOHX1G`rj7UphZ@sS$CteAfw_qR$V7A_mr3O25Nu(n6yg0oI5O3za=PbN za8_5rnAY|1*wzfi3n%+DZ{v-pauzr#@Ggy3zE=VHCv9`9f5nz&oWz@h$dc0Zpy`cU zw5@V}&8^AyEvWO!Pug2`v#7s^&MKXcJ35T~={Gyhe5*L+YJBY-(U>l$T(ld_>zWr< zm7qSqW1U1hex@pcVwtGp?On(2KZjjaSj58?92K!43&)io>o*TBUiGOYGWX4J_VUav zgD>Ko%%b8P;)5Y$Cu+fOcZQ;cPmPCj(yCCof105hu4GsHm&jk4>ZiFAl3B)G-i}N6 zQLSr%>XYS;n{y~1JCz@p`}w~Lc9Z8APo;3oIYa8`d&%{`W@o1A_IYr@ht{TKJNHt~ zW~`nHKM$Eye!k9nCce;#x(iGN>K|SETciauJ{P^`o`XIL2xQdY|IToYmKMob@y}42 z%h#U|(yB%U2ECVC4qz8`1tz^kSFbut6)5ZjSgIdvyQV2~(CWt>kre+wmF zI4|e>Wz7jLD>fU0uGBmD;;Y$YHeWit7&?Unt+==4->mj39PAD+$7}C*WII$bJe!?{2i`~m;KuCV2uV+-+<%cVk^R??0q4t&MzKa2CD~{s1*TJt9#}M6k_0%T)o0k z%h=PgCAP;}e2&SwQBy(o&Nk%uS97l94cL=(t)qTQ6(L?qby5wp^E!0(Lj+ucCRffe zE4+Kx%)Z0$!}iYP_X`)o!=>9J#VgW*->UvBte()9 z8}rS-fg=A`X(x6-C$ru0;=%ei_FzYulnC0U&i3`MQ`<3W?~gP5)ossI(}&*L{_V>= zdUe?mpx_p;*?j*wpu^Zm3(Ts15#>ZntJ~A(?gXx=j z=+72X^iV@31F4onIlodOK=QsAk&o_bJaNLpk1mW|o))RhKMfJVeP(KnO`SabsB|~AgKGiz>AZefzjv!Y!xI;@~ z9iOkO#irTX9g`r$8S2MqWVs_#Y*I!e-N+r8c^hxo)T{F54v!!OryGf!>xLeaWaT_G za!%rH6g^&6!RIUXQ#{+B3dbbl^H78{j4=f)-VE=Jry=}J#ZX(ak$V)_*;!wthNex} zk@#{t)0XyKsF8(U`zAM>$vIESiSGw0;N~g|rmUWzc~j|1n$5TQd$Dr@9 z#&}e=__)CjGjdZM8KAL;zA)?$Dk5AZ((L`qa%A$ixKKXuO{CoVi8af|L(DkIuh-bY zo=et$E=k41`tJ=g4_5V8417t5-v!;!jg&QI3u3&K^h>Wq z7*u2sx=U7x>PewUkN!s~~%o(m>t|J;BOe80S>5$`oNTX+BqB$N6TUBIrB2w?b&|Y-%(i4=iDZ%T@45Fe&T4Usb?w$ zRmUF-czU+nSrjT}isMe_z$7n36pWq@xXlS?1(7a~GCGcIPSyCV802}*O&-kO^)kNW zaFP064k> zAxh+ZdqRc`;ei+f6fe~_?e-WbYN-E}SetnFX+?)SM znj_M2qs?bEE-t42)x51(>*`^y?4T8+bw6Y&RU|D`pFeX*Zzd}=qBr_p z%sN!-sGTOCtB@Yx8M5jvQ$1Odwo)Mw%8K;nh56N7s-{bc*PZgIW$q^sl7EO9g!wyM z1oBv>Su5anvcK2t&7eisG_VL#DH#P*lG^9V`}xv}36EV2wm!_f7^*GgLyn8>e+juL z{J7JpWc*BkF+Q#@yiHp?e!MwNK{$g8oc;id*=D;TWwT-HWn@DbTILt83mpl)+v5QrXxy&v@i*9Pi??9NlrY)F39b+z?DdN2-s3hZoDNe3lxl z*=3O4QFn;fQ9XYH$G>*mbDep14$+g^yDSe%VJn$rcro!hT6kI*ovf0{8FE3KnAzhy!$~24tw8GqXKt4xdY7CB?IXV;5 zr*?xbU6U^Xt-hr~9Y# zL3abkID>BE=I;2c^c5d=$zZkb*5z=Mj?HCC1zjPaDiF>zr{A(@qmHkR#eHV*}j1wksVfn{e!_IQv zvGdA>kss+xXa5;YSIo{xip=T05jkep4+^F7Pc>($Mm3i(wEE5D+!HSQk(smUUgp{J zbxPuxDR%C@tt!0XP%SFY`_T$S>@f3Q8^(Y8W~!u4NXAO4=Xw)~G7*t-Vvmh#ynv2& z@i~S9yWpx48^x#-4tYHQGslVDwa$(AC3rZGFD#-U{h+wbPz$jyb{?X z`lU6qnxW26T$@yyHhEz2K<#W#cc!hCqHd%g%kJb)Ip~=}2)11VeUS?#&9SN=?)+C% zoO!DmJ8htr!q%|rO-rmn4K{))o7tw|Y(J8+oZ|65pqeTVp-*g3&}sb*?zn(T0nxqu zkjxzy3T0C)JD25``>u~$(XpGm88}mx96kFu-{KT_|K{Oby|$TbU2U*`=B^tDc6@>0 z@!tZS`u;v!jt4jfVJdfo-Y86c|L#Sg4%(|n0rd)Y3y|lByx!RRX!r*9=m$Z*)!VM@ zWvs?w;#zJ1^gcoiM5~@ z0w9uXr(3=%z?&>}2msC_ZT2!okgA)_06czpvg!J!Au{jD=RGy^NO_VVTy}u*V}>vP zxgZ>Mb@1t!Hb|CmLWK$ZaV{%tQ4)aZS{{S%S(F$0I%x-)<(zvt$P# zJ;{b%%OSCC7lZz~5v99Dr)OwU9d_XX{nY2&aPn*b{?iiYh@Xk)4NjMr6=<~&FUlb?$X-Zl2CHSnjLFLZ;QGDYq^N4x24u`T_!V(_039Eq> z!8Sgc3fye%NOEa@`5Es9K!$%9_`v+1)!~0ZTl@MGZ4?dcFV4U%_*`zCd>wUYHh@0n z(n~{mGdjN}9xs_SGwSDwhvQ_8ovz0}h9L!kl<1L^WON4F6%<$@JUKgSxY0K#YdL*W z=LrBmRqTF}AqL0{jbvUS-|Psrr2KtC7s0vJgJ13*B!%zFxun{DXoFuY4*YPxuCu% zDO&)^Wdzm=q*4s+bmd(B2;H~&)hxNO?(EWE32gl-%l;kMz%i>bNb+P;_I7*gfW&(b zGC2iGMqqq{KmfJk%lf-;YXz~$FPiFKfM!}O-<|4uFoAZ|=2jzayHDsRakOj(32tnr zj#q1ZEDM0tzQ3!Pef?Pg@k>j&byK=2dl4u{4i5SAbxPN#fg`SBw}A@iIZ);!aNQl* z=ylGkkx@c`Uqx$))1e^pjJ4_L2LYN8q@8vLpuPRa1pwe?8cKgZ;4HpHreN~-!$4`= zd-*=PUMJ{|Rd20%U_3Se<1FMAf#&C@%|G(*ok{N<8#{gmMyb%S4T2Kb13hCZ%YM7r z$tIn2lwOw5;@|UCT6`L4uU8N@-2W|dJETLVaXGdEuDH5N-X?ri%LRbp?kBHIwI$@sgf~)ZZu9Io4{~>U?^a>QGvsg=}@`!&fsHy-7D(D4;7* zkiVvbmde24Vum!6ztXqHO4}MT6<^@7Mih2X<>cSX40jyBIRn0Js8DxsXRG z7ve3qgtPa0+~uful($+~)x_n{_Qgm#mz3 z3G8XAV(zPgU_Y!HG0b>$t3_t;7n3&GXoXW;p7~joN1s;#>AIQ371&Ph7p1!`KVRz_ z#HQ|{h}Cf)7W%L2E>-T7CtrtCMqtDOul!O>0ZHCqQ?i{l3Wa)(WCH(gNr!hDIOCLD zZaIe&H%gfd+hvTS@z#K8KGP_*)u>{M9~20^?R92x4dL32LIshZK(im2!CFKOoEPS| z-V-duP(Gio_PhR{M=E3os_Lc%xKk8mHZiwr9H6Xi-RY6~_=|t+Mb-lM>9A(#?T-Je z?Lo~4|0*x?s5i8D)pz}m>{vfOXO|+yHADe;Q_wHv(h5)P2V#K$lkRFC1qbvnB^UCQ z>a1LGz~NS|KOVh)x4ZC5|7>m#k`MmNV*m(&>a`Ye`M1)s;c~?Fax$j^JXMgcvi07t zxO=rex2Fu0uL36(fYMpOKRO`K7aHFI9w%Q5n=+#OsS67^(9Spw7U2;!HZ7HVXl#7& z4WBGv$+sOAV%Q#d4Q&YF%4h;ufk1L0zk$o*bQ9kP7H)16X%8!5S*XeX{sVbgQ{aJA zF$n-C?=}q_-bmWd&Mm;vWg*`2SX?KkDpJ6M0Lg{f>ubnW1{i4jHfdrd0h6H~UP^Ed z{pNppF3%vGQBr^bXDYb2pbe{kt=$Er-0cGdPb-w1cdPt#uQgy6eaq+s zfmFYS1OlJwWx#MgVV{{%0VPd1&dk5Q999KrcR2cQrZk%;A=Meub1WwT#1VHTS+_{i2AyV2<8ug#jDf5zW+3o zkeI^(TKxrR@VfFm>a1N-RkKm&zhYS#FR|E&pSFeiF(5d|B-Y1EQNTjb9xqo7;1FbT zg>Rb$@jIB1vNcMX`7(xFIOCzP&?lXKOZOO7w}F)|AcdvB#AUU=*2+MNNecWr$)eEOyELYw*@< z0^X;kvOPT8kZG||oa*npKe!vEq`*)Iyc?^876?oPtj7Ugafz|U`yhJsPcN$pxDhOA zGj}9OsDE59OGB-GHM3()pWk|gQ{a^fqzfx{!e0Z?u4W7ap5Q7|r)B7^H8W`dhkF1$ z$@fGHObT#x=`>*Rz`?U|ebx8JGjFN2gZuyF0R`5X$ZU*XaJeb?g2lXYLW0U<{wX%o znw?P5QD2Sp*(gw?6j4+b4^%tjUHor^h_Y5}GB=&QNufIrH3r1G&#u}S_P9>spXR|j zxSlM+3cjFt)m+e2&8-|DHS&=U$@428eln94P03||ii&gp-CH&|4ZsFnVbwEb+A0bC0AJj=;$Djqtf#y=l?!!Gg%X#!@-;bVFyll z1-w5_a6lGh^l>s7<~%{Wt>bM9;LO9`5YY=5coKYnk+ z^z;*U`YxFz@#@m_>=Px*?gOnv^79PY`w7Fzs;;`6-`ol$?y(Nu+QMTs&}v#-<4p+moKpnE*nKU&=pD<)qm3C`gOOX1vX@w( zcu^!V2QqM$Ntf?dUm;T^>+N!jHC&jpfJ@0ZWP7>qyr|W&ZZWG?H|-jUty(fclu-$4 z0fb*Rz*(*WJSvciC@84(gSe4mbzy``Uqd|S$!gVOg^-_-Dwe7)Q5dGMP*fN z^^zR3mFFrp>>#t8t2OB8#QBB(aq|2U9aG$ZfasGP6_xuOWx1?`cZEqV4cX7J({%Gd z^J^c;S~i#eaCft<2Z25!gKBAxlP_8ox*sS}l2>1m>bb7A^h1x)WFl^}nU%AiP##@05S0r-iVrS@1xmYw;|N z*uVU<4>NvXm^fx6xg2s0{vjox>`qm6%$5FUSY}vllV+c;*5cQBx4X}73D4 zHo-wI3%JG?l3;S1oD?%*10{iDMmeQLv~5w!o_U6hOp%%MJ!vIdiDJ`dVt1r%`L7we(kV+ zQ9h@9=FXP&q3`=z^ZdvA{ZOR){_hG8=s;Dgtq~Eb143kbQKHhk-{BRC_6tBw+zIIF z^6p2BLxlETWw{Sl4NI76G=x4$d4M2JD-A;UIvUzQOsstF!Sd&?*j zj!PJ#U@FbN;-Ilpw2D%b@t-^|DnY*W8c9ZZ^N~?ZJIp|{!qV<#eusI2W~+pWEt0&k>1E~It2W+(Vg#i8;O zmJ}ZKrN*H?3QD)Wm3_YleZyAdWIO-YGD3dVNVe8z-6c?0`p~-}77AObxZ#;;;2(Xy zE=gB2I>vwqka1c<$+m&tSV)Gu!qQ=~1^9!!wD24{^c@ zS4GB)qCvcuOF^b3nB0Z>munXf*>A=azuxs_?7YF)W1pyWqE7t}CZQ(ZV4ZG(2HUO3 zpD_Oh5!b>Q)-bERpWp47ZfHkr2Nvw8W~03>Ht5%XDg>Huw>58IoT}m-eRJ#a$_Jv# z&hQFFtYoFl#e6R3X~lQ%_gU|1kg3!-y4&%*v~N&2H0u!APYYdcW8{3; zTH+ey$aQrhz>}1GsLeowz-r-^uCSgklE7dg#)A zm$%Q-Pc#B8pEUN0@OK#P2R z1I&@W-%uWYq&;3kDZbKwQjyiACZZyfytR5YOJ{@4z2Agz8XtQsi3W{dQVWR)I>mEx zZ<)7WPY)pqDDWgxABz$#Hn$CRN~IMHr2&DdZ8K~*ZHR8TJQ@q!qHERKa{*cTEu%v6 z0y?S2vP&IvNsuRu)K|W*8o(nR$KyF_$x!v8WulD^d2?CX4Nbk__$uUHM?3#Pplw-h z{zJL~{qH!_6{(PhgqJX(EAQFa%G}3~jNZ31DnuYyK4I_I8PVIFbP8Y<+?m{1K4b+o zLVYl-j(P2pq6vbcdftPu%tRx|h{f*f2u8HP>+wO~%a@sX6(%7A+IR$rKvZ&nlp}!* zh4wV<5dl*TTrDJaDp>hz2xcg`4ll@Si9p=Qx19PD^*ZPZIUu9d53>2-Hdj8a-zmf` zn()-d1QnLYPufB7HoHdZBReOVU-LBcnr#R0a(9sZCGPlFENF=UE%n#CJy(!ldOlqi z2z4A=g_&C}S6Fp7>M_oB+Iqww(Q?q5_vee8t#`W0Wj1Q<>q;ekxNN&1n^7d! zQ~g@UNkLAKa!^6>>7JjeMjOb!@2>b>XO(BUHkJ{@om*l+?J{Z(%IzhzQSs64*m#An&|LEP z6L$3+9;CO`)ro(*Y~-CvTt!~pB<{pM&3??A2Xc?_L7Ea+0PBUL?ZG7NAZCUShxIwb z-j}mLohs~*3!$_V?oZgA3)(KHo|Bu%Qe@!8zIiN4Z0D7xba6UdDp%m<4$%PXy~p<~ z9n!9YE|cC7hj=OWm*9mJbqnudZ#=J3$`!#Bz0LZ5$w0vcGJB{*=~9060m^ysWIGj# zHoOTK)dSy6a&z;pRyY6sF*CbjqbwQ=)SD=xc-*2~z!jp&zK5NRI^~#0Z49*MEc*kq z;sapXasF*fX`uqFzs~!VdGYb@KZfmul<^zOSRmhCiQIR?dNH6a+5tbrys_eA)1L=A z2R^Iyg!w4kp-EnFPW98e5@Yu4nXWjkiY{!h0;?8SidE@A^tXjS!9%Ms2>dVQPQy(> zP^k#qYL;mxKwpm^v@b};+;jjgH~H4+?sbUx92~{+0{ep()=_JdI<@yPbblT0TT{?z zIsU!NJMGh<-=jp1RaWT!@d0t5Pqx|bx7}SHPcC;*5`S?lJ_1_LzX#eP%7bUNX}>z> zugHa=e{MBn3u{Ipy!rbxSI-4?i$dJ`UA=#86}v9J%lW+cVgNxRU6IJaEG;qk3pw+$ zbaORWEk-czBE+y)v6p%U-o znl;11KMp*frsx-_buB$7oKzZTK=48 zlwuufni3&i{5Byi;4Z(~`tJlY?!`1NFx@-~Wz*itf=~^Es~+jL5a&RJ#ZA**V!c(# zX56bbOX|!kJue-9S5cMYoX8pCQYv!B#8ibXZPhX|mth$3fY)qVpaf`DM08b3 zaE)^vAv0-PWSRVEk{6L#vbMq_DCdvw0oXm18($P%_ZDAG3%(Tt)|?A0Dhf?R10%aW z$lP&I8M^klXr13RvLl^H`))nipbwp|ZDnn$I27AHpYs5Ox5`#F(vWSg73?(H{742; zd}``@A;e2X{g;|-M8-c0l9St^Z(Rn}a_%AWXS$n>V|>N?1sMj4i#wVyj5;x2D@uFAfIYTb%C2_Gfm#;{r}q@A7Fz`o7kS6Bu0!cxU%sij{j3AXjBI%?}%VSgF(Qa zbs(7u-{M(Mw0Fsnqi^qg`VV^pRVaQ1g$!25e50h`{C68DObN(Q(b0=GnS{OkzlOR~MgQHVuL@{*apwAv@&5`wyk{KBGskotfPpweS8kpwmiP5W%p~12)WEmx z%Y^qzeN~`ny)7Jqe}$pZ4Kz6U4Qy^|mOMY?@(Bz_P!C+!VnpN2;;z}m zFlgURW}ryPy9P)0SO1Nok%O9;m-4vPa-29!M*0*(`g00a$zq1p(a)X$2XvNi?xB^8 zut4wbi|lLKCb)bf05+uyuABT)W+R+`&Y;v_682SCi^hs>nXX#VeEc8o1Ud*&rkpZ2 zdDKhYvi$zh2V6o!p?%&(CPNKT+vZ1o&m`qVkM69p$B|Az-f88LQzqWw9~JGg8$9F&7W;NyTd$LI`Gs|VYISXChzy1-h` z!DA)L6LapWuHr#|8|=Qq%6d-U{L#mRe+<1z`u!jKJFE1gN;)u7(uEXtA<4U2xy~m3 zi*|afAUDGXi9JYKyi9yj!>JZ1*{T|^n=p}s!+A-Ik=+qrz&+#sRIq>01u~CKH(|Lh z%er!@muA2Zlnm*_PUU|FT8X7o8;U<&kxArs5CG-ly7PcuUu4Vf8$1|MmC z3Y)M{&&I`a)_P#h2rG|Z^yX@Are;MG=SQ5czm`bAf>>qtlqlx=T$Sm2Us+S<>SkGd z(fN=(EJMK&a-u!b#LA8Bkf2OCo(ubsq^@^w>yyM6=Y~hJrt7D3OczFA8mh>7i6@q} zZP*88Qfv1HNfT1nhi1ck+R%BC&G7ZgVD}4DoHvY07YJ$^J=}S+o`?FWxpLH%;p%?P z&!&{PY1UL@W_^a-g;3xYHCHx46n~PD$DD1{O%YI12!S9LO998mRu-n%eeHR^m)ac` z-;9AcAl)8|JcE@`S^3_(hb^6>P6-P1n_B8!5_m=qF}sX+6gj!eJ$*sSLA{a#LkKfS(6{sy}W)#6r~{*5x80LW?b z4bC__P~dCQOIaGu_%xTIfxxf}er_c*z!(@GkpI0`lg$URX8Ghlf zfL!n7o0}JFHe1*V^q>x3&9?9bm(SVqyY9dP0!3dFVltXHsd1wABK$8~|FBs}cg}R& z4ScUW^2I`WC24$O%2rLugnz!MuxKUj1H@BoWr@=9vVDcFt*WK5(pj-XE58J8MmW~5 zsysSL7A46SU;Q>4?ref#K(toaN(q^+_za8m2PA2`R~@eKxyPn;k;#lUTQng~V<-PK zucux3LG75LQnJ^ZCQQ?4ORtMcu)-CA1{ zZ{kn$5U3H_$@(L+A|9G?VpaM7d{WmuK*F-#xfrNfc`d0IvW0+F3C>Egn(X?c-GWE% z9I3P=NCaH&4v*epL%L?7d{CQkzsR)mU{eYaGMbeN`aR!SK?W}mtNFeydwAy$i4<|A zjZM33-D7>$GeMuZASh8|NedO*K$vZ~3rrnqxH3p-lx5$S=p<AT#ZPPb_Jx`gzKRfXDw8VHzHm!t}`iY-u;Rd0Ih1@V&wojDiY%7stIM-|+q~j+8 z>2EH1>k*LWxz1*sdK^wMI))i+9~tKu5DQ`>%qjd(QBc zEOyNen(7swcsrAPlDw$TP?H>J_rx_!3}dz7)He2)CMLT-#<#kUbNu4UA5PL<)OGFK z1%;&B^YD*0yUE0h^%wXikp{bE=xRA9E=mbI&yYw-TklA5NRVQT4!j3`?})ypz+)R> z+At=yz&mrIlL)_BqZS(cqFDECl^PNraZ-Zy`yzD57yPg*=dc>9V*(;o-`Tj^RQns6`7a~vh}cHJIfG&ecsX=ivN%qK)dMtW`6K zoOV^}*=N*bN|gwYpsOIg0~+SoapIGUU1gFGTyvg7 zhITsTIfw4R1`svzyq4eho1|`B`yZKOwYee3ryiyRlUX!qz!zE%zIk0_`Rm-eiJxbRU3JfSTz~6zX-?wl38G+yM^A?8VI>A_*k8UXP~-Lk zeRl+d{QY{&_3cXTNXOP%SLs>ZuY(nz6F8g;3jb)J=dpAMcKw#c?b{FWuB>W(O0S#m&EzrTr-PlK?+{b;`d#KuV*gYusffK>PmuGBZx#o2Nh8rvKGS9!2)7peXwIwia&C&MS0ZlpC^yv^Cl7ny z{W6Hxu{drVE?U$f$`I=NbS`*KF!{Tr*O0aID5n0zJBv!9p4A|yzlS*&3|{hJG0O3%xp|7;*;1I76v!7 zM2>m)Fs8cMY$jFBi%j|VS)P5IUU2?tShapC>$!sGm~i-||rgD^Z zi3^c?i9(tc#8R83M-=h>T)1=sDTdY=4b+#+{k_kSklIs%AvIzMTkseB9bNGFba*x_ zSHm}EC&f{KgL;~2?5}$drVrB1YrLd1n3^181G$u|74ZtIdw%!d&eoJq75>|>T5eMh z=Rba2ra{}33#0Z*S28IYMW@tD`(^5ET28NRG5z>fv@LD3i_1g;G=%{wy(8;COR@dSR>~lO&d*mFg zIkw94K|oz=mM(~f{ni{6F!3^nKL3mBXkZVm>_`l&3=NTeDX)j}U=Y~0k zX+*HQbm%^tPc9Qnf- zoKl4qicEvbCU(uAipvI_*~CA(9t{R>!D5I$71F6ExsE#J{MHHMr5F+!QL5h>?sWb( z6sY|R;hl|ClTn%)d9}IO*Uv@8`R;^9>5XU%M9UP`6B61xbU8X+(8o%gS$Wx0 z30cDpQ8hHlB7s2W4n7Hw-*V5c`cpld@4(&^(aS^V|9S*95!)<^smRF~6Sx!oOz|sI zOwJ9nKi$8R*i#2R9g6~7oo0C#jY6hHDA&HxtKqJ3nE4p3xS=rGbie-AjHJuP`lXSd z?Dmq(D*2WT>SpCv;#FW*ntNF0tB9zV9!OgDct;;1(UsaKAsNZ{O5+AS*@K2P z#%z?<*f`_+{VYm{gL&AioGk*&Wp&DP0==Vcwx$|=a$Zt$vS`FAbZIg;nc^uw$E1#-v*Oxh2|}GlS@DqtfkvLN(8j5ekgPFVKF1M9SwXCGqWJ@R>aOhVV}grU);Z*4#6mD9AnaF9GRdQ z1@WUAXbzP;S3-C1K(QwWeiL)${es&A$Tdcr=GYG`!~;bZ1D4-zjSK6CMDTeqUl%J2 z@Z3bUq5sy$U`u+JqO(lwyh9R`RJ?iG<6nDIPtK*aNV4=7O0tyFP#Ua~y~GM65j~CK z%sUm`cjEU(Mu`?%@$j|~I7aB#&?LAY&Yj?&RiY*3056J~R=%-V7qw60{Zmm(Tb@>O z=|ciY;-*^9Kh-r#UuBhhmi{Wi&SQzmGB+&8UG>j5JpZhDr}Cxg2t+5!O5YUl(58`K zU!lEcpZk=-Qy|BUk13kaB4p)D> zH>?(n9K2BJbe=5tZ}i~dz-)FY4dU+k2L~wtHIgF&MlSZx2U%ttCvC44O*b`Ynt)qU z5y*|5UY&Mh2hoAO0@5EkRY?-(J)2V}6*&ifQ7b1o^4i}8qIr_^LHkt=3*zhZ-c@~V zt=ss^-A{>xRPZddJIH~8(1EPOP?f4dwWGEo4Gsa4GuiV-0W(Uj5xz%V3fY95?BeK@ zfpRXYwWa+$M3ThTuBWtF3)xEAblIMcO7rIQ#zK=I(sFD+%H&1lX_DTn&v&mA70BFr zci@+<^`c>KZglNugrfpy9EbeF;yv9vxJdR2#hzPzH*uj3(d-40FEUQs9vYb>a}-Bv zR!Rk|d97&0=#%_$9kEW*J@_KZW}M1F^~~J+^YW)Tq3~U_%ii^DH)qjZJYNLbvq3bY zw_4v#r9)_kxaim8XE)<&i951jHuN>do388DUtm5MO$z*i;h|4N#$-jmW2$>K7=~mD zEabbkSzP7eM+#+#P>`tO;!Kl)S&cX5$*sq*6FXWLed-90ALV5v#{~#?$&K}RWt;+I z-GkfTv@?Y9lMR(~A0cOLw%=7*$eHG#v(_kesn=a8Hg>qE>?W!o&y@#7pC0*P2G~W@ zGrD9QK7+ckXW)8Z5Yksr5hsif1rb%uLU%r&jdQoVc~nKr@x%=L1pJrSq(an|3BKwS)Mdb6-X1PCK~sEShvx zBNX)8@XX5oeXAH$Q>aoZQlIyaDebZtU$ZWaCkzX53jFF?%tCDcEgRIlJ%oA!-hyxdcviGD1_0b$)-;nR|>q54VrauHL(MHa^0u#_eDgI6oA&Boy}j zb!N9&v{}x}JYl1walNKB>qW!t-9mA-RWS2={Y_`Sz(XU029a9iHW#;JxAm#M^nxgO z3^X6huJ7vZM|RFTcrA=8RN|K%Co%F__0tb(Yu2R85<~BR9BHuJhcPU58qIzJF-x^F zu4>fgc;_{nxdlumQIHJiy)!oTjg7OEIJH>F=0mlBqciUJMvXP^c_;3KD%9rj-Sx5$p020jAhZ#Yr<+MVZavSBVPC8RN?XDQbSq40d%REMLGIXu{u(75X< zf$oWdW4FW^?aR=PDbpH!O~9%vqkBN)vUE9j`PPm~%TZeMG2 zh(4_Jd4lw!;Itoitsl-h>%^`Y2Y!?NX5@p4wI}`7SYr5nJ8xrtFm@?B?*OIhdNSli zky$^&^!d$OQwpeG^;whg_m%1m{_rL1^zs|be`opPI6k~NX0pXxYZ7yDs{JkQmAm-5 zH7#z*w*=(`37Cm&j$?5rT*-1!O>kiUb$8dh^w=P0I+^p)9h>IIn6!R8;<^0#TpQMP z3~bXoLl(O2E5vwO_wpDm5_rAqL3H5of@?-W9G9iovz3Vi?eI6-rw8t_wqUkttF z1vd5LGh&TVIn&8LqyrmgxP(Rg3vkA7{$*6Fr zhMC23wzs7sh}>8|^{<(wW&ep~5C4hxvg@ZRSsAkZ+pvvPuY&4CaR-Y#e#~^=mG8<) zaz7#PJq#;v5sfZzgVgSd`xvJEDbL+$Q#kg1edv25TDoCkmCWnFCO|INo12AW3w!L{ zzIiBK5Y3&^yoPSAm|baTCa8W$Qwn*^reloSom<+^KqYm;By-BvD|2D~XYN{u5ac2E z`cz%bCPPw*VU5Qme-KjGX{kz(eBk{$_SC=PRL;q;Y`SbbOCP9uHRmYCvD zy&_<1-0)g;f8S>7*HcM(ezbg3g|vTD-{xvV=VwIe-L98W+o1O(jftS_zsR4iw9Bj7 zT$wgw@IG_lrfq|mTk1Hr2%3}AIzKKRe;zTPN6`+7Q97lx0`Kp}&(=i>cuw`Ky$JvJ zgz4mPwk3?9@=d(dEoVb9u~Its>F+2>zIm0o$>bM^A4lFJ+={AmYXXr*wZRxW)W*hm zpoEb%uT-BPYa^^7@8`=%BXnnu5sY)O!R;emIpGxG;d^7YhQtB($;fFh&7nrDpk#hD z@`#}ciJbe+d@@?+j%fv@AL_U)>Ui)F$}TR2K<|G(G$l_I5+R`5lbe1s6Hsc@y+F~rT2BOy9b9I4pQ44Ol3iZ;M0>|bDupMP^)0nD_eZi3} z&1kFmKjJ|h*tdXswVmeue8N2^$2AspZdy~rnsj?chu{Y*eM`KM?D4(61k$9$ATt>E z(vjo3cq;HS;lu-_5n?cw`s~htWr#SRx-bWfQQ2uLMQlFsnFTL?P&mZm3fHhKRRAWE(>ujM8Pyjd{U_aMO)=NAq zF{Me!6lXJa2<0)Xc0GG8R-n|I5#-hQc%pX5h;6sZ|Ne$SV~*nbn~4Q~tplI>Dg>ky z?OSxu&|B9_RJBWP#PzjzuXR{^k3t@UR{H68O($vWTv2Ylchk}zvxCS%<2r4lf!}{E zjSI6(N}EU<>qqFL_w^SiVT(S8o4uJy4F7gSXKe}xM`=ogd07|y%bHC25UITn43JMi z+gZ7jFs=J|>e;?zepnFUhf->AUZ(I%1;RtDT$nv!UKr)FFYwx0dH%rZ9`n6aXf#yW zsdOUx$m*}i=J6rAzT{A-dd+KAGnL83=+Jy!uI;2gpdsT;)PvlE8P?ga9^!L9>jEcY zi%UfD^?5sPP|-_DHVBqHI~-p)a&j}W5_K=JcKcK9x7!2>=dS@%&?FLyEYV_b&fl&S zb1s9(HL79yI?z#kbBDe!mYBYc12Zi9s_-N>sI|9zjqMbCbe}E3glmZHsrhhEo6K_X zTkqRUrQmC|2Xuh>yAe;Af_o!A5bBk@wwwBQ)D zR@?Q{)G8-v21s#hwI#m@0-#2@TvR>6reF@~^aA1z%}#S|g$v8tV*-xaRGhnlqxb_8 z&JB3LBbb#K0Q@E_kg>=j*8yEFL7)3bJBRCTCHEF80?J9UJE<5(o9})XfIZAqecLB@tz(6Q910V&1O3yReQqCwEm&tR#nll5 zE-|ijU)VvqBi~`le|7Ej!MFsXI56VMts0fD&Wq^jDEQiY&qJG{Bf=c=VZ$VeLl;{EV1IF?BsY?s* z@_QCy;Dd!or&T(|Fem*3oJ{TXON-|+=n)2{x}4@`*v(hPsoqh&H1c|=fSgjC_${@4 z0TF$#Q7064@zX^V8kqC^HmHuwqte0&mr$Pc(-|;bY_V8Zs8jE9?3BCs}ER zypV9C&Ka02Fsa@J)1|EoomSPaKSxed{j_E z^rubQWgl8WXK#IW7K>Sia4IPhLlqgJz|D&EMEM_rjW^#QqDwC;ncq^N`jh-%ne7v9 zzQJ1e^}K`qZ|PHvSfS~6s$wE-m!1H?>rb*joLH}gQgA}=RGT&Z+h05v*%*>Uk0fhL zD}4kb3PJerr)_s+gKSQN9<5`F|MnJ~Mw}jUYdlx6FvVf&@2zP4&(CwNLcHQAv!~-y zDcLqZ$>Su{EZ{{L8Llhs#LC`6eRsGFwE=MGmn!giuD_<=z)4_vJ3E394N_{;E(zY( z{(MOb4w_eM%t_(Z8S?z3YOuGWQ2Gs3zF`{E%Cn>b!&YPj4#mSdwYICV9RAi0Q5r{S zloUUUHI@8vE^=-7v^^#5ThUDX&qbk_2^Q(g5$&f+$%75e;JdB%gFe-Iq(lQH4*saMb4P+Fqj6U%k6yFHyt(ti<6ImlYg?rS@p{ z!T5mt_~emz5jDe~Uj6l>2z^j_SvuM%P0{gwpYoB%hzNOUa`rdMZfi-UWETx9ijFlo zd?L)1EYUui)dyLWSN(PWr@v2{fZ>`Z9##(080uVivd0JzuOG0dg8h;Iu9`HlKRtGKTP0F=&g?*k)s69aZIyXL7<~<|%47w_%tN&RE`^%NlKa`}E@{zi6 z?DWsBI79s-l)q<#4Bh@{U8LC!H$^>ugGG%r8jN7N01hPz{C_88j*7X^xSB+f zk;2Dw)VH}St=df$+k<_iTkne+-4D7qopG+cC45CrP>lkAZ6DIu75<7?-Woy|PiQLW z9jF6(Qe8lP#LSIt$GpAfSHvHz9pt>y?BuQrxLCr2>uPAot0U=?CKf;4vl$0prT_tI zPc%=C61Lm1NIl?cmv>HFAOTd?-A7s!ftcVw1za%o=mj8IH2Py!j^25Dd+eIp7z5NyHNQWB znN}}Aj44GHM!%1fRv>aUJFVPt9Lrx;smgUOVv)M1u3uI&CsLqt>;i>HYkksnIb}}d z@?St-x;)&;ZSwlwPuKtO$$~eIEZS0$EUH&E$kSPf>sT^z?b)st4*;4ChCGO$wx2#C z6-8br_VXW6yCNJLHAD5MLh|hP`+ptP!Sm6e)W!E)$u+oj;9v@|l4N4*^0-2)j;{bF z+{Hd(INshAX>%+CD>EivhSCAharv*%QF;sxl11gJaz7pzH<+qO?HH4NwF&^KEaA9{ zql}%|5$O(Uw9^^;tXDNXq-RL%!9F0G;5Zi?|2OJCPL_+~fWJO%_hD&^^p|C(05daO zz$ldhRsa32x8%sRt%I{Jfh&11Ut{S?3e5Q*UjPj$HSN+F{>1-C%;11Mr>5YpnK?4h zk@T~I|1SK6-p1_caDR2=>QBc=JYtTej_NS`dsF`@6sKb( z=Dj6|(6C8d2|m*d#x_QszfsYgJZi*Xc3K+6Q72ctD-z_ou+44F)I z*ZhfoPcfOB^_m4t3jl%?6|Ss$1RfY`jTa%29?w$a5;CAYEaP_7zdvkJc&y6OjXZc; za1{!U@fyi>i6VJhn-;C=D?ZvJX9}j!hCx%Ch<615pEUO-TMfkgNmusVZ3Wuu971=3Dmf*=;^O=UVn~8B! z8W|6S?U#O$UE=({S2jUBHumC%i-M(rgBK&@AZ)NpH~q3VP~K5%l6v9hYxZ6jyU58* zQti*niLb6^D>Vlk^E8Yn4~3?kC5h>K%)bP>2cNIn<>pJ_)E7vBPucsA@O84;1%qqN zCAC6!bv$8C12RwWdIJF}3zc=hV-eYT@k?fcYesKD8^KA%#IbbJFDWV)YF;){rxpd6 z*}J@@rq(}_WsT#liQjmGkVD?OD1^po!$B9uqP6l?5S?=4vt8eUsnc>v(*J22mtGSa zPfVrGH_X21s(js-KCE_$9eFwP&@^z)jdS4-q`uG(N}D#E$K7Oob~%=@;do%Ib+i*) zoPr&EG^J_9&c|Qk`;{kU_WifGz)|0)=R-?i+$}-))!yOq-}lmw4rFKX_T#}9SU`}X zpx|H%1BGFYROhtec;bO;@WFo$luU&XW7S{g5Ff_(7E7AXbEY$DCm8Kv%N!yh)#gwFKUuF|rt729j0rFoku_e-j}puiMV zGt_w`iB&m3e9lM1$&~l(E{nuw2+4rus5y}tLC`z!0=8QDXs`RUZr|%q<&@&~#ohFG zExy_l)N)vna#lBk7r^eeVTF|BvqFvHlJ#zvtw_1lrQG;<`D4?-0{g>ltTK`OWr1TF z94``LVClnna9!c5=q@`rgFZHwe9CqpiAK3Ksw1dkGYFwjW zXG-J@zarCliEZL5E`Ihm$un1{xB0mb2w2pl{0cR$==4iEi?9s%%`9vfoB{&3{)B2? z9?yy{<)L4angf8pwi3A8O{qR`YO{ZJeh|6nfxQ5$YGa+GdfEf=OH6{G*2ylHTsPJ; zr~YA>k2o@2ox7a)@2qce2W-Xbb}mNR>CU^#ICl8!=)KEE%R`dR+${ZmTe}+u69A|S z3>qdfsZTEVg3wY>ZUBK4iZZajO7tt2$oi?lX;n{sAPToegU7ZDIAMB=YdOJ)t;=oY zw(8f}!P}d`>=Isi$KGLki#zLYcb3|$yLB55(JI$zr9NS1z7#*WE9lYaAg6~%@gF6ZJ;;0`DO z;7J%;m(i*c$8H`u4SLRBK-F_x{Ga;+NBbTD*Rz>?ackC1z!*Rfr0#-hJsJD`4*B1@ zUE>|RM{N3=Wa!dMp_iHh%WU2tyne}WYmEirXwAI3xD@~a?hJ|#%|iWK%5KV5r~f{k z>*Di{Hw*$3f!@mUQQhNW~=)7<2jPXo9!;3 z3X5^}p2Ciu;6rT>!p;SP_|3vT)Cw{#gTGm_cO!uQ? zFe||{s4m4;V0X!NX%3dBaRGJZ<-Y`63pnMh4$-(@!R6Fkyg}CDAvmY&!zJW;@!zi7@{or|r0QjM<@5Or@HGB#%T(J-_OlD^y0%&J4}8;T zHhd5={!~YRn!`N(03jvvY`nD^W5Mo=n;)!rnI1#EjP)+uF{v;W)Q@#)trYnkrSZS@ zE(W{*%R-mC{MY=8T}IstA|AK|A1u-Jq69iB^XyT|HVB6)1t8c{+QCyVt9Tr} z?xAmWr>iAE+pA*YTAhudPbVm3m4d?i$pDr52>{wM(Pjc!9|XQM(wTcx&)00 z%k#F+QXG%M;P^mxW=zw@4x#kw{Frr9mcuA5D6fwKl73#d?GdU^mcp?C#iWZn`kK_8 zkzodYwF1~SvjfHx{}hy98RbY`DL&;LsBY8-a$;9^eJ@vV5_J%JCw@=$A5q=^! z7e-|*iQ_TS3q)`}E6o&l@LCjvU~qVIYE18+o*tI*GvBWr6u7uY^l$M~{H8wq^`=?8 zAK+(?ng;nQ4~)yWXd&g!qTcEz&O#bc66c~CA@3?i5TA^22wXe%)oHpfI?N6=-H?d; zxyN}?85Afu)M-30;W(Fu&%02su~7dL)P`{xmBO;fak(ZyLqQcaw6^fFgIIyuL0Qfl z*h6SsY1@motbKAOQk+NyYOC;rmN>50?jG06siSu;aqG+Df^Ps!?0=kjbP!EHhzb7Ytx=h-PtIk}ZOOex_tw0wjrS6MN*|Hvh9}9j4{jutze_)GsuT(JrX3Xw_b3S2=UY3S zjYXYmL4Aq$iiKCXdg-!8B*d&+gHjts_F-9a_}y0nSlWZrtV zy1Kp4yR=WjYx+>(xU^Q}fH1Ihpbs)I$?o1wz8@nulE3jeA7Wx*Yv0J=n=Xw{40Rea z^^CClM{C|gzwje)jgnop&+20aE~#(_i7pxAp$CL6RXHQ-E;pTo_m|F7-|bDUz(WpG zf0qrnoA(RKbhc5w|7OK){VOCu=f%z0rJ>ynTiSesvOu>~0A^p^U+J^)GJWpW;@F8# zAeeymWE<+R`*36_cr%bkiLlA%oQ_Hb;uqL?4~4_@`J+*8=%*t@=hM=yKfRuJB6Dt6 zHU?nNzIQ&a?M$DuNh^Imi4W6{3|d0ao*E{#$jxEohZzD6O&6YY2QDo=IIvvLnR;O~ z8ogT`zR`44O?T?Lfm_j`s4CRrZ+9}Uxl{A5bG83n)yB)?ZNlC8du6r5kYars@OEoA z$1wm-z&FLJMK_O=rXRbwF7{TLvkPr&lyT~^W4bTXwKrCSJ>EfOxkIad8Y6=pNfgBx zOa92Y8-Jld&Q9_s(23g99*qs@9qe!BD0Slcd2W^sR!V<$KJHp;c;C5Jw73l(pz0PL zfBxDF|5C^gm>DEk$s0zT3L>VQtSJaqmF>g*JruZ?@beqr{xnJI==KoxelDSeNZcAv zeD-54sj8tBxfzV`cQO?m=at7UG&CY?OTEjq??31-e2l5SK~c>K3(%{vA5^)OS0tdb7R6KV3RsZd+2DxYv| zf36wj9WoIPPs_EbL`mF+r+Ynb&I-k(;qbzUv;s>!|EroEp!Lr8)~}2yyR6%1U~dhz&pUDelb9^*f0f2$$fT2sN~$ zP1ze|zkBzZ(!NkK%ihV|G8Cn2x->5SA1ijz0G-oYjBy#jrUqBw7yFccXK_N!2^p

8w_RoSTz+lB^%lA0w7reh2#i{2x=evBqIpS%jZSFRoCuCSp`Bw%*v zm+{vY32KTz59q*rDSA4IGBn(+YAo+-$`+-%9!%WRLVoYp*mSoGTa@Q7HPIp#h~e4% z##eR_@#vlJG^FNsxzAr-b>m|1vd{zY!KrjBCaZ(V-?~<*d1sY(JTLkSRHPMYCRol8 zJc^mZP59OU=ueR>bgB-?GbWndMNS@B%MUmsVfq4~JV+ILBPvP%=pByA`6ub!{X#Bs zr|jJ5hYbLKwlwo=aO)u8&(Q|yB(QkvX=uPmwA#fj%;40yx6>HLb@JfgOl=FrULt}< zlyC{PWF7F#xnq{=*)xv9osbB*KQ>n58!6t=1~3s+4E;tM>}8zz^6ANl8six799^iMjU zszD-Rh|ukwOQzqDSpn<{yetB|{+!n5g?hi)K$$fw*kSyi zaW7wcK7P1;dUoT?Kc`w;ZS4KXQk+BZqU7PQmj4doH)_~$09;AOtSaKr3^7OqW=XJf zty2F{C``zP(o!*5{+|gx;im>ob+fjUjQv21V%hhV)^B6!S|nfWsQ$vpr^`}FND%p} zj^GiF7)MskmBVoFH!zmzoFQt9H;m6u=b|&00yBg#?cZBf&g!4ro+f@P;TZEOfe5x| z#P8!Yl>=BLg1pv5-%m}^pDQlCQN^ zC&xtd9T@2Mwc!)yU?#u2K5lwSD4_B5b3XiEi;1iSPPN@9IKyD&F{0gpKM2*h zFc|}b*^LR9w!l-+jT5_`F_bCklLcqbP|0Io657bO0U>RZ*KWbpx)BhP1(NcD#|&ZZ|i%GE)8T@rLW}Cw*fbj z0PDKMJK{C(n<|?;aFuwOrEJ_*?=`l;E(?f|$m9EOtLKtj9jTKVHIzR0>d&>0js%u& z2NpG08h*bAAAE85F9vl1>4}ilWFNYA~oUF?X^=Bh1G0o#evgm_Q%d<-Wk}cYwYj) z*KE=*1|`6lI4XK?cuV|TxihV}js_MIK!nnr-Dr8%9X+=mi`ENb zZdv!qTbvKq59is}G3ox|NV$W7upiNfATl-ALvBI{ln4f_s`d8Qf1jSBB!^)kHYLtI zv-{o0)8cCiQhwWu8eA_%?t3&cKuj{HZro{4^#rXcTPc;)%w<~l+Z*veiN*I%ePoH0 zgh9CH0ri#?Y5T5MfwUqF9|C#WX@r0GLRP1&Z~NnLIZ8iXtUKH*UN9vjY3S-i3Md?A zyl=Ky>kGZ9*VVUAwTn0-nP)~MRDa)CEmI@-@VEJ=nxFpkbZNmO6|t2OTba{8-{fAG zq_lub3j8Jd2_>h!fspU<+3sdOIl!d{sh>SC5Hc*CrWoF)G_pS~{T=*9=V;dJJ2tEO zRpSxt*uhaS1>W5Zdqq!pEk>v-vv+mrU(MY2-$Am9V3dqysS)e{_cHU%^l2D|8al8SW^mOoQkQ$^vdP{A&t_a6;H z+XPUhB8Brm<63$ZT|ahjTTPS92Oh4{)S|ARSl_Fc3yeZ483@aP%lzRe=gs{TMR60D z-muYF-xTCs)~Nzb9```ji#Gt*jvj7@;>yWB63Rcw>mK`cF`c{csT8l(K!AQYD!JH6 z_e%pBeqBK4RqQ12Q_oDy{`h4$MfcJC9+kGMdqB-DyLT}|r4k%^npQyQITpy9FYY8H zzq^BiOrtWN@^JkU!k=k)N`kP0xl10uF|s$>BW`%+`wmxtuiW4)>)Agi?cSVu)~z2j z%kgiqp??arYND9$vbwR)9p)`=`}qu4orQ

b$rZwvBS{U_4#PkCl$YZ+&g>OTMh; zMcKG7TP=Gw7xDJl%@c*i8-PQ|e&F2gqrzz*2BYE?Xei%_)*3bL_7N8W4>MIZ+-Q+A z@2cxPn1omV^2wnLc7qOy&VP%71kmFcP2;kTw-nQY&6A)|BbkZzfL#hSZ^GY$ zhFa(1Lo67g3V0HJVPE?AK-SO(yohtYMHS*_q9&Gij+GOLSf{7P1)9E1xQ_Z*liNnQ z{gpy=vP5LfiNURAHHzc;{<;{mkDkMt{FR)ibSGXG6)U#nPLY~4FlX3*D4imG$kW4> zs{6`+RVrA>>SN&$wxycVC|905>^fic^8gcEDwp)QPwIISl*d{E5yFY*n+-*sS+N}} zEgeM6B!D3j%<-%>OH8^qb1MFZbc#=hRv%1GQ6LuROz%hIhQF+hq7F+X5hGCt`lIFS zPJPLblkKT`eNNEyixbQwI^2Ny7efR`HOEARuk;=gf)O;tGK{sQ%v(0Y@L0_2m*npT zO-p)Xi8ZCnPJHtUU)Q}D^-*HnFS0$%0Pq3K=OT@i{*`xGGJq}UeTDcOr150lJru*U zX9WqMO__NoA!sv>Pe|J`e=IET+OOK)x=Q-1@U^_c-{@H?I25-28){f0y5`Cth1HF+ zB#b7;ffHm#Dhd!t@We*R1GkS98UX%|LYeL1HHbU&;OqP5PpAI|ZU^ehLUFOLYN>}f zs`ik^QEjT9D|jTiUJ)B{JONWe5DAR5ACW9KMIg3_6B>`tV=^9!wcQlLj!Wl?i z%G1OVttolm=82Q{e|2A$?@CKkxBVR=9E zdh{Msi5xSDTqx*lLPT{<(vFs?EPy#;3PR19iy{KJ!Sv>4fo1aj4Zq!EfCyWkroCA68K#qPkfeb0)4zl-hp=9jo7WkI)bAk20j@Gn!?GQnRyeH z>Sj-?sf#~69B%FV#4yyO!3;=hg}T2nG7$uURnYA9b&^n%Ha=C~c9m!|K;m==nQ+_`11q1IrYfwx#+ zV4SE4lgNO87msxcP~34=?!T$-g=fm}*$U%#^}g^E=f}y>#$5k|xbT1v69^MY8u9bf zT{?N#UBw3NzK_;Q4d$kJUMQ}dMM6!nz%z!synsF$Nr+U2;`S}}*_Eim-f5(dXPn*6 z2mM$rWGX^9i$C#gkO{bG69ONZRI3FRnlt(MJDbMw<^R!VkFrX>Uc$7Xt^qwaDuTc_ zB54I!r*)F){w^%Xd?uz2!#`Iw9`r7klpxV)g(NXh-+zTeZeJLJU+{C3V}^m1Zp>n#Zm?YJU#!rH4wHv5n6ga7 zB$#Squ_R=HgLUe=vV%5*c~4r~ppAa&2M{sM?!vt7&EKwn;2Z>kiU z0i~-Bp`QdZJ-=%;QWQ=69s_>W#-eW#&n}dwY9BDpYsr8D_&=GSN(VNFaT*$)mF-${ z$>NCncxeAp{e}ChFIv(*u35GP`mA;=)R0}yTk7s&dQZzABk6bAPqL~1VfGhC)bKf& zKu6~dAvK>W^~A4>_;}33bU(6UL$hR{qw7c4QZU5dZ_3#A5avsrgQOvWgHL5`%}Fc* zc1Xn8G@-bum6D|fgyKHTf2+KTG>5DhKB^)&0{4_~-nnTLx*!zJBe?WA7QUD7R_AT2 zWhkg^u(#^I;e!xqv_1;iKDAQKq`;-xs^h0fg{yh$=Ge}07u)T)KmusK0?r^;eq3XW zzb94Q*7LljM&FATfHTwdjRp46mbQ>-KL}Ta;yUxttJ#^*{ix@9aYKjN(65_B1DFsa zHb|48wY*1-%R^+6_H^tAp>~I@!AbYo)@fE0xdhUV7U--leSAdNM$@;_)3`{!!=6+2 z^07X|1d7|N}be?B5)Th4Kk&ib>3!C8;(vnN@j>FB)euj_Vc8G}#9ue%sW@nbh)QS7asM zKZMlH^VOW2& zXGG2PX%-`A@FSy5GST(%g{F4fMiPUvL;ubvt}0O^ONX`-t6F9tP6-&eu=OmI$p2+v zCWfn(!Ok1aZsARHTXEKYUIL~pM#Y+9dv;w7aMtW7)p-scn*WGrHIvR3hq=XnqUmkKC; z7RF(@d9cFn!31tKc-(&NftTr5c>xMao;o*&mmMGKx85%qXZzJo8+$s=BgrUDw<<86 zyG(9U5EDKfiLFCU7N6S@=n5<1Dq4T>)E%JoC?Yl=T1})ThIKp zVe)oH5bWYwkOwaXRO&Wj{-MqT(D!K6Cab|W(&|^1Bg~$`I%r_E8*_;Z zPTGIgvQA{{gf`lCXVIQjxi3n0&;7?5o{j8MJ6!8eI#|$vSDuWeaDWC%v6%S4U5rK z-Jc4fg?#WoZwlf~s|i9Bm~QFFdwy~ISTy^=_a3A<(zGcO&N)6zZ%?0>zqqG$bW4wO z;jWS&1X)}nCG!kT4T|f)XSO+prWps5^$&Io2}5JIu77Bky1Q9nmHJIN7BZ}B&J-g! zo*&5IhKP$^pfNIy`fBDbHz`Zq|B#yFA~jbH z8wclebEx%dv)W{rE75_pswXdRuI=@gqb$^=&8`trCU+On-QFFgJJ^$g+DrcT+} z{#%ABtEjeR+Qi3_T?$9a3st1?@tLcg8zG=sR10C2mF5(f^v}f1VED1Y@9up=svIhq z%q5OXsF~T1{#`u{rO1faW!N%CX)OumOnN6Bn65{W<2P_EQGF*>TgT%7I4pw-q9<0K zq~Q4_SiU8Z8ESrHh{9#f;t(FwofAh3HRlk(2J1V6L$YbpH8lP`oacF@7_V0a9TqdgOKGjC~9RyNoHk&}3O-_ti zX}SssCXC%hB0}6&1r=?-GAxXT zw*U5bIPq>m*div$zM!W@5o565h>G48Fte1C;wb{sJD0EB9ru7!~oCH+e! z2TM!$P4DWo;{`Y&n@YV3&%H9!mw2P%AP^_?yc=?MZ4!A_Ebg>^S`xUqb3C0J!u|5_ zG`hq$?Hi`4Wv?=HvQjuEYi#G)x_U(OqxT;*@ zB_aerv=+17)ZU`TN(}b``wfDW`vuY|E${z7DLwFCx*u9$3-e^u0hgZyK%GGZk0K6B zWvJfpwLCnc0&36PtS@jtM=na@nxl6{H^5OCDy%J(y!gKr0I~eadrwS$I@i)6`JDR= zU!DZ^${iHCb5T|heXsk}N-dE?JM*Fe=tDolM|%tEc+iDvnA)t4BMBO9YC0>Oad$*& z=|t%^H7#phnro%zK#weQ?P@&Xno6H5AG7k$;D^s?)?bzbP&M%LK9(etgE0kHn7@F1 zY{ee=A30q8ek26W@#uzWLmffke_r5tl%NINMDBm4ha9{Q0QwHP4j0S*7mGC5>zUc^ z|NIu|;z61L!(AE-i2og>+zUG3i#ZG12X2KkT35uLz5r2ShuSq5!iXiVI8h3G5U77{S-LFtNc8gSmPPU&!1<3F{LZmqmzYm5kl>N)ONNt zF0wjW|B(}Z21Kvkz*P@^&7h$sF*F8c2LAVWYD@=D?puquc|BnrNVn|2)lz zdME0Xl2M>Lu~C~m=nN?aQ_5Y!&<3QLaru|Fu!TS8(Xq`R9lDp*L2n@tD(*Ft3B=F; zl`nPhs$;n$z*z3jV@%`##)d^#+QEKum0mm{ZwV-I{*Kuy6!-#zxV$pTNx3One3HB zwi|`W$S8XzWF=+akw`KtE7>DtXJ=+sGD67Ayw-K?%e}7qdmDW}{oenmd(L^zbIy6r zbJpv59zF2A>*&jkq+*Og4nN-pMQu>&N`S}0C6~Sj=fJ5yS&P3j4C*sA=DQX4H1~C9 zK!g>7hEh-Oc_A1-uta&J3A!vLkA_seqyqHxcS~Jz#z#BL&@_m)N;XeV2?7TG;uEdP zIlz!NpkOYU>`>$%TGJ~>IkPwJ5mNFIxeupg5)}MCA}*h49Z?W2h!^4lTt^2ndTnPA z9UBoCtH$t65d|W>!OGIXmlvdocBkQBOl`h`O-z9I2B;giYA6C8%QpeH9}qjSn@_d{ z{RT7~CVb6o%UYK^(3Q7{5Rbzv018mep-d+C-V>kgJg7&idG~jGs<(3ubX34)E{Os$ z>61iFQvEEvbuO}ibph$+tDtaLXmHtL-B%|k?m<)YVAylohf+a~>$m>=TAHw(OUfCuP5B?gpOoQX<80aE)m zvnK3Sf>aPm1fz32KziE|At2Z2{7|Yo<2wU%;hUn zlzx}DBMkM3Y%dQIa|MF0PY7CKMwc?>2K0nw%7xljJ$z6Re;;5{5h%$iaGAp%Q`JaHR9c&4DqNEy~#?%N6wyEpNA87Pb zYe$@V21>oeBb^fIu=%Bp`_`8!Ze)sA21zp`SoG_3X*hpn6&Zc3718vKT2ELKfSjMW z16syFuFI}7q&Eh<2ZXi5l5v?te30d!&?&a*4YuCK>P^9ro9L*{M$bKOWRHyq5o9vF z0t5@!msh5jQAVz%@oOTjW;BSFo-S&aQ z+sO^{3PA5MyiJ0f9(mIjq(X$PQg%DzqB|9eyg#&fHcN&V#|}ilFJ)>1!>D=y&f6=$i7=IRw*k-j&Pk< zn#5wV{)m9fn=6=6feUh7Fpr6ulr&A0u-ovF8%i6kxp2eG_}x>y4Z_mZq#CqCL2#UR zCW;0xpRx-UU5p39uB+_G4P_Uk^t8I7C-nU|hgIMxC0=`Q>6(@VrA!V~+C!Vf&ehS8 zDM2eE5b2PH8(;FVlZzg3v?@-`zK=|ZfBBH&_EK-xr1%-EaJ8#!^1u(S{pSNINL zTGdpbdIoSo(+Y@EgAm%crA$C5g zaGIU*(C!y51hlzR>p;YdIQZJTY|=H`KDH_ zvsbOL8K^DLOk+oPt5ZD=PMb-$Cn?Qetqk}u5G(EM+R`#oZ1GxJ#0c(!mwJh-3K=JC zH>x(H3(Hi`;S=t*UT{`CS2Mqug3jr|Jwo{xCBsJM6gjYU+oSxhnVfeIBnQVVhkA9P zm+F%DgqA%8AlG3w5#xzB>+diXramX@?r$|O=$?M*XSu>3TsgvnxkjhPn{GBOdL@Wt zOtbE}$^IzAn6AGR)~I#`b^Lb8C~Sa6%lK+uQ2VI~mO2?`7nq??Ge7;$|$nvv$wTT`0TQ z&Sw3#WkGE!6V3#OJy=P6UuY?SJKH7_Zl4`mR^x}h3)=+uIJLoP%{?h?BJk$WD#bA`Ei+f+ zAIpzm4MY2=_0(scRwd@q7gtrrM0KwZ)oQn!ruWs^Eji9Su2&Yv$8iuh*x)-ygvH&9 ztF!BAVv(|A(BGHe%#I&44lC2W(fhO+R}$~J^d<~NmzEn+0y+eTaaOW0B`bL*w#}7c z?kg(~CfFYY&KvdMj>DJsx*nR1F$y z*r{RGTEZ6@z>CzmtIg4`&4-j72ws=kO>H)|`!^~)DoA4HE4$bpv3f*(tK-!ju6Iwi z03VxJVuSG&D*PYKk)rd~ZRn_y-U>t;Ci-TfDYb~nY0^Qx>kF0DC^-7d^pm+yXngl) zGR&TG&s)-8r@xE6oX3yv5xR$_R;OHfGn_f!zi_4d2D->R7;_CPn2TAV4IgE$ffXZ* zPrp_Yv9-K>&aSXRv;3NGN@?Om@}BTmYyZ$#_eews?>vv6z8pzX?iuE^G+n!Fyo!|@ z*}QW=YOblIQ}&4Z!}#d7LPVSADekbueMt~Yf7g*v(32Q+m#MZmxOZj$d}l!S27`HV zuyP39P0hV-SiN`$-e`wI`ge_C*IVoq^p#x4m^0sF?U8tc7RfuEo+fg2dLNbFETJpI zYNTf(E4+g9^&(^j9oP40EfA|V>^jOW?@in5z>`jN{1vrz*IW1AIa1j_tKsdxF*Xw& zjA(n8`4*@Qv(n!Yx$hx}gj9A}yDw4}Z7{g#wmVS{NWYGGyzzNoQG}%Y#m)N9F{kMx zi#|A{2Uumf_@r-n(&5m|I@-=-pwu|l867A}J{W$QbZ~cs%X!J;Dj zX#y<>oeRAoB~4?g>O|Ds)ClMD(5mdkup&{_-+_0$Ee1Pw1sg`%O`QU-FokLk9~=}` zb>$bk)9;KGm;`N}j@6ry)Z3AaJuN;!Clg-PB+MB5ymU}bs?MQ3V5nk9x2Uw)@w44P z`OxT7rKpRL>u%1h3U4>Gy25G;Y~tCSU1fz@@nl;XX_r5g<1LLk;?CpcC||c4pet^d z{z-#=6CK1=wd2aWH+~B8uU6FZ4%DSd&5vCdom4OA;bt`Av@2u{KmXY^AFJm0GPknP z!xygaU*87wlmn!w%ePY7t512=uDo2HxWirBD|GfN>_U7`H#| zyY^db;zr+;rc^nqw%In4AOglsOGTFyt>fS5uQQE(e_1uUwN@H>5!R;ZX~gRa6*IEe z>@m)_&uqY`RV$D9d!NU&_u?h-;NhF7h#|pv*(5~to$K>Ii@_@}j`2lxhm9*vWy%vv z_q#F4{^Yp^5!vj{ul+Wx2b3nKR^>fXfZs4wPAFQg6O+OLE0RH0=?v*j@(k<**NkHJ zh6qsSn$5*VD=(&9d@6lMrbF$EzSZq_OfGi8ob#!h)e+y2m%ml4We31*8cnsLEf+EosrLM3TTc0}5tJ;mTaHrn2% zs<@9e!*rC;nxp>|FgL0-0xh6BL}cVI6rxSc=BsVYEiJAXnCk82z{GTDgBPy7lPP50 zdkRevR#<_`FjkWAJit`yJYc!tLJvb1%Eo!X_zp(s5`TY&l!uj6m$)>q>{qQC)@iIP z&R_>0DJ(p(8sj`=5kIXM?=`J7HiBN zobg?Nve7WB#y_W*|ifnK2nvGii+O(v_B2g);EvZWXaGLnyxhIaf>bZf0-OVgKN9kSQ3AeKyAbqFdc~znR>rZm6l&oA*o#(8^%6w+d4u!RLVe z0x_M?Jwn-J=+Cmk=Toi(=ozBGlD5RMJ&OkWb%>R9eM#sh3gfqMV>K@H;Bi=^3Zrs% z!dEz!jX%bPT6MxxG`O)@$$14wV3T8;s-dzP8^bCokv2qCjrEKo^D9Yl(}J6_kGuIh zl$91gl?>Qf70s94btalsU8}F!PU-4zl(}h=i_bH^Tttd5ZfkQd9tufVimrV1dnEN; z38ygRx{d_v9i*!=lV3zTWm0PbU1ig4<)V9~3FP7AD6vPueFy77q}+b!kXBZ}eNWb& znMU^xA8y1%fyE?gr#!i>=jXx1Rx`6hypQ-@s>T->^I?Ckx#3#`=l8w6nl%`Yn#(hl z{)I1KW0eFLzWyxMLiUQNlwIMn&U-?;YmdW-NBhV}sbx59!9P7aT6^!zg}lf+)a=L$ zaF<`Rd|co;_v!MpPs;@QWcOSnGxlI#&{-ql`zs3^^6V!-?W{kuy7-b(gWX_zQT#AE zwm0?Os%hIw&-;aMJo^QNPbepi+KR&a&OaK5sxdB|cf_>HpA@K%ks_mKsBA*;XmDFyJj?^pRI`gm==|qA1Z_@-DhSpLSS)zEGy``6NE_2CS;{l5LllNq! zwl6c~BweL`zMR@~wT6^~2ctl07zP87Jskv4}F%NnE@(e|eaX8a$#u7#i>^ zG7;iSbJ9+^$pZpW6e)xS%^q~?L=Z!B!J@@*}V8jx`QC zftRD5cOo)oiCu;#E6dMZyB2Mr?P+cUZA`*wi9&-}yC?1me&B02Eghgg9adcT)7K#FVf+l{(EqS%%*N$_c&i;qKaEZex_pKj7gtW zQ5e|Cpy?@LmY^z>o;dc@gV?bmLRQVvjx7-&t%-TK)s9;83$8{Aeok;AX|Vs@$6TznI*f&x@g)_e{;Ov4?L6o3&DSaQdM~nL=Tv(9i)zM(@2*?=$c2Kitiz25 zm*Ft6=kLl7?G2VouvnOxz*`)KB0OE2;igCoG*J4vv73oxdt;xq!u3@I2 z+xMxbMFF$)3o&|W4LDqW#Ob}-&;@WK{4T+C#vSvXWG5r|Gl-A65gkSU z?oo|s)(`JRuN$fN^8%>v%BD#4cm!y+DBG%g`qo5lC8#h~g!@(nL`D;&du)>-qoz+^ z=nOW71v_A4D+6`KO?6`G7-1Ryt8;a=d?U#_apwFc+fYWs86qvdvL(wV1{%NF$64x2>tFo? zzx^DW%j_2$bae_7tt|T0`EIURa+?}X>s#dPP|&t8h+(gaxS-#-Sw1v(m05*8ElsJE ze@9LCVaRF_3;uJLt#0f2t&Bh#h;B1h%Y%PP#oK$xNJRp4!1)zTkKirZx*kW5_T-++ z-Z0F3iGzK!Qu@4#O#h(CxlLW8<21@()2?pn+EWE}3wu0Np*Xlv&>uE-eXwE>+E9qL z0nZo_+jfMaKa#z*73^dYdZHhg#}|_8hsF;Cwt%dsg@J8z<9TN?$h^kK2B+8A9hj^T zQcI|}w^2(6#$U*tTK74y%aR)L^A?x8mctFQ3vZCd#q>JI}h)OYVyuW-!HTgrfiZeO0EG6`d&5f10|94(nA#~>>b z=JM;AwYpFAbLKlvQ*-TD(-;G#h`!T^Q2V8%9)be=_H8Si1IMgcwY4y&SJVdo>gtf> zlcpkfk|_n{E!)*=AKq1mKQ%WT_7}S^Ce*WUG#0uu)bseObQi=#V)Q4b2kAG~@S>DS zLfe^bQ*s-P%s|yj}v+mXK? zIiHdvjtU!Jo?@HROt@;lDvp_v>A0AD-nle6b9#otdGhfXLCQ#srLaEIV*S8bxiax1 zhmc;AK(i(oBA}fQ3REajSA92M*)OP8O*>amj$kJSN6s?+vUGndoolB36ufaq)WK>d zAd(+wN;6g3jn-v@+I|`8@7#7W`Kmpfq|}9PtbY4lB9i>fVtj#bN30L$hskuA)r

z>V1802JCVVqEHfp7YF8iXr|2w;f4Op@hoOe#Z_N_M~My;Go*19nv#jg2@kYzaV&IZ z3NfiLZRLf$`Q*U#jA*xiEF`R=wqT%jJ<;1d4`Y+kwB&Q0%2PZ>0{y*9Vy6&0wi^*% zVeH^XW0<5NymH>GU#Sr4?(Xh@+>ujPE|}broAltlnc_i2rJrx#lu>r2>@6c=pY2@V zMd%A@-xuIjZxNP@#NQ%m`Ax=jhhpRoVrxFQ-Fzl5=S{6Axm|%#rth6!c;!Un^gIyq zXiqqOBY7Mo-%YL}E#E4HEMt3ca%q|Nn+{7v&%;vrL zk)HU2pLeTZr!z~LmWv8MGWfE;`SC55hB3yec$17)|2?i0{jT};Z)~X$_y9FT$#I84 zJ$QDObz*2{mFdeRz^(J%n}dcDuGX2hYSVVb_yZRXrWCIF>JDzjje#$ot_5vZCT#YC zNuI@RmoE9JZB!27$6GuR;#M!kRi$V_Fe&5qle?mtr?RGUqh(eii2zt4j=X*+eXyH3 zi&{1b_o=3+f>c1m-PG{A#Wb7WJcs+YH%fyeH`ktoZH+9uimCU{u}aqEoW3K|e5(EJ zhk>)eK=&PPtz0D!-5!S*!lKkoJpEZ4aiJ43=)?_AR@sSoCru33hAb0cR`~3RVGET3&h1YUhZ)Tx6#H5P_>}fBq-XQbg){%3i zO}^_*HWmiVRG%&?#yp)T`m@zj+|Kt53@5IkYo;~&0oHpkJd)JBoD4I&5XKju9MJf- zYw>niVJWkkCS{{;#m`yK-&0B8I?>-Te6_>P^((iUfJR&P{^~vJJS0nne_z#5ZPDnm z0)BWQR)Iu7Bd?NZ8$~1uHA}s}&;Q3SM%;=N!fvW4)LImV^Ai*F|4_a{L6SE^DX-Qf zNhZ;%&~At75xj6YVKjO&G?M6YPHDf60c0dNJ1;pG{$3_ zzMkkEzxU-}ZQP9NJ`m?hZvk~SI;0PMNRSx7VgywW9(KhHQ$Pj6mhA^%;}x_)9^nsq zzE@K7^7lCZKJTMM#^sd;#%sQv`^z_gg;3*W!)8~|1|7x5_B1oxsfk-0S(a$mU5qSy zH4=3$E$t~!9GCxyOd5M>S=@~KT^d?MHAk?>{Ie16@A6-DSP&Ikgmm6|9gU7u#NA+G z%`ndBv*8)!>6)synp(t zl0gCGzO+}qDnX3e6B;!XUZHVoF4WZAzk5gtw_O>WC-gjGR-vlKsMTu+1XeSAq?g{i zdS(REF_%~H)!`50PQxf?>OH)ooRd_I_YSi&DvBWeq)X>aaHHkDic+4@zAw(p2ifY) zZ?wY8qtl|Ay+>YFk0=tbjJ-?`bu}DN0liO`4{%H=w1 zAwRDkgp@L2f{UGuf9N2i>rGXtm;EHLHmFGEnS}Xaq_xFDEw`yWc(!6)wt85@!~h2W zB+=o1)&J^JcCa4yYNPR}agdwf9{3{1qX!LSolVr(vV8uCU|8E^lL=^TSLDq%xZ2%6 zCy=H#nzC%wV8F`cMfk`Puam^(+*nyL6nM8E`>m4hCL=N90Jl}f$BuU7Vx|PF9QT_B znJsduLiqkYwx;0~5x7WsmP=jP*Op)!8THBaHH(x6o5-7rVLvJyJ#U+0F6Dh29b1x} zwn4G1;qC7I5ilKbj8;1sFO4?c^|WxN=ra!ERav!~3LOck$N0;up;+-HuJd#^e=cJh z-!vu_oll#Umf{n}l9fg(PF?_zL{Yn0bb66Iw@CnOnAd)tXk-c#D z$ruoqmplAu) zlh}=F-wP1R9{U*X&g%}cq!_U#=ttcwqtQT5E$Tmck?RzMni~Fx`a5T~<@?V&sEC&< zN|2$oef;0p7BFo{4o$pmzK^1EuWBDZPb(!kXq(5{vZ!cEIIVETGn};xT=0YIYHJ6t z^);S_zDXJWqB|-=Lp*k|rZFaT^U1Rpqxu$`C8?vGL5>G#50R-bPXf)8b1*EzWvZEd6BwT;7e}b9E|810@3EJ`4&~<4~(Qt9Kz0#H8w}25aOdio-KstFXMJQCldpMfkp@&3=6y|*7=X#`z zT&#xiHqYW42BeWr1xB_7QcOe>0s2bsd5VS>{9*S*N-jZ&0gp4=$ai&W z6HE)yDV2eerTkecaLby|#DuUVGp52=O^eLz=)T4aEvM5_=3}A7r9wVq((u&9;09CN71<9;>Hhq%U3lyjYaX+Z-}?E$ z45srtv^N1`wUAM>TQq6dFIv0Y66bxZpz&8tKV0)Xh@$QDm<(IQ>eeuQ zS53jNFktFeSh~E?J(%aR8BEEzPEWI>ofJxora~tX$AYIemOgo=LXl#1iBJFV`(y2Xpt zgWo*yPZTR~ib_ z^jY@Jp1byB$E`a>*o}hU#{D_fpgO^y%?OdTvJ-7?r9iWqiP96!Ycni0f+F-v&W&|F zCG`CC#4iS=JrE@f(H#U`#ciqHrfx3v`ekDN;550-IcsA+&q2!M*%jGvIc*>Yi<^J8 zY4a1R5OuS%5xtBR%VB5l#H~p1v4+!D4v!$sF;FW>@rHSd^GVVX>PY|Xa!1>%lamAa zg16T<8}{XxH-*=U-D=Ode&0%;_p*ky)8tRw@<@r5*?iJpf!k~_d+?BxqvHAGoT4u*E^b@Pt(5LsVllPTGCG+BKbj~McHSAEH*4(7xG7l;JC(QNSFl_yDg$wFP;e;^4?ys9g$@ zoZWrcIeP}uDH8Nzp@x?J^B>vmYg!XpR^(GToDO9j7Q6Y|@Ai~@F`nrfoHqQ=eg!bS#p(9WrQ&@2U>+q%V6kQ1Bz;BAzezbbf%!?>WZ#@6QM!P+QMVn-M z{j6e(B8vP|yEDT~Bl+@aJ}T-fZxTP!UT_}&@Mc3lGiqpwY14$=BWX$?)%ENa8U#$R zgxs>UX5@RJ`mXx3>#|8qh2;61RK^~KJ*jq*1k9PCSQi63_H*(hm%R4T1*_H>7$tl@ zn%%YF>HAj{TE^BN?iGgTEfpFkXSvdWAUqNKDArGxiDs>teJu+u(5%Yti#=QBK39tN zy>00g8hoepUfO2$G`*AFZeV5prqd#-*#&p6=ccOt`MW4Sx>vwXv}a%c>Gs}_`hCH6 zDSBJ`p3oAOTJvwSok)Y*S_cBe%+>nkkl>xj*L6M5jnv~Lp7>9F-g0g zv_n}>d@c^I4!mv;%V~|hxMabYD}TdAB36{WePO5fxtME82+?;-iLc| z_-rNlAwE!@oOvPkW|rt}L*=t_>oqst1(LC&HEP+ZZ+vszh0g4`$0_! zy$wW3THa<)$t7rHE^a!hFLZilyC#$l@(6aALeEZQKV8Jxtm8i}^@6Sfa4Tz{YQy-+U-D zW3~kJRAP!~EjZ0OF-8sq>7-Jos@O%V3#y_9n`LGO{^QeZ6UyfTURV@4+yQZ>uT5M? z{L)t@nGPi+AZnnlOd9WoH`uPt>KC6bmow>a*sB%wMfG6dBi}x3VID~LGNSY zEng}dnKk&0I%wix2})**=;Bt)T`S0xZoEVOtix`8{zI|M>M?oVsH}WU193AD+tykgHUSS=1Tp}N2 zGX{6C?DIcEEA^vOKZ z7xuxfDju^v9ygo+J(_?M=A_YBcMC%YB!l>GNxT{wX=y$Ity$f?I}z4ysx`;ryuGlo zlI>XKpTDACWsYv~RKD%cKCkd$9ID`5(_ZmA^(H7)?b5nnoKhB|m%5a81ST!cCvYl(yAF)2@%x6Ns7E;T zq>;y&;nfZHNmCMKy!U}i{^ZlH9*<(Np#X0O+fDQCYJBDwm3+AYmfOiKWXQ(s9&}NK z_b9%nc6rImdM^A2f%u4EYdALJWL$hmunLq5zFdABD4?JDUa|mTh&?Ojby2WzHKO z`G3j+k>0@25BWMfQqBX9h-Y0Z;Uqw{JKWp~N(>-C!+>aQn9#P8| zv8Jc`=%)`WO|y)=lPL*OED2)&1A+C_R>h+_KqkYRYDPitWI=415BlkT9deu9tio8R z{k2dzpGITq64*T@uRN=W08^WZuvdrOB)9ygly4TX{b4PLQRxu*`PB2$RrbS@QuFr< zg0;EM9dc3uinoO%7z>hRr{(|I7=A1Y}Kdg{M92R8NWkC30>!y%xN zSFgzk3E+Qz6F}Ie#D~wK{ zRwL;?ibP;n^E=03r>5PCTmulsah$>H_kXg<@gB}g5JU|kTETnKTer%nxj_?akQ4BO zfDe#BT9)9AQe`pOo@)_vMv{n8ox>giKhz=moux9EYl8ZPz@SkV0P~xuuUDuQ`Y%;x z;@UwBSbEz5kkvNgpRm*^l08g?a30d-(B)M31GYWygNSADH}9j-$FF-2ILibJJZ4*@ z$9cA}{H+aoDEBB!2J;p+b-%3LvEDM|A$HlF<*;m;E*xh`lxDj5n!~GB)i*`;@JGZd z=~o^l5ccDu6;N_`GI9)YeOr2;yoVrj)}9z$F{R?Dl?Gd&r2Jai5em=RS^f zaQQ0eu9NGAD0fiFL&oAzr8DK4zm8nM0fuR5(RdFzf4J$I{K|yoN)VZ;p#cSV9V=;g zx91USP5kEszB-TaDvEA&O@$^~^g`aw(-}kK3^Q}L%T!?}EUiUQF=lz^NqdYNl3AUj zN)vUC`tfyfQ8HIrlqR)ke@uIXIgx zVC8!x5kPedJx8mQ(c1*AuY}sm3KH)R#Qg$9c47?=1bz-d$?FO8qh8yHP`jpfM(lqAKX2g zW?hf^#piY>m^jzsRi$_;XcORY?$spa=wktBD)n)v)6K%gE`;6w#Xax2MbQ5INBUj` zkgJRP#ozEgQmUl)w$&J@H^9#Ybg7EzdKQ`l8iYLj<+mNWOx=kjD8l_|OBLXE?;VLY zLK_tResj`{vAx}XG~Ay)16Yz!dCGR3YQ(eG>WB;%=vUwYZl=8KbKJ%jXx>pF$Sf3Q zx3?N_oob2ycvK;0yF)oF79TQHB`b9!$pydwSLmJHNL~`bIFAU=M~26JbSn=ck@5MX z_E_JJEpPAJ($P$RvMVNOK(iK|wN2Qy16aCcJUbmfi;0_ZH&$kq$;a8yU*tX>Tlj!JjB)C{ zErD@Dj1ZlALqpJY(`po2mA$Qe&NS-Y7uAa65&O8MY}E-GF&@e~n3nyhW0e6IJq{u-^tmTN`gOKGjM_rW$IVj2yR{>M#v<;3@KmjE$^o?k09*~u(|sZ zeCfv=eddBl#3ARIb3a&o78N;7j9Sd6f|xaMY?gWssPm*KH(opH#Dy2Z3qQ9?A&x)E zUgj5*;u<~@mFp*G5O@^+M#bB>dzAOlb1KHnCHs!;IQB*W4053N4*9x9zfJ5`Nk#(| zW8iV7k~eM0JKJTB3*lZ|x2>iqpM5G6GZKc88p#SVq{##vxS_8f5qsH0&yktPHy!;Bzg~2R#fsRCv zYPeLFkp%&@-=1arQG=Vc!;dZ)X!|<%TNHKVfpT04+og!92H9&Tf)+{tJ^ypwSgxt|9g3fs163K&b?~r+&fh! ztMJp)`uor01q7g^)O*yKS1ZhOgQ$MFcI3yX794fuh#=%9HvcL_0ZK-rQ(MJcTb+Kb zo;=I1;Pgpgjq~ROs*$}@zkIPGo3vXQgrzG&C!KQNT3r~k{rR%fwQE~8L7Beg_l`T! zBp3392g>0s(VQW?${zzxc1Arsv&Ty$z$HOM7585F>Xv!-mpdGK znXj7}@Eq|cjaIBRHz`JEDy$s5NDM!h(tB{+GR7=o5DKRBJ(GZ-C|B`0Qg#3$oJ7Fb z9sJQGbN+3k9dMkuTX^Sw^Qpno*3*2fh?JAHQJf-QhjxX%^&Y5 z0pP0+BJdFp+gvF_2EwI1V32M6c);~2iKr^i+at^ANVBBoCB0brULFfpFL=*v%VI}f z0VYT+m2K~2V2{~{+)S#~VdD`+MCw01r4K#?dDV{NqK8c6j~UiuKPT|gE~~9cP~?jE zKJiq~Ph81V=$(%{$6Q}kLj)$MnKA}2XCNS+KDGl$WV!#L!OzhS2>^DlQ+iCZy4yT4 zJzephEsk}uI@S4qyoyrGwqBbi&bxW1+P!G_%F=6gNz@5bzeMJvU(k_0lHNJ|@n};4 zK(-H%!WUn!M^+@L@NA0t|5^5w@bj^4-8r_cOuO#Y`lh?Owp$mJOzIEeU5AlWj!Poc zKy38jOLgBQ!QVZ(Y`;CyPXyiZMKF8c1=$-Cv8(VSuDPO0Q!(hjy_{(45u(s;X=v1( zdXOi#o_r!|5KoX1p0}@0k?4BO^;hg2Fr~;aoJfizXv^gLqr*5H8q-$(RRP@>qI4Tm z_NZ6)W7kQKeHSy?_%tk6rkWgwiZZC6v`JG|guiGzPIZjFX}-abAtMj!>Xo}WqA8PR z3O&b35e(pQHLS#n-3v5CUEY&<)E2P+|d_PNdyGcUrzJS5%QvDOo#fIi7h4H{;!Ok+AYAnX`z;h9M?uClZ<_%mf#3hbIv;>NbSt zlL&rQe`G5Q9*Pb>#HulnL8HPLMWG)Z`KMLxWDgBke4@Ca7$gu^>Z2tR$gu2tG6O!_ zbHDsdai?It4it%sO^>|h0~tjtbVE4szk+2fH=rx8td>js{rAQP)%j}i9-q}MEp{P) zbBvd9-AE1+P)Pz?-GhRxtj69f%z{uJs_)jYH* z^lXH49JL#$0@W`~Si2yl!GH@qX%%-51AqLN!&Bh6h^jEwP#DHkDjyu2){YLDaXl_Z z#t*sfA0(hjm#d*|opI@eZO}g0aUdY;OKownK>90D627IiooPjiqasb@)avD0FEi9a z#@)O>y(fh2DM8Q1$t=kf|M6qrmREs%6n2|?fPFuMk*rovlzc_H7Rx)1x|Ti4*c=z43zvJ znDc*@Ldz-d1=?tU@94*53et&5@t#@a;cX|!6o91UYpV?CiogEw6amA<9cwTOZpato zosPV-ZExM#B6Iw)SeAIwz#HIoiu^BuH13mQ2oMe4+9c(v5lI<x9gdB~_+#7RP*bj(ef5Lh6Vi*!G=US3O|?RO>cQJ~Y8^t9^a=^$$^ z>;o1$p3W=5s(m-qd3W?EdWs2dQ#7Shz=YS_{$DNx`rzb=Cl0S z4drK$2d%OY9XCHNt(lD=wp|X9h_FR|HVDqGm!Vx=;_9(T+V zL=;4I(XgSfpFi3C1CR>v7q=|^XildSNix(WBAxxn*?#d=GEVj4d$(FY&-G*3aSSG= z5_ra=^sC!%G32SQY_5Ym>OU^|tv z5q!ksp#?Metx18Ig%=qG5|96ncrTcSxGRwB_$=_GFMOhjsT^YiU$F`#oMZ_VNCN_4 z#%xqVOhp=TI~GIr!he%|!K4P}S3*p0gfa|7j(G-N3#I|9%#nlz#=Ey|H}707wLl5) znj8~LGo}(iI0+W*exIK~--bPqGhcpS?EfRr-o0roPyW&v|Q zRl>Wf2%KQ3`J=CwkrccfEaE))%mF+KL4B_~-ku*P0z&Jl7bpR8{M?I%*V5Z=#QI!{OR4bZ69pK^5>f^%#HzS4RCDj zXl%{#Ogk>pMh~{l*>cYc6OIo5D6B>~lS5RMQgu!P z`wwQQuHWF6LCLtC6Zs-4rYwnH>nF@I8kbtskFTNs>Gw1VaF88C`IG>lPnPs{9hC;p zYXj?>%KKN9sfca_9^cO$*OIt79e1iX=y=#^hl_q(n7V88laGZa6HICIfPkYbEn~ z#AyI{)R@h%>ZH%2OqGc64JSJ1k7oXdumWW|kOl(@TaY2hUGB|?59D()g+x=@*hhy* z#7x(Z7EO#D@5+t}A)Z`iB+{$uHLv!J2M6pzM3Z4UXM4~3G8pAqpnskx%eHo;7XBZ7 zVDnJi#<4azQ*;1FiN!l{{Wv-$=>yYR&)y)3=xGbl`PFkEaoFxM&8enSL3+_; zFqZe-R>2WOR>J`#hA#K~!K>Z>eSctZb4lRixkLsc1kTl5@>4Hum}+n9$QdHH@`K%9 zv`E4hi^lo{INUG)R|WtYAAJ%9wwFR0SH%DY>)I>#E-5_&L#_l0{*$L6t&{>Gx83rd zObzh)+AvxaC&peTX?bcxlFY#6GwLCF;-Acg*qQEAdV*)b$Cm`}p@?t6O`$_Y%S>Wo z(WPx2#V{EHgBuNz_P_KIe09}bfMG}82(VU-`mXRAxz#e=`_)x}Y`~E~KU@wjIJN&( z0EsxL&Ib$^erb~;LR`$HSD94!2Sff)B1VGKl0hjR`Aw1iUvA(bcMvh+bCS*k8DLF= zU-P0!2Dpr^g7sHuzcBg_{nLE{U19QM5TmO%iJN9Bg*|U5Nj4Ds#OWQMSC0s$vB1ZK z0HMt5X912fkMUiuC&bnd!=kM4kM@VC{;l&9FIcBv(2HBZ9|=|)vtQsiEVO29YZ1|X zL+ZUkJzShV-cB4*mG$vp26ELvH7ZH;=Q^lHZG?k#fLXVG*Lx~V|7i}yrGx4f02HpP z3qaG1bdkkev$4}S)*cXO{k$A9Bk2#P$R4is{jcSa(>k9?)4(PVC6ge?!BKxvu^7_E z{lxYsHXF$OaX5-@|4hNl@ybOaKpVAo9MEK!RA3nf^N}af1>d~dOekh{X(peH#(K;C zNB#2ooN;2k2H3Fdocz1esl~#dsq8=>)pc{{87_e4$H{@`Fh3&aa7G2>7+8n8)?SGN z5D6-4t=&@Of0%Kq0&Nq)|12u2>m9#{(;V@CVuqevl_Y|kwy7)gDkQ3InVz|){Dk-) zkwo}|>r&bi)+_zK?%U+#h~L{StG$rZK#v@47KyZ?NOF5BjWLPinAEmTApso>kJKt4aDQrgpRELyO19N9J{u@c)%-+m{Q+i1- zW5?;+5Bt|ZDpd?16?QKRWi~k7vlI6$hZOZ>a}rMJr5ta|x_LiYoL2^#yu%Fu$Cd-0 zG(9fT|Ee`qXAlJD7QuOJdIjfJYbuQ`JJmFVwORMjQ~=7qDV!W04hslvbaauV2~0il z==1eP5&cQyZ2uD)+(`tPVREo}-RV|4QU$yIALX?B;;S6MOhb6#z1-!ZrAL zyA#wMEYAg`{~eYz1^AdG@QOZB>6XLH$f@2enDG;fD$h-#KMxM)NiUQ{-{qcG{PC^M zQ4Qa@z^U>^=Ba`x|1fcH9Bh~!3~z+!h_GRVgWh8f2SpkiG7a3zUSa-kSP&%Ou0)SmJHx5IYQN=_-fP$}^lCLRAZx}(EZD9* zt2xVl?z~WopimYRduoxJnXl5OotR1mnX46 z-$?l(-OE!9fZp4iL$vVVJO7Pb(>_>xbTPP@@P0FT?O^kiUgBZ>ABh1exfgfBn$gTKdhqOWm$ePHj}kpkbX#{i)4tlB@4%YdD+C63MpCHIoHTmNnkEo8OX#|EiH z1nCEbH(Z%;s8tHBPL64ZjQGU$cM*LxP_BDwQRU@*7My|%z}L5Hl)xYV=6`lge< z4pRG@r=k-Niz)qEEY2Xeb(wkUtmg>Z!8ozVA0idd6POmLxYgg7u^OL>4gyPXah&iw zAZ*E=aw-b!0)*BchrTQOsnxZPHe#*|>FY5ABzged`@`G~ZRx6H1<7gtDLCDMF1F8jbTp(+~HF(s+)mCZK1R-QSWS><#E3OS(QaKHxlL zk(<(+_Wz~vXch;Qi0$Absy`5C>Tb&3ri2<}6`ONCq@dnJbEdYhV}(1w zIrwjTufw%3w8K&75Is1TvVTGAa4(%1@WH+Nr8d;x@+t-eh#(pYN)hRJ8tD0WAv(m_ z|FCaA_`kiOG^fLuPeXQzEosdS<_8!2U$2*vXTr${)V@X{0dcQz1n$RUuLE?9adA zt)z8rFXi3t6s2&Lpa$8r7=i2Hcvhua zF-1QrweEw%%?l=%b{_f0LwMVoX_9{S($g`_$FTn~Tr4JM7@I33a>nngz#n=^6 z|I9+_uh)Slp!e7NOa!@{Q^R~vJPWNSyA9Ex^u7ZU*yWQ5Mvf%{*UjHUKV1UAmFc1X z97-MrP)#swk_@!r*meoJq_SC&S~7-#tkI(x@4dJWK`J&w+bt(H>rF_!pPmA+!%6=v zTIR+pD>;p>uMR)~4MDrxUC;6wF7qdXcJIPg>{=nH%aWil3eiANmV108s-&g3T98fx zA%(KR{ApKBkLew(R!LG9M=0kM99f>J0gf)Qw&`wi-~MpSaUT9zF>Isf4jB|`_Fo9Z zLBHGYFVkz%UIRZx_ay^w@+!eV^;BHu1~)_b51$DmhC&^jC3MY3?6ngKvYhj^AelG~ zFjUjdQnLe}=KLNqn2hsNd3Xxxn@Z@^p_832J*Y2;=~<(t_#fx%2e7(0qx@r<6Dh%G zFE}s@6Ur@DAV`vY#>D&{6BziPc6F5<0xvs0|7Q(re;Etn0X%5p4-?1J4GlFxRcE*w{5|&3Xqsc#=KA3wI>d@tPE0#M zR?PCu(?FkB9$(YgAb2gGoMOwjJVxAKM;bm1)D&$?US9H>)#W|;7>v>#5z$)}Xyh=k zY<>JYwL;tIr%1U~VJok8!L6Ck&VFKA6j~7Y?*afyuL2Z$ZMP`4*oy5~5uGQ#^8DA5 z>l96eFBu_tbBxD~{hrKueL2`;qoRj{mqtyd1sPSCqA}}ea>6!e54ru^^lHh;ttRz4nC=OIom;EXQ36%ut)2$YDWL@_R z442rEVEFv;DNtNeQ^+9}g!v0>LM)Ir3;i^Smmz*Ok{g4DFkcUAMUCKgVRqmsM4tw7 z(nh4`ni0XOS^I1I2$B)zv0hy!9_N#h#?RDPeU721AEGheZEXfmZhRj72R6_R^YpJV zBzTR`ErUZunWPJq6BAZKw0ekwiDr~5L!^+rEs)Q4rv`{hLF~*lYEKGfpw)Zb;tjU$ zkFPj|%P6JK^|-pajbslMS+%LaDnz()QcJ)nNuZ`GcC9u9r;r=Lxa?FNoq~~Vq^ZUI zq;pJJPxKOk$}acp*VL16-yh%JMq!&|zCNS-eXF+2?*dVRs>EA5xUUZPmnXx+MZIbCTT+glN~zp^Ky}uSFxq#lIE=PG#g@#~;+wDO>o8 zubo3*tTL3hcrwgl9w?=gOcCgszr~GcN*|EAN%a~uZct^J7Io9fR01s3^ z`H~&lbV-caY1!sb8THHMa$LDlxwErkO0g|NS8wL$r*;M=4U}cVOVWpMDc|?*Q)hC%!y#a+)Qd5k zesFYo%Dhl$Cn+1VWSrs98Q;%ZKzZ}?b!FG7XEAn z1bt(fA`uqU4RA-Pv<@n{cDNfBw8G zAD7>4m6bEj*&pKW4Cr|Nr7GC!+Ce*h^Uqh4!CNSgg-i=Uquof1+HWH$KC^moK7y{u zgG)%g(Gpn375ct*x49!;e@GT%9~=8F#~>g7O}9HaKZA9Cf-`3JnM0c#(i+F6WfmLx zx^L{vw;!li*5DQBe+$w zz+lKeTzGJ}-DB(^thi+!e=1)9mPx2?%T6Z z6|T_tzwWj{)_vP!_syAWue9E^lj+#L>1=mc*tqJD_)x)lMONk(KiFAv%zO{<8ZfV2wtW85U)m_QS7L0D?_(t8o7FNCh^%~1M9H{MBmwd6{^r-6}xhr zdN_LK*8W|cnDr=95JNGowSP%DnwItrJ8r8t9D|eH9pN8p4*pnh^T@7M>PMgO^B>p$ zTMOWkhmErSKI>Gps@oe?td7$TTv3Wbp2a*s1+T4Or)wU=aLk(*Zu<876m@#0vbI~U zor46Uoe#|URy_v0o(FGlTj`in8o3st2%I89KLe}~Oc2j#s>XxXQ;-RB`(Vt|{L`jt zGB`cqHTANK`RfwFtm_fN#P2I^`cxqGeHt`mNwHc#t8~Pk-s0!V>bmbImRixTK{Ddy z@$gfpZK|CwCDe7F`>2j#a3uG`_BKzscS8H4K}0(2;=x7eb4wncys?!bq%8*izF98mxi|yDh-e*JRx(KVCwm>0AZ}Ap(juy%SDk4ES z)jV>Fy5+l-ai5fQc}cxo^m@L=RKi8@I~f6$&u3GC`+Vq#5+(=Nx2cL`)e}R4G~F(Z z8UD8U##Y`Iq>lz}_@xgWX&kH{Slv9}Mc>BrhDQ^BEK_~w+W}y2##{OQmzSQr?FR^_L8kOI;S?-v-I(83sauhe9!$FHNmF)6DU#z`o_owXS43*qR{qBb>YJ?;X4q?Y*Sr$JOT`VZ-7hd0WTBVk6=wRt1i+Bh|ZC8o^u-DEcuOZYXlm2}XyChwk+qHA2#ue5!ZAW;?j->5;)to$xK5Sn^D6}S0do(#MZt~Pfn zYC-xJ-j(QKwIrrep)e+k+B%GFHq|%47uIn!$;2}LAbo$e)?Ab2*dX3^9`_TCO_eLl zas4EF=V1elsCwFvM-PjLX6n<6VdbbOu1+Bg``Wx!qo=7{JLOPU0UYy@3yH;N?dtYN zW7Kd5n|h1qTS+0&d!^a*j>*oFuOs$KDL$piEDa5r5An{G*7JwX8X;fF2HXdxGV%=N z2PmerE&a#Zu5y=X+-y$po5PvM_W+4{DiyNN5bM!b?B(IL8#muMnfuFjo>6GM&;XY@ z@|YiA@}bN7taR`9&?a@IpWHJOn@J&yn^$`G{?L!oRqU!(Ubyx^pEF76rBPx`QLNz* zO%S)5W)!2QsKtV`QDuOPb?tgh@CLC{yNs9G%mjPs#T&;?edzwpmPH7v)IP{Ym)R<# z5=7T_ozH$sD7(*WY3?W6?LYpOGi<7>-smPUHm&Y=k*1041#7<2iUDsLn)Dq>Rw|~0 zRIq$!pV)v0BWZ6#_sg6dqD;H=;wuaOx8+oW(*N9iTAFN`8@q+<`s&#+hp!tMUq9fk z5t6#&obPn=XY40=u?7$8gP0=Mn&_z-d&vk!MXl_O=DMF0sk;xxy`EUrLJ3^TKA7?< zBTt&h6p+WLv{l~APj54pE;YJ))JLi@#|V!Xj!>j+)BaQk1NQ8CWw9g~lvP8W6)J6w za4f~SI<=YSTz23;dO!y(OZhjOH)7btLr{z`TZl)$wmFJ5oUwVS)iASpe^8zMyqt3b z>y%JQIO2hC$H2BO2khlxal}qN?Xc2)O%b+*$uve-?e*t18iUCqn2lzS^e5$!jFWN; zQtgzD2emk}T3oXy|A((F2@rfNm_2ugn7b#qyi@|ui^7;2N7ZJLrxn*9T|kCs{J~HY zq|6n|FhQvGYdwW+foExyTOKO)s;}{Ri+Af3Ze9wVt+_s$d#2*k*>oM5Le0sXT(#4VB|NfI z$lJB+pEj8UR9ZZV^q%pFWqV$tR}6;IsM2$#o<={Obj5h$c_}YNJ?q@x$C-t+kfk!d zA%1Wae#kC;Y1X57T5@T5e0ywRm$=tl`}`%n!hLMaHD>W5 zM+mQp0qhk_OhujKQd6!|P1Xi+BP)^-JLigRz!_N`;W%`SA-H?1O*a3P1EI;?!I|%K z9sB#3=6#zLD_wmwnybTY>}p8k(fy4iVhvIfKS-}kB9ogvV5?i{&J8thzt-7)Gc}lu zFniS`>ts%14Db`W@*`gFcPzMCgiY`&NV+knQM|5AS4TxY=8)Xr&`y|7a(nHQCq#mU%$O#FiBs9IX2!}y?GiV-%85^gOA3uHy~i&9 z3%JPBmo_LFptMsUJe?!|5_xBZnA@hLl48#L>i19hvgesgAZ(HFKo=WcciL2LDFj`G zOa6ItSz}!^xUM{b?EQ-g5k_GF6om@|KJMFQ1LellMK_pIL@7vnmJeeFZcRE1i$eo^ zmI04Hnp4c|mR)g3QPl2EE#KbudPe&n02IQ?LF@%x`eRFOGw75>C99U~w_TSB?oxsM zG9d^up~y-}{Td)R99`Wu7Q$We`AUy>zs_?ll%CRcQWnx1_^a%CW~!;~ZLr6g*&fTg zrLEHQg_F(RT;9aJ=WR=tT9a{+q9)7E;5<;tAnDI>^K((^`m<|%zss%IxQZ7(?@TAI zE?;{IYa{rV<6Qnt#L$4rhS0gQO9>lcL(iMG&ARskg94pn4-RKB_vlVTaF>fntq`3y zwrk=84a(JO;Vq*Is;78leoDV~Y4yIV7-c5bKlD44F;N&Lc56^a$FUZYe^`st43ou- zxg8ceBZ<<4h42{>SNyeYCFHKXsj4>`N_9IZo=SXa`*q(A7{${@eaA%8Mjcn1iv<~u ze8@9(Zoaxk60VMD>0k&fWRyuJ21MDo_)<%*&8Wh8xfeyhSAKmhR~q60NSHf(9gr>J zoOBT_U7$M52+?-RHTeek=|t;)2_b^p48tl_^Xon^w`}m-IoRH2hM{*Xa$-hO0|84q zFb2qzLi5t6H4G?|-kNU6bCSAM8i_EAPhk$5cC_#05twpXPE;)L7yF$vUH8rBPzKTv z|8J%h`r|S&D9vEu2Tx@ARoqafiiO8+op`evQJP7*yEKD&$5`!$^^iQR{OIVq zdL!fSuJI_mB2a@k!89^Bp4V|dhg7ri*X(jB>`qKDof=r;Zdh-N{_n@NrjZc5x{dc; zL6wu-g0(#mpCH<{o-mNJQix>EKcxxDdkt7mIdE8y&!_fMG>PJQPhduPb`8({oWxoCZkhfnH^rpL5DN&$Tp6DzdBnTn%W^IKN*fg|}5^Qn($9|A*a z#+F&2s?CCGG_TGHVrNhr>7F-qVZT=bd!_kVhzMTWrr*Ht*ZqujXgnZ|HSUD3_X024 zFx|KU)T92$IthGCwe&4_46$al5u^_*4y`{P7|4VO1wfk4pU%pl2SmPjp53JLIR3m) zzSi5tgpm|ykQkFryPosO4@C+sfC{7<|J|gK_tdV7T9NlZvk8HNdb=s*!g`#=4pMHi zx4!0|ICBMdXNeo_#Y$D4k!s4nVL;U9L|-U0;=iG50%B&%7hDC**vhMl?NDyQjKLpt zUY>^h%>hU9f6I$6(5F3?Fzi9gw|AShR7!>g=lx@s0CXyOxiVMCUzJ%-|#Pk}Z zuMLnuurXz8>SNY>C9cM4Hu2%k(R@9@v7$Z4dP0O~3*WhA@+nGu6Gd~HU46^ExBVfp z2E3T7ZatrfQ-AEYFqSjSw!q>d>SC&>pn6 zU&igSGR(YK*?SfF3L!?9+OUIo`P@kL^z_5MlwFZ*yoXvD$=4UM9XiG-bI#$;XSe(} zkQY6OA^DM4W+W;C`7}kVs}MBx6>(NRa+xwiqMABOhawY9FN}3?{K^gt+Fc_Z-z>g( z)dA)`&z)ONx)S`2L3;LI{f*egpGb2JK~HpjnYFiCt{}xxgp)IAa*6+d-5bkr?pIO15$(I9)^tJfCU;Z)XDhqi(t625>S;u$ zB$8f%VP+z&n1Jq3^;df7nE$2}I=fkc{Zhg+gkk+A19#VCC(vve3LL#x#HV6*rK{2EN&%Ubz!`%l_R8~RPrj05@tX?aI1*cJ1 zYIIyT+-0wOlDJ8u5!RNo=*Ue`HMFpd5bpqJU_~*vnWIeL-`@9YFc0#XopPiwJ`I0p zQOlwpIN{t*8DMoR3vsu2X($l2O=0D?jdb5 zlVH8(^JsDp5W`%V02I40Qu&ckUel;8qDyAVY1VW>LY7PpMxz*eG^-K%*kx9-0%W%m ztDc%(5k08gONk+opX6VBKlALpkD&lHB?R322NZ>YE?I^}zwc3ajVk-{mlYe+W33)v z?Ud;|t+8^<<_kgPXKcfA+}bo?mHf|=W!M!rmSw4+x8;w0s1NQ!!gmNEwyb{ZV?L&E z!AVhJBK5r+s|SDRH7%psuFcU*_yq4Ij@*kW1 z9m1@#EH%H6)i~3ys}J|9HhB`kcYL3~m=@Nm2G8=#9r^Bb6FncNTatCO)ZAmbX zbAUWs&TnF$yO+Hw)?idwpNx6xa1hREh5w9lMZQ|niBC=eyRTIAJG@Cm5R9znZoFctj29WO`L-7e0H24uR)$#H#L~5Zuk&e)RvDc=D$d=4SMD^hk5LXr$@DuWG}t- zuqU!}_eruBA1(aAahxVd0VQ<0#oWP}#4flsevp)aV(4*BA$iJ@$#FBQxk={4VnUK|RXC4uzl#961L88;bS{pxzG6chSe zx7hb^wuDGV(C+=+l;SgRuHePR`CB3?;|v!`Dc@r%e|3O(9wfh3*b#;%dsmA?Fl>l| zI^ce%W!lD}Sy`4&#FSTb?-#!T*=A;vIe>!TJHKbz#aVz=_!8%cPWw=b91clDit2ifWoXPfl-5-+rRxFnTN*J2$ z&u%i$Au))mumeIwjg5Gh*Fo#W2zquyT{p-#0{;p}27>YJC6BufAB&2p@GVFeuOJ;0 zTN0sZG4r}7p4z$FBnheIN`>~9>s=WKUvio|qv?TduHL^$_Xeyvdt8SyC(VY5=zAxw ziQbm-OT)TaQaewsF-Vv@t-7FQN+OdFXIi)VjVYT?!TZ{7?z;4GG-hog-t5ReH|%QO zt8UlaNa~w%+_mCVpD${VI%I;^2A{6fb~S*XIg^39S<)zkbm~F6ZW9|;;J*5M$x`|Ed$`AguO)hu%?qMdDQY5OT)Sh1iTX-Swz`HDc8Az$# z>h({@-R+djX+%TeO*ubI!jp7;f{kwx3NGdrU1v7TSsn~2SPp7I)6PPa_3j+D7ofNT zj(l+?T720zLtq|-*Y9i~IGWclu>nT@DYzyy$x%x~t0fs(x}k2BbJaPihmrJjrM#_K zQPI%4N^!lB5YQ?HG!bIgMIc}DZkKo}SJO-1f<;W|`k4sp+pc22S;WCj&C+oX!x+$^ zM+NbP`Te{{)g24*QQ{fZLL*h1UZgflEQ`*1d|H{^1N9%KyD?#nH=yT+Y+R~JYVD)o zrND*fIcpymTkWJcY~QfjkW_^k<~ZdG@Ot>k`a{8sR*!*l*UL#e502LVShWt)U!2W< zV{MlsND+PrLFr2~UpD|*3p!0iyQ!c!>x)8_E|)@y(|R?CY&+LSB(gz))43v*kHKGg zQaRd_2GY7Vn$=7|r2y5ia_V9sjLkhh)=56mP061THsA(QmYQ`^&u&@*r^`-4H4N@4 z8bfgUfWp%@=MH{jE!BaHCFX?SJO)vnIpkl-x!gt}vd;=5~`xaIQCu!;?0=o$s;_Z}!bK)h#YWY~FPb`%wE zSM-QHE!0m+8u7k#k`*@agqC#fhCcvg{MMyz?hi$i6lb)lqaxYE0)c5< z!`=xP^Otc29w*}85J7Oy z_8+)Pofil1@$K)avTGwKxv%*;06*nN$-T8LTRVEnhKL5DJ{}&CvWJhKl}OX8518{B zaRg-dmK8vBKk07W_Db3IJlx{FLY6KWW)NIgGz@~oEw!))3O&tp|B;c*WrNglY~=$SR%@XqC@tUaYJKVnvtQ&j466p7)#GuIGq9GcT4?qQ0! z)|NWXpJXZ~4*Ns95(6@Vq#t z?k=w9pOz%-SxBB4rHHfOzB5Wo9@}3VjO+{tDhK|Pdy`lq{!^9b>gS8?-KxTHPQtv=F6FRVznHZU_h zwb!4}g+Uav4@wtP3V*Hq@nyg2OALRAE_JJG7!h$!c_?ma@0BbSaBFM87G)3yTQj_^ zgHPDM75kN4TT_Q8eQN(@c$Xqu?R2 zQA67g4zcXyfD#)B6c+Ig2a`4m-ZxSaI|-n6QizTIhBqSGV<$?pvwFAzZmEQ_^= zwD`*rZQsz*K`6mR|8XQ*vR_mtij+Nl_|}uazO@xOd+K1CTxO}7H-q=+eH3`w74tM! zE{tuAFy;*3JYrXf+<99xwLzbs+fExz1kw$IDTBCByGP+z$ z%|@%puM7Y2jE`DUtLTSCJP)#fVrR%9rW#wBv1JT{5}}+qlh}*EA6*9*n7nJP--cuyNAT8`hGo4J0)b0 zw3&%T4R2wkrmD~+QF6#&fg$yph@s7$k;o_gr$jua@?Bpb)*RJrQOTXAuz7TOG!pqz z1U1|%kLa}8sd0le&mf}d5#9QTx<$;F7YI~;lNV2OdXXWrqDGe(t3EWz%33(DmE#1W ztJlxUb*2fqKiixU;)B@P)(YF4DVXZU zh`nN9$7RziJ04M_92BK+uQ}(inP1wbGIN}U=k}_!T7q$AMtz9c-Plg#gO3O{(yy8E z+NC4fs=@`H_FIdmKmXbW_c>Rsi{v1YS3=68wi}Mi1|J2n?r3cqz^Y;NvFSz!u5 zbU=lsyYwzi$-I6}uc2&zr>|H9Qvd5FVvGospjhxGT;z&34ca@%PS6Tn7W};kq@zf- zYzal0LAtJL%V~vG=jkocvp^6ERQ~MYr2QLT;xx z&>BPy$^WnuCSjd7AWyz|#~4XRPC9>vv^mw!SHSmfemu6+nKi2ztJ`t-0Qqc_PA-0@ zmFV-Yyc+L#i%X~{<~C~?fk*C&%e$$PDA@rXlEncYm6^(V2ZMN?lbP7qDKm@7b*_-c zf?H_%4k(<|(wpnl?id%c^-_}-P5pB6$>d4Zzo;zxCC*Y#?|S93G~gc#{mKAw$-(~j zB@VPl$&<)&<&^1Fk)Q6zso}}5Br~iqb!u)u2N%-amg(8K#;eFrg!2A4^SwtuPqRdq zq>(@x%sEeqSc63=T}PFcyu zhsE6%Q^NRaxydLo z7ZEWO*P8nTTI{k$xK>@CVIHMJjQgcU(dWpl7!43huWzERa|2e-|UT$MmfRLRju8Fj1~ zJNH-5hz3P!1*E&gBWo*4-8T9rNpUcR{_Mwj^x4c2LaiMG%8K|Ga@}x{cZ)nraE!wN55!k zglG^l$q=|4L!DvL?XXvO#ip^c*fti_z#5};x;p2%Ut&o#>9Ufw33=av`u9bFVR;$~&r;-012)KYFkN7BatexF|uk8g#VyLZk! zyGF?|`O~sVT)E6p`$TDS3Yq2$UDDrkFy*>JL^o5wnNPKmNs<(E|YNgsIvEDk{i&z40>*ocUP}-XKzOYKF&^Zb!VKi zP_=+Ex4delER;Uu40&DiBWtYOlGbkZFN}6le`UElbw`YyQ*D94vkU!5S*Blxbzd7l-S( zE5)3d_cX(4`7fJ*^2UD~+_J868*t36_VrLN!g&kK%g1kpo;^FuN(6DHtS$%atnpPv z8gvpruWrT)i=Oqj`0}w_1)lY&~r`tYa4GRJPR(&{28mr>(mtfc!rhLPN(JH z@gedZ1SKeDJZoBan6feC>qS+0uZeVPdT(P!)Zi3Ia}4UIoBaK{>4Y_St+oXsnqOD# z$imhp)utvR{lTFW3Zd-3g_q(!NDQ;t(*;0ONaBQky#NIayf|@kB|EKU$ z;m9=|sExIPifif`{$5m#-1u8gMT;F%MS++9&I`8mi3!+9ZbJ?q4tZ4jc)ipqe6eF< z?Ebj)5Dmon-5Woa^>_YI5Pt_ZLNyhI`FFe*3~QH#$*J^jiGYJb|I^Z7FyCx|Tiil# zi1+HGBGvP5@0!Hy`w8TbyaO_NQ26h+LC?nlRrUwfG~j|^PYWurhvm$N;P=l?=K1G4 z&aMD{Q2=Sx(`KTl{oZ&SUoZSa=6XyD@+`y|OV0}s@=ue82x0(oJ9qcjC;HnPf&{p} z-v)t(|2BEr6FGqqi#!5l{d(AgO1j&C+5c_wo&LL9z?LuUR-pD9Rz*e=Q|tXg`jJ5z zA&bgrP*C{aMs(!*7NFOmpdv5Izx=mtv4U}fRzu(Q9}|D#|93$6w-f8bd(hmZ1;okj z%KZN#jE$hHpwX)lpGc9>4LR1{Oavs1+t(egUIzI7r_FH@ke_Dn%G4H)EH*<%ODhmo z`)@0gC#BpZ~XM zu$&+p@k(IDezKYSsoR0X!IjXz>j8NFd4e6Lmd>)t`rZ7Su|eFaCzJghWMC!-3E(kd z%CoLJlveF;**d7imT1rJZQ#l#dtjZGTMwJ2Q#k@6{Qs8x0wk3kgDe)fiP7uh;20x^ z&z%L%Fl+A<*7`fN#s?4vg5W|0+1opqvdKcp9Vf@O5{L|mw zU=q#~Zp;6t`|F1DqW_=%mrnW*`w)Q8&L9pVQ2F1+eL^m%gTT^57jog8e@|6_Z-Pz` zJe?sKYF1}hB^;c^88*>7^lxYI16=TA^xZB3@+zf*!Cw5o@Np8(Wq``VuZe?W4TTz} z|95(FP|pqq!E`IoqgQ{vzrjuVe~2e9b~1Y902uwqy_~|^|3GL3^FQU;ki7eUzG%19 zb2K(63Hrapk0Hd^AgHkXWOBVnG$hAs{|o)I&HiA(chlE-LT63A{l}}|O$)a5lX9y4 zWfzxmuUUayE4(RxC6zQd7jTB1UrnYD#8utk2udxduiq+!gURUXGa6$u+H{ zus1b0z)6*(yf+q7)XeO(etP4DRr_taj8hBan8`e~p|Y0bbN`OXS%csgYJ9Ujcv@~* z)4_acd0Sn|)bIQQp<3e%V`y4GX~^R>XP754nnvswP)Yx`;#bE8ci=Ri#PE&=-g4!W zNB$EkiDGes=OcuV!HZ-tmMdXZG!w?X)!q7@=Qr35T%j~qMWMe)AO?G8mz$rp+0s_6 zo5e$G{Z-8Q<#YIa7mO1AX%IJsr+>1zg&Y;mhXlH^hwA?;yuV{|Y|la$bR4z&MMjD# zi)$xrxru*i(zanyFK=@EIoVNa#C`x!_*!f5HOyqQ9MP<2`^n5@JgcN(OHUB^S45mK zv=ngjlAJ?zN0w8n#CIzukJt{+Yt#*QcVSC)0$;=MzAN8}R7KfqFb!Rc1{r@@2o zPUI`0-<*~ipAI>xIN)0+4TsWly5o)*v8^%k2M-^-*057~q0?Kqe%KWV*aQpe)mP*H zLoEIm$3JXqmi8Vc{D<4*mBD~2j+baHM(kuyv&dVkj`Y$K$?`5n(}sN^{}d`B?pIi$ z9#jm$+ef}PZ)&PacqboZ4g$ixlH6*ZOU2s(5!Dyqj{D{={*eRxx54MG>cN+d3P6=7 z0bUV%#bk8K75iwre9;{)9p2sg--{cm$%WxNH0$zcF zy) zN?NOFspEd9^dxz)Mo;Qz~GpRxw)GO5DV-fM=y&05!z?VVW9JWKV!Np!2qAIb1B@n1|9tWY-i^WrfI7;H)vr-VD~C zgU)51eqcuaj0hV2MBVgmaLhY#ZXgJl6k6D&uh`l?642W;8MVsyy;QRWS zhPG1wxE(3(t8;uOFj3xW5KUyV%ah%k?|R_KT3+fDGuR&Eq?Z8C&|gKv0Vr zrG)@}kAcFGH%xx^3sH;6Rs9{IFvHwle4dtJ4zPdd6dm*@a9#DoWAoJ~OdJ5$D}K8K zgLy@F2%sbkFmOa+J#l1ry!?GPxtFK5isQJnzj~kVN9}^sYuj}7KQzG-l4b|MowX(^ z)~RMBH1cKi&=!7MQihC(?U)Gq9O%Xebmn=OA8li?ozp3a#rQnMiUle=bb&_fes}nD z*xd&5kv%Y)VA#M}ZC5@|YSb98z-lP`0ns@tM3f&P$iDN*ItDy3VkCw-_VFQ^D0)quuL)-saN*Rif!Tk6Zlbn-;dR?`W99}#l2Cik{O zWb#EuNoq4Lg=ejZq>Gr}DyRS({8s{Z5!ciiDD6Re;P_3^hVsYiCxaSgMfQ~^E^-EZ zCDrB-yRI7!IsERiRDt07<&}k^szJbx06Kvi{^+++=A(qA4u0(6f|2QcH}RvcJMK9< zu0>wAkltwFZ{`l%`$GG7zT5a07FIO80y&WPUYmhV@$`!0v!}USIic(dsY*Qwd4Xlh zwBfp*nhfG~YIF_9l)ZKAdr_diP3#H^ZGr96k3}hw!a%9MbUtZ+!m+POV_I^td>m}# zIJM=+rCz+>R$dSyP;R()@I0o9ydE4TH9SS@(%`QCU4(!m|1K7n<>DluTWb%!$SKoy zdt{E)VaVu!fP7GT38Adr3~en4du|_Oebb(X2^*+=rpRz2rtU0GFAz`Wx4U#K3AG9($w5(R$JZ$yE;Sz% zxla`qpQWPpQ zjLYi;?EAE(@bcgPpkMyvzztE#$}+BZ#fe8CG8fcuJrbq&E}bkSUS?5OcB@a=%Ot>8 zmNTxmpk?9+b~jY!w<>#pa|yV)ExCDjc7l z7t(?&8DzFQEH665H{`B*Qhz*hZ9Tm40&LRC)}Crmks*I8A6y0mse&U85!aE~ZHpZt zc0-SZvS~`FINm+0x?9*ij=jDB`*<`_MVEFlT-9N9GDihD zwKugiX~`3CDoNz~E_X!=h7_W0uZ+@f{ViILrR@{>%+UAYMdFCR+BQ0B@AnM*R=!>5 zCa!TUydMqEs^hR4FKsXJ$%En9{j;yskn)e+98g>_lz)rNRO{BKg`b5j>I4$IdT0I@WGOk@*bqe#9AQ|1BqciG55K(uGhA!e-Z^iLzRI=?d%&NT;CHc!S4o_(}Z-}j2QNv>?u z@}L}F3$)$#pz*!#u=ccL`06*YTa%tEy|46@4sDY$&iwPXA8`R8cYWHo3vbu`^8T^< z307nT%lnSj858A&aqX(v^hJ9g>AP0lO~TB3ukDo)rFE334&eSwE?OsQ+f$5FZu@%t z?76dlNX=VN$lNH2r&6^ck!A5Pv`v<}-DM@i_c-K>sZ7pYw`lLhbX1i3<&I!nG%BN` z_|Sg}Wy86>{if^@O`ebMM4xMh*n;Pb|IYeDi2lXCu+uDTDv9e6+J4St(L&FW^bzfn zQ_+0w)Z&}?%U3&pY*TY_Ap?D9J8ps-up$;KRgbP0+A?e`28d-hnQT`leCg3v^9%G# z8iJu$Hv)2;1-NifS?*fnlPQ#K+}NL;_ucpT%8#c7>r3-0_dZ0M4Uzj8jD<=5^1{4} zO~K}3Ww%mZ1Oyo1O1(Z}e)}PdCT%P*9j4a26W*)&JxA}o*FyR?JjM@l3#;ayqCY!(It&|kPoT~4WRO`q*U@5zkCutNLLI-@2yKik9v5Rv7Qx^Cd5k{Pa z+WBzRV+3V_8f=Dhu@#3Zy`i1)9?t&3yu~jM@W}ZdP>=M~9R=Bk>2@{DPew4qaE6O{ z&i?Ekmxnc@Sa5bhhCx2yf-6ggr^Q7?)g#C3 zTUq@DroO7zDP@YF+2Ue4VzH^5LE^*yYR)>Hm98l<$ zTHaOt;b{B(C`*4z6sld?x3sSDjV<{`fvN%1qdxuBO$~uC+9~bd?K106LvWGaI(7T0 zs8tfp#6%QOD*N%L<-L;S*0I?-g_9I5TUYjPM>d@P$-4J`$t*ePPrJBY6JHeKt@VME z@6?XoxILo%XYwX#J`tosDn{K~|GDizf35rb`YCMM!M=6=b4NNmK834?B4VslB#FP5 z^c$$|o1bRh+T&+0@=CpjO6E`M(E1}~qV8J#U5g_laSczM3dfF8r|$mTuoO2h(K2QW z8(fnuIqt$FNpA~rNKST*O&NT}L^^M^RzEc}w7riYW7*lZ^WDQyqeUO*VyM1Nc^PBb zuSw*|z4iI%ooBei_+4spcQpNe`9*x4jx4aI$UlY8RGmht?XRgGykQRFmSFIhn&*9b zQ!V!4jTaNzEBj2(gg&xby}kK3q?X7Qf*7_c@3elx$#z%LD8MqPEOFAtju?;rwig4v z^Dokiw)|*#OV5$m2pee`90#8E6aQHEqJ}5}_cPe08<#-!t>PZ~Qb{E4aO?QCVX5Ix zJ(Q$-vD>rzu-%NqPlmn#QT^TCt=NBx^l*R_UpVoL3$6FYtswcXWJ!I9_h;O&q#v2p zZ{GUXRZFuP3s@f#mmgEw^HsO+n-7^Md9#Bfhj(LaP4XY5;=AeQl}dFYygr!($$d-C zdD}{+IP9xd*F&ajaLl&1n-WPS_yuA6R{L51HAwJ$V35Jhg%`i^YPxSGDn$fZDUu9- z>U3Xd=6;7`IUXnJWk|Z6lcD;;&rX5^E6K~7=2)YM+v-FowHb{ud1;j1~6P3F9PdM2Q(Z zOUd6_xZ96ZXb^0&`&v$HmRK>aU-W99YE?l7+ca zUo%Gsu%8lN@W@CpkwF&9qV@-MhNOy)-3lt@f4)UT+egi?o^r3NS4^;d-yC|m<;58F z)&1dcgjT9m@`mU&-9`Js01zBW^VvJCY!SwJ9dQ`O|0+L7Ju8jBD)pL0BHeiBdR>)< zM6@Aw0K1V=OyOSa8$%X`UJTot^ z6DFw#T^&D8Qesm}HeI)Oq|)71UyAVY@+mBDarH!s{&|#$`%qZa;Mrl!bL494;dj#| z(tk;+&lJ3w{#K}KYUl;hha*{gDp{h?zy6{V@4o-!T+N22{Zxw8kdL>A-ZMjVtL~;vSRjT_}T3?O0#3urBt*%&%Tuc&m2&f~Hn{R#u)e`R9vBF||^+zH=D~ zQ@L&;Kcpo$nM)93%iAA^7Z%T#JCxb6@%(1W_Yyj7UTFJ~F1jWAH%_dmd?j(s4?$B< zTDZ-I*5l0y*87tg;(u@<|)hh6WkjU3aKD!j134w%LJL zL}c~T>$ykghdTQgeA0f)KSkTcU4hTu>SmkXE)7BuaYiST^kWz#7cKW+yt_@^FfPOv zt{OWrR(q{#?3D0p1G?#lYY5oL+Unj%feHF{=QX^)x63d4AHQ;9y)hm4&x=FFoLI3! z#uBEFuFe9>t+d;9`>bnu$i-rx?d}RaNy#q`h$#{d^`E&|_InCx8q4hYGjW>}hL>!X zJVK4I(oa#=-^x?Jl}k&#nnfinANthHSv?5X^z-|&;ula`g-pOC|8aZ!|JwTNfT*A6 zaU6e8f+*b~AV>*_DBZ0{gF%C!(k*$!iAa~yjkMAw9ZG|gARsLuDI9&k5#K$Z&*$fb z@856#xr5u7otd4Tot>FI7_G}H?sGzv9?!_syWujWrVFKsJ-yor>$;mEADIl z>d;&1p?xf<{wf`LVrY>^>FV<}zO(#QVHHjTjd5glMAeLT{M75^rq`{rufg#m?fYOt zj9JEq4>@kmcXdwSv-3ajcGw!vjtR^vgfsx$J9 zT8b#6G+E<&w$vB;a>NP}$-X7C#7EOo#^x;71U}piG6k$}u75x?9vIlN>?#(HbYy>Y ztNMD;iP*}gzC*@kg4udjZ0l8ocSN}KTZxB7_Rnrse_lKo4Au^Woo^wyb|ung-}asw zoho^gAPv%+I);#jk)mIo3Q-=2 zKbSRE;&B;tM@IG@+)53MBQl}PO_LK161l~lQ=~DPzdYr%&{U2=UKLr=y)lT;=-Jp$ z***6Km^3UQ1G`YoOb(V9`-6;$EnO;f+pgtuZNtq@!VJBx9_kuSj)3(DDXNf>z!zGozT&AZH-|H+3l#qEu?zY#Sb-hmou zGl~9NO}o6^Y%W?UYYVggF@RbSt_#o@Rpz;7 zdMN3Y^Sgn$iSpr#*9J4kGv<<$Q(|2mImKZ8wSR0qC9W#5=b$i%Z{OS<5r_BzE*!COGY+HF*hM_UJ8Xlh9$izh{uJ zHZn`Ej)yatSF?CJ@ar1nkD~`iBgV#^n?z9d$^r7;5ABs(j`a8WDCn@hOD~+l92<3%1^wajDM9v5F*pd*EEW zchmU3+%;bIzMBg{Vw{fZH=m_{%jS&N`vyJXA?$jE(=LehX>L!?#!hEtqVWw3+%P`y z6CVq<5)Cih%?;1xqw5hEIAWA?ZT7IVp{oNmA*9x35co^YJFFpYUvSEIsgfi;P9Z|TDv=Q( zRI7j^7EUv$Yh_@#EL>;PWq2~q=Y(ayi1_}vX5vYns5aHQ9#Rw5pYyw>Xc5)0S-YQu z!E1ZTFHW~}jn6&1a3t`Q%V9cmM(+NwGxxkGHw{09NRwT`V;iqjnmMq!17^`f!bR?S0)+=iY9NaJSD0sz)Nq{Zo{>joi25x`6Dx z)CgL3n>&GVj4>jbA3Fxz&hJ{@hY?7w9(3ht!p&61&PL_VwHz*~;#D;}_sC#WB`L`~^4yEj!0~w5 zEb5ILco9koOL8p4V##QSJh-?0R?C$&1KB=Rqd7RRauuV)`0?ZJLR; z{ym4)uE8E#W8Oz0=$??#aKzD!MYZmoR0~hMoR#Wkrkx`#1e>`kGMz+PhO=xS)Kkd5 z(;N5RYEFTT~A^XX9F2$%P+ZzGZHH zI9BI~oYIJaO;I#I9_|R%e?AJcY=2)oy(8{9?7^h)Y{A>mo7OQs?>27D!>JbuAA&{g zr>1IfT77-wmJgnluB6-UYf8JqJSZN#lN*R-ohP%BlH?`C%Jh^2j7x zSbmZ8s5}JyY74-GHDiN0?B##LuxOI4gu}~XELF5d)@5cePWMCkF+JfaHZQ*x0GAzI4h;UreRbqGvdtSUQNk_7rlg;W8Se(ZzBGmQUlJm>D$NoDt(cj;P<-;0s z${wrq6)lT6Htyz<3QQ-B2{*tpE{#?>l@`0yA9vb#;zmfgFiLKxIeJbq14({#b-{=7 zv`d-{7|^`C#m4Jh;PH1Ap5V1xJm6>R3%_1@%eYMcDRF+Zf?M1+pa$~04CRNXI#D=~ z8BN|(zhCk;4?bo&jt5__vUX`;IC4h%7*`<)L!}hHR=h#wD0;KsNgZ?5wzJ8yNdD=z zq--!xtT@zqS}uy8ZQ*SzvbLLVzWZouwZCX){rFQ572VRP-uM%Lqvf{!{^XviK!E`k z=L44JcxQT(ERKze;@H56T^|2{RBc2fzus)4_a)mOsf&-A5GiXuuls;vC*GN;SKWZ&CXc#4zCGJ+FIg>%4}2| z;-f>Lq^6IIlG1{2eBBUJ(`}0FQ}1+*9ShvMY@nVl&|6*{8}CwNUG>mxhmeIGfihrT z#uxZnHSZG;xBj%rJ|>reP6e#=Z*-t(8X2JVdi)P{)J)KOU zfpmV{4E_GPP|LeC{sO1ihxWAga>~D7Y$>e^eKvt&nMRZ0=}zf3iK^U2WX z91WW-Kn+Ge#(Jo(AZ0evr5oZ>gg07s>j})^8?3RRwdT$C3zQ=M^Kg%W>N6E`S_Rz$ zp-X7?&)THA-!D^5wVbc@TImMa8^P~1T~Th=yPZiC%@$Qk-p(F^1Vj&<1WLP zm43C=?J(1r4pf}bSi2pQ8nRRphZ)ZqWt9BNZlqQ8UWuS!PZ{yL9$%rgVeaPKjSR-O zPvu#c^=xs=74>P1otf*@e=69rMSv4Hy9kx8m64971&#i1PWDTdJUvL8LJ!Q}MmTV< z9cV9$b{&b4ykPOQ_>pNlLpXoeltnU{*Zc2bfKU&;vVLK^1Y~W<~RI4PV zZ#OKoRvoRnIlLrhz`<2{^Hx~?;#o}`mag-8{QzInQpVS$v88>68^8`At?op4xCx`V zITEc*o8O+>n{=a+#eN7DtmJ3P92IS@a!W9=)IU;&Qh+xTYfEClu{e57neWP>fc<7@ z5nV~xujavCw!!h)tUUN{A3=KN^#+_NM;b)q@qwHr;;b% zEuO^*=VNKjlynwtdQ3#8aDp+JE<%V$8Bz|M?WB2CyiDwBgs;Xpk$Gu}T^VdyNnyg3 ze}L07%=~MAp)As@rY1uKu796kSuc=4y|#)XiqvpSnf`TvO|tio z%hoApoa43KI7$Kn#1$R&It}cNX*~&l)7`V4B&Qx8m+*Z|;*yYnba|GcK>(gg7GyWu z&udWy@8+gI>`c0uOm+?Tejj2*O0bWB+tsijmG8X^PyWDD$&&v2MsJh9F8Bp8W9ph6 z7pz^z5I!hlc;Pi&vV!%g*^M@YIcEM6xT*KNz8ZbQ4r5y4-l=~MwD|J~zm}V?=`2Bq zw+pjt;fQak4a1X6yV~k56KgpM)8+`V=UD5BhBLCKs>tqd z?@Zh`R4$PKNjS? zHfgUT>O(kL$xpeimkuuMhX^H}`mu3v-6EDc*L&#;j_8*fuZa=l+-}-b#pfnCezdW0ovuHxm3zI=)FaR4T2yu?X}zC&$^OtiN?BD$yPD zYtTZBc8sTlv=`o6_B}&Vba|e*6<61Xyw;7RF-GQZGKFX_zxKn?J^{X-E3XuL+OVT< z+@YDcbS|3ng{-^hgAVXH6lHwocxu|!nH#33UW!p{_BL|;TGBJ8Nr4$SrHAPHQq^h; zlE!ntb37SecleESrjTt5>jX&Y(RgOFpF&MP?@wKm37t>C*86qIEQJCR+(_hvRkN5rR8|-78_ydA}6lAkN|x0nq0oj>SctR zWP<6SXCZKxNxOgajF(`PneB?;;g}M}T8kfVSYLMu#LB}brK+&9uwBG-g`@XF=+sRs znX#(fqxd^+>f$FA(?Y`lr&yv8TP zZmgh2dmN)j%qGU#CF@(+aJaKzUlr@pSpoY)gy3k^oTPUHf?9V3z=>MiX>PX4|DJ8~ z7|0souiJVAxRS27INXC^8bC7;4CUU64f>KsaOP6}lNN$YW@B!6D@*`sAI*1nDtkZL zorASFV6yXz(Vo({UpRQ!AHF89|X1?w*x0yFpcr^jlHd<}#)3ywTQhoMuG86xTE z<0~(zH!`ZjQJr*4{`X>8$ukK?t1RxNBY1@Oi8bg9iVvvBy7b&me|ZaABVO5e zj0t#3b*}R;xr<)Twm4%Tm&K^$GM&RM3bk^`V3V|mm=t9RXk63R~>bj<&LJuLHO#Y*nGs?dZE6l+>ApDJ=gyk1Ih4(Z99eH%O{ z6Wc*)={2<6Vf0foM`z3`)P=`tY&q9X*uFTgu=2 zuEhlC6hUr>45=i0;VS3yTdmp-z!QmT`89Vj<2pFpoj>2~!o}pMdF0vQo?Dp{p$(ja z;I4grna}BBpOpCeu6n3iH4Mz=m3^hH$wdvMj6OwK!6_9nq#0*$we~2Ps(g*bYDN59 ziYR~Z$}~=h4SD+voE#y+%kuWK%K@fp?eu9d-wk!9^)YawVcWlrzXFRGv!MoFhZ)b= znA1Nz)l5w~(WJj7-U#gKqrIioKY+ijxXm7y`{*ae0 zE=fwDnq;&}kKcYzC?bdL`D>Bpcd~5sOZR=$F%Tm#7%g_WQ5M28VcTT`jj~6P6o81` zitC7xvV1~$ZM^f8rF#&hGhzAu{Ewh^PR7T}m}6LdMx|HvRjCeY(ZQa_V(hDWb4P|; zAT@vv2({WQ$#|ssy7%4jPPUV{SF0sRNVq!U$3bqbN7lFKV{dSF)B99j ztRS$4pRv`H5%$u-N(^TJRVe^*G-v0 z_;%pzwa3Ceg79R%aAZNU&+G}^#iVaLi#8n4xl8(3QOC~K+8}a*d z1C3=0+o(}8nKzXq5mfm_@0JAD7*z$n!R%STwzRk9%!-qT>arPujmMXacY?_o%N^!2 zzIOQhOJuXP~tJs*|u55 z-FNN$o3ZEQkLC+U;%haC@@j=yHzXHQSLC?7s$tK=FnM}rUm8`^&Q#8fj=Cd8I<+P& z{V3%zT52Zn-jd3fVXx~+locx|v8J(pVb9lBxxG=fF74sVFxx$lYLu)er-!4tSCA@V zRJEWBRE1E_2MYtWgN3ypZxt{~v|%`kmu zl{?Wk;_;Qr%Y0E*H)ZqPn|b|f8g^YyDY8jx+bucx*RW+K`7 zy@Q=mi?{4y%yx4uRrc8118-9Zgei^kpGa_qGzR1Q(Du@Q{Pj{UZvUap<~!MWsN)9Q zk2M>|P+`!m&+4Oinc> z&f*aNIxn73uc|y<)-7gu;qCYgfyMcCdj@c=UNq|G^rZCr>ZKnH8?791T!iw3FUi-e zh9+fqZ>=L1_wHK7Y8it-5ALrZ3Gus$1XK20kKGsD z%Bch&Pb+FuRCnp0`wqC(KM^E@ib50;=6RpU^M?TmY)#9!uVND;=xy`ad78$Wa9N%+as|oKv*tDJao8Ak@p@3Zc@!H6XCUe6AuqYjfc5Nr( zMhShM7c1NLZxXCJruPLs2rDV#b+VCM;gV1fFvLAA0hf{)lsT8+9=L3jd-^e#x^^?S ze-8Ann;)GG{5(&)G*b4SMGMuTvFY4@WHT~&Z+a>7jrIo&s7tPutXC2g28qA zed`pv;d$)e3!MC+|r=VJCa6A27_QCh8u}eJ-?3{Y;?{Sg> z^JCv&Ko;Ml1K25}JNz}BtzGhWGn)ra?dNU1i^)*C$fL%WLCQ~g<~zQnsU+Qe+w53Ab%WFK5 zg4s;?uO5M`kY0nd91+XrO42L8-{$$p4terO>?|Xy9uI9wL|L_`^;O>3xi*SI6)+4D z4Dkfw?n@Q>HIgDdXIcs4h=J+Dx%qpI0g|sBx2|>o+9bOxC~&LBf5Ou8`Dm3FrN%o1 zQz!FGBmz;Jg7A^SyIp*}`5c@%6-_WZom}y=ACY7`h+#-nvZOxd0Rd8QeTjtLiu`c` z=b=32D%P|5>GP%6kA?g@&Zg=K)eMgf>XZFgeC@&?P4OOId(rBfJw9B!i~EU}_h9c4 zhk4_v{vyII=Mt$SN9#$0(m;300R66O5YFhWL4v<$1ZA}&XVkfezFvi`9<7UEKrK}abu%0) z4FEj#&Dl`-0ScHsrJg{wrpRf-Th*AxG4_co`oT@+MV4hLT>|WR!uOO0g1Yz&tP!?- zV_El;&pW*~zal+8Kp_VmA4$TI9_rrw_JQuJFe+T_Zn1%d2Fq# zn-=Rk?~$zIu8KuhFuag@q@=ljdHv@W+89UCTz-~vN<_?G?!XH!U%RDVtu<2@|BM;U z-VQO}cH#bw0WE+alJ`TwSLfHlC|!8TnunbIlOBM;xo!3jk>BL&Ete#zWMzB5?cUf) zo8YJ7A1NL;SE%jV98ABj;BDXXc`x4 zdJ)Al;ln2vH@wvw3YuRS7N8GkdbS%_H|f+KT-g~gclI%NJuVH=PR^(dLOQuf&;WLP z9Clly3-zv)xNU<0TjL=o((PD%+gQ|B(@2_VL#dr>V6ivWHx2`81HO|QE#FLqY$q1I zQdiciXfkFDe2Eo~k4)F~%>;%PIsiT@6j-Eq&XC&YHJt7xnbrcQm+X}#oOM*hUOaBW!^m_8RHgd{GL6+ zTC8cBwM8}5lB_hogMn!~mr6oZ zb%91qmz?QMgLUA=tZ{|?OgkPo`EkDd%;kFRD;B!=nHnn@*b5J!{NdM^*zbhUV@>Ed zgp$slJFea2{ciL4=2*-30HNafQ$3F(p^|IMbCWQt|8-0^~6ziZcXRgBhrSaRl} zqLoipljB^o?H5lWH155dcS>Nqae7kpby6KM@M!lZZ=joU7@u{xZR)#J$*e=fGv3d) z7+5B2X^d7hC59)}lwivAhzYzGbhm4BNh)CK$H_nDCKRwW6t)cWSD@ zwnAz^X5|xQ@RD|clifDj6J}0K4VC9oAHX(Bbg7S^%NVc7a;~oTgyArDdzRp+Pqkq+ zkqJc5nLK+gxWN}Pt{|P9g4iV&mr9|dRMhpK<>f|%*yO9uwrUA1v9EKKOkqV$is$k; zf83cm;io|P%w`rPZOOggN;zGoZ9brZF;ksRq*J?|T-h`d5|(d{C(08Z8{Zx5uRy_a z(&ER~R%4bu)L+t~9xBi>3xTnF9!`_hCGn$p`9}i& zRgv>cIJYO_Lw<;<7MW8cA?WmO9(&2d^zdXcy4G3tJ|bV7YxgW){pSlXCN?pV;MlyN zu-!lxvo=mXG<>NdM}7uNAmz(VxStMiHpm@BAglCdIO0b=9@rI1`iCvrJR=jA3GX6cXp+8^0mW>y|KTiFl7V!mq>=JU%>3 zyd|{6O(kE3bQ+n|R%d$C=Qx-=;5X4@qj&Q>tW0K;eqGNN;0X0#M56ai?pT?ff_jgC ztwG5w(py5NOPh7UTILb5?f~Vr$>8M)>x@lUh&75Va&43Y(ExQ)v8QLXRDDan)qYPn zEs10BpZvn@a>*OjeC&;U17|qwKf9LIbp?1#Cd&pB*Vg1db-L_ap}Ds-?P$%_Ypd}f z^v6(m+$_nkY9R8E>$2+A=u) zcs)xXDZze$0iHARWVvAx<-OYR`Y^YSmUf*;rl%|!zv)1iMSs9wXZZDuHS@mUOtpaI z*V6{Ey~8~u!v_~FR06S|c3Z%YZ*ZtXIr$4nW#wavq;v$MwcllNnQjJ86{=-4lF z5A3tgZ2Fy6btZ+Aoz@Nsy*ujX8&4}Tt34B1MJ5KFiQV=aX{5LgX&^Xw9kcUQ>-CKJ zJNU_vS;4Y@^tbH3WrzFc*icXDmO>c+W~lz6n=x;}*VS5H%((jND|krA#iFGDgC>&H zdC+r$ocSt7%_z0NTTePfQGNLPnOf;Yy?gcF5(;8lxr*0Av8a<>zMx@CcHz;BmyNY9 z^q{pK4%oZ)kyC}w65(B9=Y%#8TF*P6WAZiX<)m>SgC&PA!7q$J#E|gYl>2W(hXu1m$-jV5 z6Qs${(AytG*dkzJk(C-W5{y#~wj8#>TeFK#=e97A(sy=%!{ySp>;(0y*kq_j;rv~R z+&H3Ti3Uk7Mf?om{ME$4`CW9tm>gFc?d6Q|v8V>#lGr8BB^bn`Y-VcBnO;`>Jy2_1 zuk?l)q9h+{w`yXhWCqzd9C%NuesmNa6$C+h+!RV3TsB;Uzf89YAX95sp*hf(Kml>f@rtuM^D{DNFE^Q9c4Uv`sP8$%=sqgHk{1^9}^kP6pIn z1{g+m(rkI5;ZtAEQ<9j`#h*+-RfQnWyix*akeU6Rw(K)_OZ1y*;voXk0yes!&dHI6 zE7pfr?e0i80BBl3pqvHY{@h6ia zK)j75cb5N3w9kY=jlFszne6(^%5m)3YrJ_iI;-!(NVwxA?}S-r!J&P#X3lcN@>aAP zUqi)R#Z%d%4%oV__iDk9v)hD=pVq6zlFmKPFh^R)4{1lMj-MHZriIa9nqLb+#rV$B z2JW{XibiaYco;TN`99u42ZIr_s+#&X@U$sO{&Lcq#bEjpeTgmPzFA|}(W`Lova~PD zzPl+Er`nH}XU&@I%EAkKCoMnLeE!LBI4#razm0RMEHE(A5S=znS2gft!{;0ZqcV2V zTRYJ$s!rPTeA@(TmWb}J`zBsFQOho4uLerW~l*rcFhTef>oR4S06Hj#+kijb+=5s*J$lF@?c%aaFsKRwDHDdbs z7Ao4K>66D3tPDfW7=b3AiB>U_DbLEPZM~F|&I2RkHJ^w-*)L2Uq5@L(4@!XZS_bvy z-!ZXCyDTC+AN}v-EgyVe(MBkS`3NzLEiFiB^ezb?A+Ma07kT^DP&^jChcCsAm)EB!n6wSyryc{%rW)EvdpqyP;7OXQ<3V2no6^;=; zjy%=;JOFq`+VV8z22&qD)l=5RN1OHQGnaZiOF1q%C{9t^{&2LISt@lDRB0RKn8Iq2 zIVM!cN!mP^MRdD)VFV8Fb=J34B$N{(kq<3Ym$w?qDap88!wQXDKK^zas5e*QOXluC zeI*=oxw&;s#D;vw&d;&YmoRqxzL2ZM4d|#XysA&)gF1d%2+f#;)P$LLVcd3=`L~*$ z(WJuHDO+$5-aE%sZV?|y9AaQI!p;kVKP+4kYQM1N8XwDX=qUE0c_vD3ie9M?oyq}T zUPy)Ya3L=eL=3`xmpaO07>>RzDrn+;Wtk>}T1c~((OC{0K8(C%l!JgR9r!pY;As5b zOU3fqkV3zO4R=dpbhA%pal3WZ9*DY@(==?fz=IreYP8W&=}<;?m-OTP+i-gjXaitt zcsZe|%+A1h3A`x#0K@p*F1k*Q;gB(slAHs7KIU(xTDf>M*1 z3pfjefHOx?WZd~9_G+ef7a}bi4ONHtw0=C&CjQD=-c15|-j0k%SDcg7R7LtdL_@}* z%)})fd$wB!zB|OCbLcGf7z$9S$q+*v2$_E{;udOM=j&;RM8g6v&&1Td=85O^vbj84}lm4%Ti+?+!bD* zP1dYz*AVj{x!1FPZI=oQuJGHaQw9?)upylX2E&c}z}O5P{UfI6`q+78?!iBEn%!O4 zFDgw(t-n#Qby`m2apIV*|*A8uGsLQ4WrJx|IDY0 zwWzx-sCCpYG!FLxBOun0|Lhv0qJViwz(v+g{FwFhNS3!|kU!%=_um1*>P*nFDle6%`G)CDHM`kXO!JYH)tMi;zk$ z3EY6aRUT<|1z6eqBlF;QKx!SM^BMgw9ORdrQQwgzxDevs&Yk1mxY?hb4n$&5(x_1p;4{W-CDuwH<9BH=>&1(i+-ZMdiY#=c_D0`bq1mI=|f^*p> zHJSj--#p}m>i)?KBWgga2<|$&Ew!iC%7+`EjOYKX5bDp-E`K;G;5r=B1bDQ7_W8YI zPs!CKi+)e2@?L_MT>dj}6LPDk=t07OFld?oquOZXIX@*=v&Mvq^M3xJKJ3J5ZOyU< z5FR9tsP~mvhPc%k9}`Gdsj?(*6%!hUO9t*1ZA*WUIin9ns8KQxnvbO#2)aN zG%%n*i@U>BK;UF}20HkIv_+}eqc18}_mG$-+(dqVmNj))5;dp|A*~mr#k?1xe^T}h z`VBkye+TJp9?2VM&?%TfhhL{m&a;R9fcE(x1e=f_cVJ-tp>KwraUcs`mQH_(kq-$J zV2Z{Z)M7CLoWMaIjczaDx2*^NrtQfvTHmlr%I(9Enw1PQb($aUdmMf?1%)YPNuVnq zd0&fTutbj9*#Com61+5s1Gw^mp9EmFKh4qkf|RJ+Db_4Au;B>zX7s`$wlof{yTR|R zl=K@tagO)$5;kXI=lOvcBfkO%Kn?iK920+5`~P^Ndj2P=&mvcETe|69R z(rDgy6;K^sn@rc1`vZkU&2OfL)EQp*!9P5r)@y%tw$b+GlQ!{B2III>;QZ$h!2~jp z{a5e~hSAB#GDO!mlmi$!Q^l)h)YPEMkTV6pQGZy1Ff`o~}W*&F_;`A>R3XvD1X z)NsojozuxOp|A9Li2xKveFnC%|H?mtXUi9cOq#5Di(^uGr>jZNK=E`*_6AS3k26j7 zlO+sQQJ*TC-ncH$6fEpjny)qAtLbaW=X`DuDU<(9_-rlWpTIC?Jl4RJ+**iXp-lJw z4+H%(07t?f8r633h1?EEkabb6P~O6VK503RT*y83k@=7CJ2R!dEA>V$Xw~u5g&?$2 z)Q@Cd(ZCRe!MPnU$g(4?T6hND@XhN4(4YdgoY2kr)94Ib=CJkIhbX4+g@3EtI8oH3xp&F?g z`zX^UWPn4>>KJwg<(EIA?4J%>=$Of+>Ehb!Bh`H)R;dHd7-zwvq6@O*U*er+xxc;5 za8P=OJ&$~rj&s~NgkZC52!#~;FodYf|e!!76$?n{EVx; znA6_zEB=5uc8JGAw~fTarwyrwk6)sid1xYYFAc^F_*@_(6M;4C9b>irujLG-@?wk|7wZ+YIk^CNxfUo;uK2!{D0>qRC6ZqaP(nc;ok1EJz7(qeV2NAn9~P!#{6~ zUxLTHd8qU{!G>ma+s4f@EX5 zK-VpTb6V1eW=67f*Ou)F)k70yL40yJHpkAlZ>i2Jd3h^}c=lACW}=t1A*!zk8X~_7 zOB#~ejjWYXh|9yiqWRl)rLh_l+7DVCvV4)F-+Hy7+KWLHKbL&HL7%?`WzgNPK6Duo z`X64vr;wQ@t<^$siwAKg(4E;G;<8TT_LM()DIT+^y_F!rmt+yVK(SI14+*Fy~4 z9|%AiY#1T*mo=u6gca=MIq*y`!h|Aw57%qw*URnkdoBZXUcVP2NmS+aqk*M~tY4gn z^T$*06vUQV+FlRzTmZ&{^gTRDH@o{y4rp^#_JxR3{MTUVc8Oq(5e172=*`ezCf5+_ z<*zLj$AcF88u`@a5Y8|qQ%|EBsZWw2jKuFbdPx&?B-ho7h|sFRza@k1TvRoGhF+5T z+U_R6vT7V227IdRrGxR;n0hl0BW8TxNKWqahCbg@-E+cP(UKD7XBS811Ebb^=-yxh z2;f#9-{9VcAl)F#O1$)<;(d&VmPhnkN9M2MHQIlVA9vN%9-$CFS3{fRwf`F*e9lRw zeZ()?@?W1y;W>ezdcAp_MWxCxMDXgqdC0fd6ew@So9CxntlWI(6Q~O^2x?}M#o*DU zj1gB7V%&9#VmH8oCP~?QQz0B=#mTO(`~LoU18M+9`d+7j@B#L=?1eEuvB_c-kz{ra z48nLXL7zy56NbKsFkaS(YL2`fYTkUBqU+>8Z!0{X2*02xKse=xS9wS?yWYN$gXVnV za<+&3D?ZJF2=fc2@XVZeFyndc#_yGiJH_g3xKK?ItMpRZTOo`Ks}CGJwj#~o0X##m zU)#U>dbJVx0=z&ng?zyDM??LuKWRa3QMq+)wxy3(Z-mWLI1^On8s1{c|+@w@0|CP5_1^yS%0!P$$NYiJ=TDw8ryV z?p7GkG%u7lWyDxsszI6LXtBJ19g==D)%t*y^nZ#dI8VL>`#U1o(r4$uLhnb#79J$v zfV`QA`g0oiud8-2y{3UX&y?zJ?`f~gL2%}F{@H3m!jk*TxA*c!1OKas{*$Q~Syvv55hdv+g{?LV|ov|0^E>E>2SNT;iXv zG%jOFtF^JO&4IV5|5v0HxO<^y7J1F2e{o>)WS*?bq2wZ2GDN{pi1wHG*XdQuIsU~# z%Mx~j6*`blvBHPk+k1v+ zEYyQKq42-z#8yaSO&O^~=IY&0-@gRcCrQr_xA?1uD)D=0vvvM?cN+&ZmpApw>gE40 zER`|E0JB&e3ttLmnZPd(U>Pf;FL13AfP4wQd)OY@qcAFJK%U*Y3?D5 zT3I~$LZ2;6L)v1@Eu|d!MeRh3{o+|1f;>oo7c8sdXBT-+_^0-ldaYzz`tujnC@6{( z91!{Ni-n3b@vl@$H_EfuNNitF9Kp_#f``*mk+4ME{#pDGLlZy4E0b(0@}dy|JeUDa zFmn=o_&(|}m|f{B*hqHCzqs)YfTKn}%x^L&i=6!~jw{LV)6+yY(a)4^7fyn}t^w38 zC|x(s_1@ii!dwBBr%F^cjlY)1G*yDbga4RN{zHQFPk9cgNiNLKHYI(YoYMW3HMdk& zS{7L;E*f};2#hKS!j)E%mwEVK3t%Jj2NMx!;}}o7jk6`|;MWlJcbCsWmp-y#e%^go znu)*y?#H;vCM?tRe?Zg%AU0oDlrid8e}y0VStBiBDgSG_fG9>S=^vxpf8)V>!1g}n zM~&klCe>K?UP^?0JaHWRSK@+Vs`ForAqW^_N>3&0mnlA7jgZ(Z38rASq@AI<-@03d~X9oTv z2MIpBh`aY|md9|^?(sc}k4);!WVa<6pTHvjT56BMRQ1WS;K;U{HH`^s>to~z@W>_P zWWT|GlSF^QkpOQ8&37iIYih$bLnnAm%r4pvk$sGZy9e-2ZL?d35? z-pw5_s&>F$L>T-=T{wyYI|dz?o&h)->|BD1Zx?L`cMtvrZaUZ>y9`yFgG^tlK`l7W z?(@%tFIH%=2ZW2ckt?F;=Z1{Kkzfc7}2`Is#`KJq4XfWm0)ziiCiwK6pz!)50 zjIjARdW;M`ZR+EG@QT=lf&?nFMksnwX@d7lKQf75Y!2C|`D11%Do2^V`~+$I)BT0E z5L^PV%*d@j5cWe+JQuAszy;5H3yZx#&60 z5dYmH+DO;3Zz}qRID!pV+H7gAP1pS|6y?VPlUOs^@OA&&Nz71eQWhC|;Kh?VR0%9o zaG){}YSF7uz-3jf-A$d~7onE62AqjjbEw-bzCh3HBGgjoNiS9y6b0~oA{z!mG(i{= z`(rm@x>x}+0+=q1ME9T>g9#7+IusoJ^e<*M0ECogkmrPIcrMyez_Q>1Y!sE3pk^Hd z)GN7{f6Z+!9ze$Nnga)HnreRyIE6NFJ`Y(fRpca8BhI*-`IoeY+|a{a1H)O}DH;my z{_t0?HbAX`d!ofWIkdQOLZ0@Q2?dxU(HPwbS|yeh#?yv=TX}}4;r%`OGjtE1c%FtV z(B?sN2Y@Ku27htp4m&WdB0z;@VH{|dUHGpbHEsiR9uhvqhmYkFe|bH3@w5l>(Sj+@ z37IBQm7W*A!iUqQre~7LNr@Op0kf%%b*|F7A#uz?9=yx^1IEed@o-4xf=c7g=v#lPtT0~;MYuKgw6b^6iE zc#m4VQ^rbe-ubH^kb8mynAQN9&V_u96u98aEp3D8U;l>n8^8lp&8j1F)PH_@xsCNN zI4y#}TuV#hEfk20=hWo?{&9{D-Mv#IfetoFsFmt<|3D#MVZOh1bf`uIOcXvQ8Ng#C qmh?SOvV%D-Sn;nRq-SLD&T&7Mby7`8&HcHnP*PBnFP1g&`~LuR5LGz< diff --git a/vignettes/figures/iiasa_logo_blue.png b/vignettes/figures/iiasa_logo_blue.png new file mode 100644 index 0000000000000000000000000000000000000000..4de360ae12fd5bedeb1c620e12539c00ca194eb8 GIT binary patch literal 23073 zcmdq}+vba&@~G)PD{&*{(a zbv^f+`yaSp0K@s&v(LTPjfH}63pBzNHR4LU0D8)}_Y z4*bDzl+$tnfmjs&{vfz{x+;M{)FAmc66)@0hpkGVmiZ?i?@mNSk~~q2E5u6(!t?_) zx{~m#oDt@oTlo)p-#tgPdv6e?iTn1WEg@#){A<=o9REl9}p;TZmFSF)n*E~oQ| z^3-yl#gXyQ-LK((cOY*(P9L1Um3=c?8g!ZB{8wub3o@zue}${@EdRe)ILI%O6(;a2_z%5*s^oh^0g-qr zPz$-+4=J(t|CweR2i!vWr<32GbMwBlU6b`}_~{OP4Fx9QOA;ma&w8U|r0x{!!Bx0C z_(b9)E^{J89?Va^Z2c#gX20`6lN6*L*&uT zGoBx<&}rUEE+&CryMAJiY^QMhF#@6m|(>)_is4J=ZB=twgJJ*5p+TT6Xd(J+~twlS6zUUspx2# zB1K5`KX2&ps2j?&=vM2Squ6*J(!t@gu@@s5<3S5QO{&`Zj>&ye>8?54v>Bqm8O))_ zmuf`%@)}iR?C-(|L@ybeS_dd{KBVwhK zNgEHgNnt5;$^SFAY0fgqWF`oiwBl!!;t5M!4bO>by546G*&g!GHlX$v$RiFxWUzhe zzrxSuetN}=I!x;&wb*X^^%5Fdwm{kvc+A_yH_CAgK;+#JhJOVycRxEKfB=*G%1IP- zYK^SPpG1gQ&hun#|Jz>rS!Q9(#BO>GU_2oMU<8J2 znf_Z3FA1&I1{S|Q85*_C;qP!I3^7Fgw|&VNJE3L}yNUHCZYU1SZB6vk{j(@Cq1oC* zLn`tdh|?*S{(sMcu=|a3EGHXMUl6Hqc_7rQ?ousyi;j~k>@>hX8aZU1DmtRBK}^#p z`zLRc7gvdL=SS@$W-!l3qXa(KQukaGkUV% zYm-Hma8Hkl(?huBAo6s5=AZO9&R`Kms9gukMMPac*FgI^C%ej_iC~_h|0S8S@cnT+ zAE+&H)F*8!>4I3f9JpTf7mtZl}0T`BMTP`DB0TmW7VZEv6x^;o&JI zV3xI?B9`G(4+@Pp4{xp;>c2)?fKnN<&y>b48+1IPtJ9X_w~~203_vF!sGnAk$2acz zh$9SZo#gI|W{RBAkAsfoCW4zcrR#)|2PFFowy8g@CJ~+{$#2KugC1n+p&owEwc?tp zEltm|;W|TaR?E4|3lrT0iyn=BwD)}KaP|Q`cs;1_nK{(4mSi5&O}i-l7%Yz&3N4X! zbBvHZ!Q|=xIYHu;=v$1D>3X#@dG&1+H_Pu*X?#|QJ@RW)yxx8YL&b}WBW0aW`1}3L zhsHtsS1U~vmXe`k(s#>XGgKA3ytf96(sv)Vj$faLE7!P9$KmBV;Elqz3;Py&-IqfbIG@RS&nK})eJy&pY_Av1GG(huU zQyS9sGD?%Eje^#FX$)DMv#!3#$7+G#V2<_iOr8=<3k{RDktHD{vL0#LJFw0PX4W%5U3BsrkyUJ!*`0RsBb@LpXB@No8#pV`bz45LPYXGNdEF3Z zKCoOizxvbyxy%>2MyTg4n#U=)X}_}_t0x$xAp~5 za>ITRa-!f9SAzL(FWH;GcjGVfPjLfJ~31MoM>2T*%6v-dx;V%AXE zS(u$7V3apM_S2ut_O9?XJhly7y_)-(tg5V|`_^2+$g#%C>tt^77R!omNf=+ec2CK5 zZP+y{>&M57f(24{=fHt^XS`SC*}7_SUYC~j4}GRGOFE3A(x(?0zBU2sUXxq1uan{| zQd{}`xEt!(;0|>3E+t`3SDLa5&`aAlv6jZmTe=Ye{DkMTrN@Q*Z7Up@myx-DD z%25N6t~kAfy*88YCHVv;EbuAfLgOjX?i!AeM@%yYo4As$@_rf7DNUux}RL# zuE^s5(7K8 zwm_&=66LfdCHCQ{s`~C3a(o_0E!~svWDDw_zeGrMlU{U{pAEpQdVvVmNJ;+U3(DsuB#%D(w=& zY<#6pY!g^62Mftdv)3YTD<{Ji7fguf40;8Ukgp58e?FA5q{ALb7wV6Xw)?OP4WFP} z72*}=S!=@S(D*ZfsvLV&%hQhn%4~&P>aZC5`Io%XVEb&t7_2^LH;$nF{%r|~8RRN+^5=xL9k=gS3Tuw2c(-)9| zknt9=rsEFzLc}b^#D>I@L+@!pRk_M&Qsa3GuD&i}zq!SleE$CHIDC?fZmf+|7jWO| zvkDcNm=8u`M<0^8KQRr<=z{_~ML{;-Ej|tQuAoIXYtW*`z9U)8BCEGk>oe~(djz zz}0U{1YfYflwns3=dtrNhUnahPjDS&-KIJ(2`&XtS}obuOu7*W4z`Vp?%$??o9;$S z1NmyS17CeB9uY+06m2BKwHjTl>Z*&{gu61wkp)j!Q@qm=2;(e|fIw#?vO<^LkE){| z_xO#8w4!GkD~K3_t1rdFU0>jabV;PQ6i7;^d%03fB)MI$I9|5}LbJvkuTkIN#NRDJ zN1&8q+529sL{s6H^hNP=Bqx@fN8$ZK5b05@*KB-^J`bCZpSnAHV;ZnZwmtm_QT+}*{TQ{oKPyQiS3Z85r=Y zQ2fAoH7AFq8uf5t3mv=>0pi={f{T^OHeE>0Hd+qpPRgo{MhgNw=G{j0JOqqwYrPpu zJZVAnTNZUsvBoV`@Gdhvz?L-3W=RuN(q8Ecui-cu_X!f>WHT@&O`WDI_V8T{#I}P# z8RbX36>}pbM!duM$xL{PQZtJ?C>4$Bh!>&eAq7FjqawWD*S!N8k7~7qpL8w!O(e^! zi)nnyq4_o$*0WX9u30(l=Qarva!1b!^79al6qDG$+mjS=pPi9) zSp6Wea*xTs_d1^MWH+VJvRq}1U~SpMe!Sn*2YnKG$WlN44iP(DAwsq5=Q>ozyydZH zb5V%-^}gid%dzlSH60J$lJI-6F` zQ`p*@d!|9ktFXXo^+JfJ((O9doDF|`6s!1KZz<1Nh}aagz}dFt(lBylK~8&cIMP9I z{M09PwXCWIvpQrh)+(N-p+LUbh}lA!?yDuFjOU>GFf%GN(VLDzCs)b9sA<;WJ3Rit z|2nT;K4xNWfpz+2?Siqd+D)D)&~-D4#Hl{HJJYC_d&AyCOf`GonNPrbc2URJo=G!V zW^M73!j`s3j*sFw!*L-?2s~DNmk@_4NAMc8S0)4almV-&j=Nxe7B#nm;ur*XE{*by zA(>3IzcL>@4w5Hx&$?S}Tx*i&N#^ru5ObC0tpoYc9(+H}TJ6xCo8;+G-&rJuqp>*Z zHMpxSOOTZCWnB%k#E1+~8dBo5gHF1zHoyt`wGO+4%83$%A#+ako_{(&x>>$E4E<{a zojuQ!d4cu;Quk_QWIk>&D&95ip?nikp8NgaD*KI7ngJQMb{Eq`d!##Fgtr#E$#Q;c zr-BlAzC+gkf!L%yUKtiMa;o6W@U?ZqmP( z2B57yeGY$qN!$K}3wu(#PGX5{V-}*>`ApPn!?anG#4*r{`>iOWvU2g z#B=dRn-8sHSVaqMfY+tUzPwhr`xXDNdszDwo20&RtVTR4r?^3P{>_f@`WyG(GfkV6(( z5>*%j(e^#EA4oDxikzm)2E$&n**H~X>wZ!q6OG?Gv$I8D=uM*y@HKQsrJR;rr)iAK zv?9dghoX#}Qt3%xSSfifm+_ilRe|afP5dAVhiLa1r|D9#aGv47B3#gHT89=6iq!G* z{T10t+#El1^@FoupFbF_jg?m-U$~h7zadjVEHE`g@WMS)r2i?OnUN;^#qF^W@rTGQ z)%BZ`9TH|6rrSNWd&*Pt@cx)bAYWAM>mPn5Vv1zAffr(gV~zV^+IzwW7FsDrxaa@hz`SDOa=74&#?d1Vaw&Uqo7ky29L?89j@0j z#hc;AgUmf9O#{(@T`S~Wc7k?#tQ#bu&F~g<$#eN=`(m}x zJTw~ljw<%T@UH^s?|gR3v&5|empel*gWhwi+_Y9^(_>Kw`v%$8i5}s1o@2*{+$c@N z=U_0MLyvN{?5eU5|R0)tH1T%$XVe3-`AIPT>&(hvs* z;MJ`;Jbk#I2o-&#f&IpU!DMZ{g>PeIKY;b=X~7@ z+bb#7F&UW^sDNBl^pPw97#+IVuM$NJ-6-Jmh-hL&NR?++k)5SpbE?K>y zyAXQzW9TKeFv-Hl@VDdhySftXh}xRtrRTZKjC-jsZc$yqr0!})R_R`tQiUtyBdPhpa?7zsbw>_ty#$b=E|Na3MRwHw} z!cbEwI()0Cvtb)<)0on4dT0K6X%1m&<^Z)RX~1TC7HdNZpXM(j6j0e1M?C4!3W>Jf ztO@oZi(4gGfyHCWUk%^HR-oNSy3w5^-9H*|AmSP$GZ=%)Q$M{itzPEYRp$*k#{yZU z-_oQH5Waq{tF9JJZ^X$~t}AG*dj8(EIdSYwJP?XU(X14Y5@d`OQGC*Qz5Mxk(iQE6 zJRhAxFCFNFYR^Uwjm17|5v-T)``eKHXVKP$9fZUzlMEZVAkl2@uKVJ5AhKT zw!;9clY<}UWusvTuCSJs`+61oMnPY75|5ntm*ZoRh_EgdeMdFN3G7}%|8p4%&GFM& zJXe%-LZ)*hj>gaATSxqp#VZo6U3uOCL3EEeHA~BWFRPbkH-FL51-ThI`lpHbQ-zoq zY^9eD!4nwIZEm2g8LtD|Ms+1f@EuOWyr20?QQ0@~?CZYg{*37?4H3)iOKv1g&0)|- z;P0yK(-oxb`uXGgW4?f?X^ zn%I{2lQ23HH3EWj0`W>bgGT`qug5tROlN_I)U6cobiIS~*&xBUU$fK#>X5f`g{GW_ zpnOYj!XEbHJoaqA#|jlp{UxoG7v}VwNrh?lKe+4`U}d8-17`$hI>wa&H?6u7Or=}L zN2s1X)21w_Yvuz|zmgu?65(?x7bGfPvd}XRg!*KQV`_vfi=;T}GDMiApw&Zq} zzGGF9`D<)5*Mmik_Fs#9uW6AC#7U?NIz;t+(byxO{5||n6rvv(FR1+Eyy|+>FgW&= z?8r{qf-rd6E1Gf4d(%l)r17~=!qTxSqa&kB**%XS?Lfsk})`yN(c(dCEBRhT!P~4XHKEvvDUvgF6Hldd#ng z9zLQ5*`eyJ+}Byc?cYG^fB25H#PNPkcoz8B+*RE3xIu`;edG-6(a1Bs&>ku&Sq6$3 zSp1#|+cbj)vI&+r$hD;)C(Ch6pyl3l7v{g`TBp1DrK$f1vtX%hpGub9OdS)?bdj!+@JSQM$T&_HXAd<&nZ1r1 zR9>iGJ9xveI_42$>QNTbKY;)~MtTx$iU88KVO{J^z ziN_7!zf-WX)Y{2Fxc68tv)^u$`S_x#X>5%IcARq^vxg_al%upXetKmPfrE-ID0{T! z<~n`JZL5>{N44?TS)5Tkv?c+zq__%B8PjbYtZj$VPtD7%Jc2JWFPPQ!{`4)XIsWEx z@95u(_izNb1~Ize*8#p@e>SDiy_V9tm;0nE=<4w;j>~1wflW^Zvxnl{+_tb3)R@Wo z_XTYTtPOAamrT4{h983&c^0971&=*VS@Mx&$WcZW6T8KmXIgKOe+m;T-DqvwlwPVt z>GpbA)z&C8|BV^t@t*y`;oYIChfv&{)!glT8)uiDL0S0LZsxsCof!KN*G zyhbh5=TVMnGH&o&5ou%u@*EMDhPt0SFhp6sIU8FDA(xxwJmWJfVQA0p#VOuN;t{C%eUm_(;U}U2F^Yv;8mZ8xch4FtvhY;4ac(a{ zdj!kD3TlDKhv#yCc{YbE$z>uBV0VzH;*NQ zP(P!IioJMg1IlE6*UI{U#U7cNoiG3un|vmTJ%1}rCC>f*WzcX;RlWSj>dALa8_;69 zJs{A4Eq_6PStNT<2TcRH)>|NwQ0YJ{i4?-u1hu)oBB05`BuS{ch;T#tBH3@79U!|6 zi#w3tbi@(jlC-7{q-C;9d&Vi76TU(8t5Y7G15y(3N_2V|9;qH1%_{!2!S%faToSMP z1!nKcMSo5j0q23F98tr01i=1QK`u#!#i89wD;E78F+gc5{sxQfN;8x=jc+t9+U3H6C%`Qm_E1gYo1v%H4zJK5 zyBDKrD6+AU4!M~J?DfV$8I$s@T+zU zMAV-vFONzW%y$`K%3?kN|7yR6K=tBU-Az{p)2D^Z=cXN$>&TX#X@WIQ*A)Gmmbn=zKbSV--^x&#!=pv?K;S zJo&!(;k(&poh9hjoey(?WF*Pe7U355E2A+06IU;zu|NouW@f%E-a(^Rk7Um)hwv0n zlDw+Hq8#DAO#W|o1GI?U*8KUx5> zlhaC{hYO3f_6Q9QRak-3n$2G;9ILlgX6)TR85^SP$>$0Ew5^iL4z6U&Z|QPbNUR7KjNUGK6zVsF{SNUZqf zUa6>-f4veJWy@dIEZWJCX#J5l#JLl))tWiILF%z84wo@4A6rtfICVpNu^+AUZs;L- z6#fxs?ve1e{0`MaIm2aLryu@SH5$p^Zl+aUh;V)5YWl!U*VESn*61w4FFq4k1%A0v z9oz}W@Nehdk+u|wuqbKXs%;K_Wc0t~Jq@^%6`&9H{F*L0CfUfxuP2z0{=3^ovHvN)I0O)e27?cpRwwzdn?!t>gsoA@Ydc zBbOj1Ms>J^VWva^EA8VlSNtTrm?ommJ_W(QBE-bOOrfhO#J5-ASX~rp-qWZh_`T!4 zE2D3p^F5FkyA?f*^g_;QcjxvBEF1Wum%WgEd>Z56tka$&RQkkXppW&fetWic;}uA) zF`Nzv%R|jy890BWX+__Nd?SIi=wHgjA4wuV==;Kdu$2~Z-84(B!z=WO+a+gGyQ$x% zU+fe(kUHKI<~^1fJsu4~+pWk<H9A~UT7x!qZ z$pYkNLhMO+HSFA69l8oT=v10gcjLS9Yk}ww!RsD(3HO^lgKo>UMU*)hXy@Czj28?* zErZ&RBjQL~qS#|&SQ|2d6~^5Ar`|F>vpmj+gywpU*DP?<$yUgt?{b;$zG@K8?Ok{q zp}PZ>3JXviSV3EwTTf!;pJUbqjy@~^YY2!BMx5%yfyEC5H}=uZ-_X`FRZ>}f5l@tS z#j*tp=l_W6R^RRj?M?4gQmFYkW^&f7DInZ2!8~<`s7g zk_yFA_FI8oU>{EHY@O4Z^TMUJad~pKLv;yN+eU=J0d0fQ(C?UGXO{h9#dsqx)^s;~ zL@7_}CK#4UyHPpd{SB6FmUuMuLnKSp=#T;K%!e9qgk^Qv*1&JVho|` zW;`TY0vU`$l&7G*)tjkGp!?45SCVhO4y~=u5jt6KSgnmD0PY%?o9}PzHr-yytmP92 zJbmT_`GsY(8_PSA3?*_@3K_xFS1&tUaHYk9Dg- zvafeLCTy80#qAxDrTdffh~Kzvx}#_+A46U2>5}M+^zh`NEPLPgSGC8h>K`PEGk;2| zNoODNfj`X7)E^JEW9*Af*?6Ce%Z)1r+{Jvwq7ZK9;JAorN~W6PBZ9sfl{H1J8}LF- zaFdRgSfH|eVq?#0(TPjE`51e3KIPc3=kIDLrwsjq(we>Jg_zK%dmJ|L#OE13Ac5r2 z(T{BiKwy_ZI@|-o1_m7Hq=SkKFzPaENC^l^5TIy@<$BDvaR=`{dIA)SH`nb}#BvC;+^%2u77 z$oDuebK{2Ygw?l8CQbyUQk>3yuE*L*+J^ggfgv|m7Obp+*1So>1JriuY^1h3<1ir? z0KAZhgcUb@7L6of$+e)BYO3pa4u5D{Rvp}Zks=H716`Lv=c{8D6HTWfdF98~1=}|+l5>_Knk=2GQWe~?yPu9TtDR3Q1a38qGW%P(VPCcd#hK`5 z{n3C>?yPfOI@)2&ABkSz`FC(GJFTpFoXP9{;W&BKr@RPP#;e*ysASW#4gdxZEU}E9 z6i8{C(gaB~Mk{16sjGw`ADX`w+-T6DKV`8y9Mx>xDaviC3VpmW@G$y4$3j<`@FzeL z0;W(_IX>*-`{@4Fismai>c-Gd!bL2T!$_IbOgu6+f@W;uPQ!wqC2+*n zF@C~*=(h!3#U8-o>T%+$`S&woc)n!$$$m|&NmYhKxMXiBSF#yuw%LTce8!!T2*joOz{_(2Kol_&;LiDd zx!z&ix3v~St!?x`ixo+)Kud4x>JPVn#|NVL(pK*uY8f3%#*gcdUxeVmHuWS@hbNMA z(63KHV5w$7#6#5AUyysYR32Ky99kS;+g#R-_kDAz!JHb?^gWj!tdzWM)~P=J^i{6P zpc?_K47U;SWC&}6H^4&?ZkaAl@o(<6u}|Hoz2wXjnxilF(i__qZjO%YdTcphOfK*$ z!X!5;snNrIypV`D!xGSwwfni=(q4kC_v5g}YgKH`MreD#J% zaVMW=EYtXb&u7SrDp+Y27XQ_XtB%|hPoINktI|fh!Qw;u98~sF+hm&DAKEUOmF}&y z34vZqUOU`m+5P6t~x?ilC3BGT%yZDx6 z-o|jBvh!7*-M%KC=L96a9N&vQryP~ykc4Bfdj2L$$p`h^+=BfW=F1Y{99@8fHuBm!-EsUdlM z3xzy9d3+C-H6e4~oIad;?IP{$H^%VmJEZ;jZ74QNt8|Y7w?_ zS`aMTJC5vQDrkkI?0DhDaJE?$!aS_Y(P$w^;x2o~kfW-W&7DVKFsI(gxuqE_pIkyV z0F?uxpTlQ{5zlj0STqI2revC|R!(*F=a{QA&hVGP;{erna8x+kOF!uP&bpC-E6=Z- z!-k(h50`D%vWfkJ9SL@%fa6X6PUW?oRgEo;!}0A2B@6|Cm?05^OQJ^htz{>q8jIpVh5vk9l=eU(IwA%5}Jyf3Paax<^! z&w~tx`$IQrYaw1~lXj%5;k51;%9-K5-niC?+nnOI=hMTul?PY`FVQE}D@k&#=8!l6 zHarN-uzf2fxUPe%N?j;pDyM9-Z6etImT#nVK$_PiE8EsiP<`sxWpT8rvg(cPnNoos z#su2)L2snmiLwahHK>x?2pa)eQY%bxv%KIgdS#}mn=h{re8x4iRP1}F7yB_ato>VXxMKBWfHK9}T2Jh8FWlCuz=`7+68BDmKdJ(C(%$D5!d^PAI-csVcI z+JzlWaf!YrQvRmJszEl@U}HH;;xU36?xiUC#laB%ZhaMNqc!&}6w{~Z4umSL`$Bc4 zK7J81&i4=5Z=F5w5a$JN|3%S`lpWZ2^XuG@!S8V0gd19)K&$4IG_NAhdwLLr;#7R(J|j+)wdk1Y;|S&%|AVaY>e8g! zC+3iu_B%8ItLW036)B?Zk}*9v0IlT^sxgxs>v0mk#}0CcVq|KH-m&QFr4R6J&lie3 zw#mqDe7lWCNaIHWcEivd6j7Q=5}=txgj!M5Axkjf0rl6Q$Fbz3e& z1mUvnNRm|fN!X!PIkki+l5C0ovvcH)H5nuXq+(mYH?i-f zP=PB=B^;4PvLT#=4mGNbol(O4dRn272XR+;$zwr3t3QxQ&aHM@@N&7MAQmZz^)rYWR zyq>v$q$+z}$`2Re{J49wF13k}ku8QvUFfh$eS`9Jg?rww=2>Ixt3ccGni@@&gA%H> zhT8d3^ArCo8CzQcIl2rW3FNNBlQMLY+KaG+Rd34))`3hH<>1e?-Z^OyzX$yNyUNn` zA7z$6>mHoyPqSsJ^aA7bkoXma(?p8{u(NJeCXDqCI#|{HL-j2<=h;8d!HvH;U4hns z*c!ltlK_{`_ylnda<)>2b|@>p#YI%oUd&onJbH@H_NMSqDJin|u*0i(L$$BNgA&H< zg4^c+{e((+LU^eyQ)* zGJn~cr}Os%Fj6^G*Mg>KURj;Y!9&X=Bs~G3#RO8v299nEJEdyhV;f zj|S_Wd|K6Qk7q)&jv?Q?Og?;F0sRNM#4d+5+Yh0I{%2+z-KmUJ=< z{ETP)Sq{y;+zE@W_HR{2b-YMFUY22>KAo>8s?(^oEjX0KVpRq~jxnZO^gF3LOk-nC z`5<$FHtdn?UMCGe<}5Zbk`<2Y(|+Apc(;c%b^CK9M$$EMlrBfN53viHu7)o2Gr(i1 zR!9+6t5dgvk=3TLvK9tCF}_62h*7?ZCgBK6JMANp9%eDV-JR8ARIV<7ZQ9TDDshQ( zAx-B^^Q}zgsdm2|x@DZ}88QL%N?v>kZziTFnk+d~Dv^;Yn33o@ioM=D;W3Qssxe#Z z>S0bua_thJQgt!$GMxvKy)BZ8m)Y;2@P8tGHvopQ0cf?>(y$qH`sb>)A%G5Ray zba|$~fnJbcd~~Fw*qDHLvL^cMN9W6@T{ATe}oi4Ygd6P(B_zIcvEJy*gKJHm^!0ijCGeRlzswr9bA+ zDS9BUxbkrKdJ{<}*>!Wi#l0i8J{dY!%BM(*2NZXgc4}FBd;;{jALhzY^8J2{9tR3E z9B!NPOeLADAvmnd9K&GDCVw#3uDE!Q{MQ9Jb&%!@j4GgIjK&OeyS!1ZWxvWSoQ70#RsTi6v34sPgg<+(iLOo&1B5rUG&X&4^K56R(#Xd2k#EfUYJH6&Y1( zl=_iivqw%9aLwn~+OibB1Xs`KnRwQv%S8PEV%K`o341)BQT3-Ife1eI#moF5XqFU< zPJb0JYEyhCkz+X>^)Wx=@=V@5O?Z^NAvSu@3xLIl7AK2L1iKFLmL4?&+y-c^L8q)^ zWIXg21`N>n6%48zB?}bOv=&FuWs&L>QnPX{8EG@ma*w|qMIjerS`g}g;WNzim7{oG zSIFvl^}_#nnE2N{;xbQ)l(+_ZFR+Sj)JWzVQBDjR-F9{u6f7~%axOHv8)PFoi*1;# zw~mAVEMjdmA#vVZ<=ojff4qACqddGmR9=3ezUWS^_-iX2l-k-c-KwtX;3KM(NA2eK z)rY(l?tE5W6yzUV^NEHjs$0!R z+U%ug72r{3J?=xSWG7OEa8 zqo)&No|e)ADjASp7iFyN678^OiTu`@UKU=evek7z`1Gz|7OMqguRGaPd#_AZxd6snZc& z)5P;X<~_5NE2yYo@JV)QjaNb~Y6msigS;3rFT0CyFQ^OnOE@eZ0r%^on&s8=D+KYp zxnhRvJh#%V2(H@x>w)qpdlr*k1#DElj0$Pi*tFF?5}5u*ZkKQ>5zC52ndQ*Wo+TLk zs>m&cP>9+Jj(D@MpI!WW7;EEr{A)qt(CE;}5KGb(X1<|v&suW`V|6usH@-T>={hCe zwmfgY-5}+Rf@b_ejc#naKj(Sdpx2^QYhlaLoeGzYThX<>O~M1ZkDn)sS%O{meh2;P zfjn|l6|TSz zGWutJk7%A;yswko^Y2UH?VBF<*=>PDYjzB;pW1X6e=gSiqKFmDm@Cjj z$yAUi?8n~={c;m4+vQ~5EL#%h=zY`xv>Nk!@W1?*0Sy=O>U()~^YtKRq4DftXauiWXWJyvWkY;92H}lT|3mj0HF*MU^|i#-}to z>yiG1LDF!j&G!ASr>|{kH(Z49mE9VGwVvz9Ct{VWyHqJ1;gna>J(usqYvg(`)D3Q0 zX&opUS0Q1VDc(Q)V7h#En?CVpEO%O^9bB zX1Sa~6n6u6J(gE~sO%sdJ#c4OTxIOS9+`LA*1*Z*GW2Thrlv?r-z}gXgv_VHm7K(% zEn2JDd8!wBn7EYz%EQAfTZnx7iO*g-7ww}U*Tli0XqGji*U>;TQ@imBs ziXp}Dc>C$i%+wvqYKVSdfv#Q-Uy6`vlkMK+m-cZ+5Z_662@0#}^^+!~i;JCTGgn9o zk;CqN%pmP=r$jWI#JieyVU)MEby28I{`GCn;1(49*L6fqykdckPtMs+%`~W1wAHBe z0#La1;U!mJ*VCg{;8c&#S0MB+N?k~cO^&X;x0cR6_zVn)mFc2kS{CH1N<`Vzvq1(C zTJRwI3WpxWZ>_|Q7n{_k=zsYpsyFwCy5_0CiQXvs-(tDdZo^t*YXr{@-06(o%5t5{ zgoIGg1i3~=zCMU-X5%G#6%^A5z>QM~X8eF2;u|B0=d*m!7OYGB(N|VCc-Q4BCS^Rv-Fuej9O|w5*Cj_8mz>ISZkAB<>Sy zYA!u8Mxs&S5;(>Avw(t5=IPyj$_LpI+9165;MYsiX<8VMI^7;$*9(gT8P#Vhf4xK_Wm#iPJEZ3m^!@ud> z;Y*!;ccSDszT7?|ry{?63`#~XJAju=;w<>S;v|0;8XtrwK28SQ89>tf_g(-=88Z{P z9dS)%fGQ1sB`;=;$#?f-|GO+;GxFpA zlu41pZcW8kLt za37)5Sd7;Hl{n~xx%k_hpbN0$fJCEMgCGO~=vG4ruuPSZ4EA=S76${Vu4p`GoO^_s zM?Fb9eAJ@dV-kOn+;-ehH(|=Y#DIT_B1t(k2q1p~-VMl#{=an9z;z!W9W(;4IaCuYl!D^6>@hUs)C}=m@0y z0!IX4KAN?VsQ1}96hi#*#lJetN5nwapf>AhJJfI8qo!N<8+#vIc2UGRiy)+cd}OMFrFdglf?OrzTRB=GtG~{@_yJ!B z4bAy`xr6CCa2JE@H>_;2AUsk4=Mk*LF2Bar@kp}`vC3J@FjPF|qg*(gGxjmPHzGe-%& zAJ;)&%gcTbW6*3W#u}O<_@kFNTnFuyGXWd2JkVnbGZTBPH5(>7Y$WOWRr~M`GH<2- zUk}&ePxb$Q374{4_NMl=_v8Iq&w0*y{vhR|{Ulgzce6J`KerzBD_2TyI_Ygq!L2fXATTF8P-tWa z4(P7qf>iJOFyWpx;X=Zv4lPe-$In2uxaf|Y5k-)nVCP?s3v>h05;&|Lh6{{X3UEzs z9<&=WJX|G|lswNQf%)f_ZUjhFvQ+YhZNAF4HN3hB$#~6LkW``P=ePYoo0b7b?HPvti1JT0Mjf(6-st1 zsW*=ATN&I&?qfi!!}kBPCb7&l-7b1ltAh?B5^>&f+@xC?X&sq%c8f09e}hwieAnw} zX@Bd+6S~0#!@09hyA7DydOq2-?wX;M*=u$4Z;Q@npU~PzOWgVU!HxaTl;acGc>aq# z&r%qRBXRj&#^_JbVaXK;vkVH*|K$P@C(n(TzHB6ri~N;xI)sMw4y?SB_m>DjeCm74 z*a|eG76Ti&@iElo(2b}|H>_?d5=_|=?wN5uc>rGOuk0qm8HvpX>p#9BtsdMBq)ZtB zhfoiMmpBDmd7KlJ-#ZY#`@|h34U4@x?6h}S=e0l#mzu4PT$`=z| zYlj-5*30;$Q|Sh^jJKJi`z-ZR{soOjc~yvT^zp-*8ajMnvnH~=XHC(4XnmsM`tNxMxhBk9OzX5h$ zeQ;tJB;}jiz(3sw%K?`MlyGEEzreYN1dyl>jS27;iom(DnEX5)W)wa>yC;65f4TJM zR*;H;&#Ha8mrr8DeBMnFMs<8czPlK^bHQSE+)JargBG#xDbAv8UdHQgc(BG}tFY^5 zMU%p~Jq4VC&vtn-PA{_2-KohVTkv|*#BnBaudjU&$Hswr+C~B!$nJPn6{mamNRQ15 z$FJN=kp*JVOW^imYof!%Pq>(IePZHe_sP&(q~Z_IPh!qDu1*S$Es&1BNU!p?+-r?ww_-RSQdM}Vkv|1`;PG(y)j<4_9XWJEN9dDu40&ed05uY^bm{ocsN%`R(TGdwLS>sUQ!@p!1G)tx zt^V)}2OLM;4b;tT@TZ8v+3;sUbVZjs=QTKIkN+fsFQe0s$FR@?-6vlVt>@%in=4m# zr%%&2<=l6NvDE&0fX^+%! znrIGNkGf>OBam;G{uJ_LyVkcLjrk~{`J`MXbj~Gv)8g*pIXSmLTOE4-?TK_U)YP13 z%(qX`weJ=*CJgSd1hX>YELl(ToGqF;=j^ijF;|BO`PWcdz99V3vULh;R_X70w7gF; zX^V1bWOI5@_{LYa1og&hIQU3^?S12Bs(;?K37T$WI=kI+;K2E1z;18HXy622v@DNG z+OpCL-XndN^p59y;(VUuY>G2BcSI#)K4Unjs7n=WuC-3N*z+_5yHqOF_VAF?N@}xt zNUpo?L{QH`7Zu1nW5KmjcSaXr^gR4Rv!_7_e$L0;OWLeUC9TmjP%n8*f@}+r@78Cc zF{?D}Xy+d4bb}2^YJgHrI!XuE44<2zYiL|S+K4S|d>BBwHQ?FQ>K#I)tjw8_P{l=o zU>gWB2PnF~>kx&cv5Z=vk@=_sQ$M?=PZUgaG$DS^ITzgO~*HrDp=(_NZN zhY9SjPl`|uZ>fG6Dpf#>*Oy7*oU!J48<&vn`TkWy$5plrb_7C>o1=^H^RvDQNdG(VvigT<(lIP#Z2$e&S}BwMYWmIxynzEmJIg(o$aNw6Q6rp6I57R? z+RS}#^x*}_p`>r4%%Gv4qEGw%*@k;1$C{mb+)JU-UWWy*J*P2Rl-J8$n18-vP=h=( zklZMRO86AuZYW{I9(MP6P%qrkJ>r0@N6_|{VN@`ZPIoJlzss>=AX;!(}GQK)fXtkRou_hKY)5G1F>{c`>9Bg+tXU#&3Jd= zSM7ttr))pE<3Hf$OnBylKGbCVrMwo;poU>*4cPnQYn7^LzB|nSqQOKhk~|0qHeirH z!ud@7d4{iQW!;=zTztwrrjxk^PEUCf!6=v70~rC2=vR!Q+Q`5K?&_4yCkx%wcGl2$ zrkQu7PL#7W%$kM+AK{@hO-|LxL+w)M=eW=FIJp~bH6h+A>%9dht(GhGkzPYzX^lf8 zoymx>SgXkj?v^;Iug4!Ce_5!-9k*B5i`z&QtkWv;6gfE7c6cj~xx8!5z{|e1`r4e! zI?a#19CjV_k@Wrl*u+P@vsjT_iXwJ__VD4_enf6-65j%+<1K;H0@D+?(tNsU2L|6P z%2i5ThTte9aORPV$;!HC@6l?9GvOyP43xNJGW455dxQb`-*BJ(_|8{uy*Kmq^&F%l zE^kGPJEqQq5cxp}_HQCRfHUhsZ!HF2bf?85w#b}a5<1$UK{+gLiA?=q4jLs%XYriu z3(ytFVV2xl2Y|s&+vV33kD2O8$+GLkvC9mBBHzj=awVr}(g{zq6c*m!H<3D6>|W+9PNl@8YwH5nO>I z**CCCO9(3al3@qzU}%{b8~aNbo9;OXbZZVjTgbr4^PPO(V<&tpyG#}`#XDQ{M zr2_W0EUc7UJwad3>XTU5=QS#natalkdB};T{*kGCnIio9FZs$svgK0?^)V5;6Re<=GMUXKJ~@bE4#)i zD<~+zs$|lEuaR5cidi2$n$Dn>N$0S&{$)}oM|+?k`H`Omj<1uNC#b@iqfn$bJhgt; z-)0E7<%_d{eJ4@a4_6M^_j@)BJGOr#uaMQd(vX+;jCosx^Y>?9Ru2G$obUr8?+Iv( zwyGbQqr$rD zc(r_Oc2N>(xlR*HLjNB&Nn@5l6GAng+0^TYHAERCLDC6y=Ct2DC!#%@v|qNFkl-&> zQTKYi^Av~d=9McC()=`T?pf>lDiqPiNy7#YE2X2+F4{Bqc2sOq1))-w30N$>by{Zj zRTl$Cv?^J}x@|TsEEdzO2$ueW@I;)-*Me>&a@&tQ^5?m94=Ufvr<_K6z~_rW1M`eB znaakI6LiEdBt%&w=La*a)tihYn29)v{qU=uT*ZYrDah!EeF#NHa|eq+NX|-S*%!WY z7~Lf^U*U{>ghL70%}@M(J!w<-J6e_;oL7z0GyT5c7~uIp1@=uH_hm|Mc0~N8pxCn{ z-Px5l@*qaQn6TJ+rpu7I`@SSsNS+!{4}au|Jel@`R4M3W3fZU%&hCeykyh6TA25&= zuFC9Cp<##NrjXwiyR|M#M)=;@DV{{oeCJw$V2( z{Z#X1Hhekg@4Zi^R6I+l;>eYFA49nqv^_I2w|-7ue(KGjX)>n4g(^h%vAx{Xmg~yp z!s)97Wr1=N!H-UBn|aB+DuwxX4&~UAGkpW#%rN}U4w29rW{@=yGh+wS_MhrNB#+hrOV)E$dVcPZj%(7gP zE&vHuy51ZLGm^U@$e|(%?#;x~$j|o~Q~%l5YhF56Me#MMxNgwVGTP~HN8mXII~mqJ-LUWUKH64c7(+0Xa?$o`a8FWMZq5& zh{-^f6E>DL=9H#^(jM|w>~_Q-nkd@FNvO>APq*(rA8wn5IX^m}mpD+AyF_v28PhvGe10DHx z8MTm#%@Mf=+_6Dis^R^QZB?jvK1Pb>5+vb{R&(`%G)z6WH5}sygLN$}bw`k2&N$JP z(y4OGX`gEZCNH84FvKK$KshP$d-kUgy~h?38kde&J9Rqn-spL?f0C@S=5Z2}^__V`5Dy*9YgAy12gsuJHx-+6Hq@ z_46kig5R3u{c?3h_?hqr!zJ>S1}s{L)$H`e&pSk#+<=Ib0^Em>rpB@dJk}^?!2gpU z6(^^6{$|AEPCx==xv2lkkd|>TjHVopv)!BbbY94V=qKVN<~kG+B9d}FO`m{e%HoCyW@(!ek8pLP5(mgIH^ND zHqPcOS~lJ!Ld@MQQ$2geQ1@W<^_t$qo?Q-~+ilU|-1sO{Q zZj*yGfG+z2jm+)r96sGV>$u+rvw}+9uLJf}ZZMfery_hP^SR%yMZA+Yh$%tJFGsBf z-wKYh?k_Zw4-FgXiUFC86OIS*tf}2*375Mr_GZ-C)P>&wJ$DK!v4_Y7?p(SbGj%5BPI+ zF5Jj)b@u88#wzT-GMf*7Y)FBFX79B Date: Sun, 12 Nov 2023 14:47:49 +0100 Subject: [PATCH 04/20] :bug: fix for spartials and checks #80 --- R/check.R | 14 +++- R/engine_breg.R | 13 ++- R/engine_gdb.R | 2 +- R/engine_inlabru.R | 15 +++- R/engine_stan.R | 19 ++--- tests/testthat/test_trainOtherEngines.R | 103 +++++++++++++++++++++++- 6 files changed, 141 insertions(+), 25 deletions(-) diff --git a/R/check.R b/R/check.R index bdc7110b..6adf89dd 100644 --- a/R/check.R +++ b/R/check.R @@ -115,18 +115,28 @@ methods::setMethod( ms$Warnings <- append(ms$Warnings, "No coefficients in the model!") } + # Check if some coefficients are clear outliers + if(nrow(obj$get_coefficients())>0){ + co <- obj$get_coefficients() + # Remove large outlier from coefficient and check if that results in NA (outlier) + co <- rm_outlier_revjack(co[[2]], procedure = "missing") + if(anyNA(co)){ + ms$Warnings <- append(ms$Warnings, "Likely unstable coefficient in model (outlier)!") + } + } + # Check if threshold exists, if so if it is equal to maximum if(!is.Waiver(obj$get_thresholdvalue())){ # Get prediction pred <- obj$get_data() - if(obj$get_thresholdvalue() >= terra::global(pred,"max",na.rm=TRUE)[,1]){ + if(obj$get_thresholdvalue() >= terra::global(pred[[1]],"max",na.rm=TRUE)[,1]){ ms$Warnings <- append(ms$Warnings, "Threshold larger than prediction!") } } # Check for positive outliers in Prediction if(!is.Waiver( obj$get_data() )){ - pred <- obj$get_data() + pred <- obj$get_data()[['mean']] # Calculate outliers using the mad pmed <- terra::global(pred, median, na.rm = TRUE)[,1] abs_dev <- abs(pred[]-pmed)[,1] diff --git a/R/engine_breg.R b/R/engine_breg.R index 2740c574..e7d84ab6 100644 --- a/R/engine_breg.R +++ b/R/engine_breg.R @@ -632,7 +632,8 @@ engine_breg <- function(x, return(pred_part) }, # Spatial partial dependence plot - spartial = function(self, x.var, constant = NULL, newdata = NULL, plot = TRUE, type = NULL){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, + plot = TRUE, type = NULL){ assertthat::assert_that(is.character(x.var) || is.null(x.var), "model" %in% names(self), is.null(constant) || is.numeric(constant), @@ -670,8 +671,6 @@ engine_breg <- function(x, # Make spatial container for prediction template <- model_to_background(model) - # Assign a cellid to df to match the file later - # df$cellid <- # Add all others as constant if(is.null(constant)){ @@ -709,14 +708,14 @@ engine_breg <- function(x, pred_part$cv <- pred_part$sd / pred_part$mean # Now create spatial prediction - prediction <- fill_rasters(pred_part, template) + template <- fill_rasters(pred_part, template) # Do plot and return result if(plot){ - terra::plot(prediction, col = ibis_colours$ohsu_palette, - main = paste0("Spartial effect of ", x.var,collapse = ",")) + terra::plot(template, col = ibis_colours$ohsu_palette, + main = paste0("Spartial effect of ", x.var, collapse = ",")) } - return(prediction) + return(template) }, # Get coefficients from breg get_coefficients = function(self){ diff --git a/R/engine_gdb.R b/R/engine_gdb.R index fd5b502a..ca64336f 100644 --- a/R/engine_gdb.R +++ b/R/engine_gdb.R @@ -495,7 +495,7 @@ engine_gdb <- function(x, for(entry in names(params)) settings$set(entry, params[[entry]]) for(entry in names(bc)) settings$set(entry, bc[[entry]]) - # Create output + # Definition of GDB Model object ---- out <- bdproto( "GDB-Model", DistributionModel, diff --git a/R/engine_inlabru.R b/R/engine_inlabru.R index 477cbecf..bf753609 100644 --- a/R/engine_inlabru.R +++ b/R/engine_inlabru.R @@ -931,6 +931,8 @@ engine_inlabru <- function(x, # Compute end of computation time settings$set('end.time', Sys.time()) + # Save the parameters in settings + for(entry in names(params)) settings$set(entry, params[[entry]]) # Definition of INLA Model object ---- out <- bdproto( @@ -1138,7 +1140,8 @@ engine_inlabru <- function(x, return(o |> as.data.frame() ) }, # (S)partial effect - spartial = function(self, x.var, constant = NULL, plot = TRUE, type = "response"){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, + plot = TRUE, type = NULL){ # We use inlabru's functionalities to sample from the posterior # a given variable. A prediction is made over a generated fitted data.frame # Check that provided model exists and variable exist in model @@ -1147,8 +1150,16 @@ engine_inlabru <- function(x, assertthat::assert_that(inherits(mod,'bru'), 'model' %in% names(self), is.character(x.var), - is.null(constant) || is.numeric(constant) + is.null(constant) || is.numeric(constant), + is.null(newdata) || is.data.frame(newdata), + is.null(type) || is.character(type) ) + # Settings + settings <- self$settings + # Set type + if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) # Match variable name x.var <- match.arg(x.var, mod$names.fixed, several.ok = FALSE) diff --git a/R/engine_stan.R b/R/engine_stan.R index d7dbfe1a..1e44dfd2 100644 --- a/R/engine_stan.R +++ b/R/engine_stan.R @@ -773,7 +773,8 @@ engine_stan <- function(x, return(pred_part) # Return the partial data }, # Spatial partial effect plots - spartial = function(self, x.var, constant = NULL, plot = TRUE,type = "predictor", ...){ + spartial = function(self, x.var, constant = NULL, newdata = NULL, + plot = TRUE,type = "predictor", ...){ # Get model object and check that everything is in order mod <- self$get_data('fit_best') model <- self$model @@ -830,22 +831,16 @@ engine_stan <- function(x, mode = type # Linear predictor ) - prediction <- try({ - emptyraster( self$get_data('prediction') )},silent = TRUE) # Background - if(inherits(prediction, "try-error")){ - prediction <- terra::rast(model$predictors[,c("x", "y")], - crs = terra::crs(model$background), - type = "xyz") |> - emptyraster() - } - prediction <- fill_rasters(pred_part, prediction) + # Get container + template <- model_to_background(model) + template <- fill_rasters(pred_part, template) # Do plot and return result if(plot){ - terra::plot(prediction[[c("mean","sd")]], + terra::plot(template[[c("mean","sd")]], col = ibis_colours$ohsu_palette) } - return(prediction) + return(template) }, # Model convergence check has_converged = function(self){ diff --git a/tests/testthat/test_trainOtherEngines.R b/tests/testthat/test_trainOtherEngines.R index b4b49cc6..a7bfb9ed 100644 --- a/tests/testthat/test_trainOtherEngines.R +++ b/tests/testthat/test_trainOtherEngines.R @@ -1,4 +1,4 @@ -# Train a full distribution model with INLA +# Train a full distribution model with XGBoost test_that('Train a distribution model with XGboost', { skip_if_not_installed('xgboost') @@ -35,6 +35,9 @@ test_that('Train a distribution model with XGboost', { varsel = "none", verbose = FALSE) ) + # Run a check (should work without errors at least) + expect_no_error( suppressMessages( check(mod) ) ) + # Make a check expect_no_error( check(mod) ) @@ -122,6 +125,10 @@ test_that('Train a distribution model with Breg', { varsel = "none", verbose = FALSE) ) + # Run a check (should work without errors at least) + expect_no_warning( suppressMessages( check(x) ) ) + expect_no_warning( suppressMessages( check(mod) ) ) + # Expect summary expect_s3_class(summary(mod), "data.frame") expect_s3_class(mod$show_duration(), "difftime") @@ -197,6 +204,9 @@ test_that('Train a distribution model with GDB', { varsel = "none", verbose = FALSE) ) + # Run a check (should work without errors at least) + expect_no_error( suppressMessages( check(mod) ) ) + # Expect summary expect_s3_class(summary(mod), "data.frame") expect_s3_class(mod$show_duration(), "difftime") @@ -284,6 +294,9 @@ test_that('Train a distribution model with glmnet', { varsel = "none", verbose = FALSE) ) + # Run a check (should work without errors at least) + expect_no_error( suppressMessages( check(mod) ) ) + # Expect summary expect_s3_class(summary(mod), "data.frame") expect_s3_class(mod$show_duration(), "difftime") @@ -391,6 +404,9 @@ test_that('Train a distribution model with bart', { varsel = "none", verbose = FALSE) ) + # Run a check (should work without errors at least) + expect_no_error( suppressMessages( check(mod) ) ) + # Expect summary expect_s3_class(summary(mod), "data.frame") expect_s3_class(mod$show_duration(), "difftime") @@ -418,4 +434,89 @@ test_that('Train a distribution model with bart', { }) +# ---- # +# Train a full distribution model with inlabru +test_that('Train a distribution model with INLABRU', { + + skip_if_not_installed('inlabru') + skip_if_not_installed('INLA') + skip_on_travis() + skip_on_cran() + + suppressWarnings( requireNamespace('inlabru', quietly = TRUE) ) + + # 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) + virtual_range <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'range',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)) + + # Now set them one up step by step + x <- distribution(background) |> + add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', name = 'Virtual points') |> + add_predictors(predictors, transform = 'none',derivates = 'none') |> + engine_inlabru() + + # Train the model + suppressWarnings( + mod <- train(x, "test", inference_only = FALSE, only_linear = TRUE, + verbose = FALSE) + ) + + # Run a check (should work without errors at least) + expect_no_error( suppressMessages( check(mod) ) ) + + # Expect summary + expect_s3_class(summary(mod), "data.frame") + expect_s3_class(mod$show_duration(), "difftime") + expect_equal(length(mod$show_rasters()), 1) # Now predictions found + expect_s3_class(mod$settings, "Settings") + + # --- # + # Some checks + expect_true("get_data" %in% names(mod)) + expect_true("plot" %in% names(mod)) + expect_true("summary" %in% names(mod)) + + # Test some basic non-sense calculations + tr <- threshold(mod) + expect_type(tr$get_thresholdvalue(), "double") + + # Can we get a centroid from both objects + expect_s3_class(mod$get_centroid(), "sf") + expect_s3_class(tr$get_centroid(), "sf") + + # Nor conventional partials work + expect_no_error(ex <- partial(mod, x.var = "CLC3_312_mean_50km")) + expect_s3_class(ex, 'data.frame') + + # Do spartials work + expect_no_error(ex <- spartial(mod, x.var = "CLC3_312_mean_50km")) + + ex <- ensemble(mod, mod) + expect_s4_class(ex, "SpatRaster") + + # Do ensemble partials work? + expect_no_error(ex <- ensemble_partial(mod,mod, x.var = "CLC3_312_mean_50km")) + expect_s3_class(ex, 'data.frame') + + # Do ensemble spartials work + expect_no_error(ex <- ensemble_spartial(mod,mod, x.var = "CLC3_312_mean_50km")) + expect_true(is.Raster(ex)) + + # Get layer + expect_s4_class(mod |> get_data(), "SpatRaster") + + # Expect data.frame + expect_s3_class(mod$get_coefficients(), 'data.frame') + + # Expect formula + expect_s3_class(mod$get_equation(), 'formula') +}) + # TODO: Engine stan to be tested From fee31392a34650949c75e334cdd9a26cf7ade955 Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Mon, 13 Nov 2023 09:49:49 +0100 Subject: [PATCH 05/20] Improvements thin_observations --- DESCRIPTION | 4 +- NEWS.md | 3 +- R/utils-spatial.R | 77 +++++++++++-------- man/thin_observations.Rd | 38 ++++----- tests/testthat/test_functions.R | 2 +- .../articles/01_data_preparationhelpers.Rmd | 4 +- 6 files changed, 71 insertions(+), 57 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 39b0b740..63cb54f5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -72,9 +72,7 @@ Suggests: geosphere, cubelyr, testthat (>= 3.0.0), - xgboost, - spatstat.geom, - spatstat.explore + xgboost URL: https://iiasa.github.io/ibis.iSDM/ BugReports: https://github.com/iiasa/ibis.iSDM/issues RoxygenNote: 7.2.3 diff --git a/NEWS.md b/NEWS.md index 9db566ad..55f2a9d4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,8 @@ # ibis.iSDM 0.1.1 (current dev branch) #### Minor improvements and bug fixes -* Several bug fixes in `thin_observations` and `global` argument for bias-method. +* Several bug fixes and improvements in `thin_observations` +* `global`, `probs`, and `centers` argument for better control of `thin_observations` * Harmonization of parameters for `spartial()` and addressing #80 # ibis.iSDM 0.1.0 diff --git a/R/utils-spatial.R b/R/utils-spatial.R index 60fc6f5d..8639c674 100644 --- a/R/utils-spatial.R +++ b/R/utils-spatial.R @@ -1255,8 +1255,8 @@ explode_factorized_raster <- function(ras, name = NULL){ #' model-based control can alleviate some of the effects of sampling bias, it #' can often be desirable to account for some sampling biases through spatial #' thinning (Aiello‐Lammens et al. 2015). This is an approach based on the -#' assumption that oversampled grid cells contribute little more than bias, -#' rather than strengthing any environmental responses. This function provides +#' assumption that over-sampled grid cells contribute little more than bias, +#' rather than strengthening any environmental responses. This function provides #' some methods to apply spatial thinning approaches. Note that this #' effectively removes data prior to any estimation and its use should be #' considered with care (see also Steen et al. 2021). @@ -1264,24 +1264,25 @@ explode_factorized_raster <- function(ras, name = NULL){ #' @details #' #' All methods only remove points from "over-sampled" grid cells/areas. These are -#' defined as all cells/area which either have more points than \code{minpoints} or -#' more points than the global minimum point count per cell (whichever is larger). +#' defined as all cells/areas which either have more points than \code{remainpoints} or +#' more points than the global minimum point count per cell/area (whichever is larger). #' #' Currently implemented thinning methods: #' #' * \code{"random"}: Samples at random across all over-sampled grid cells returning -#' at minimum \code{"minpoints"} . -#' Does not account for any spatial or environmental distance between observations. -#' * \code{"bias"}: This option removes explicitly points that are considered biased (parameter \code{"env"}) only. -#' Points are only thinned from grid cells which are above the bias quantile (larger values -#' equals greater bias). Thins the observations up to \code{"minpoints"}. -#' * \code{"zones"}: Assesses for each observation that it falls with a maximum of \code{"minpoints"} into -#' each occupied zone. Careful: If the zones are relatively wide this can -#' remove quite a few observations. +#' only \code{"remainpoints"} from over-sampled cells. Does not account for any +#' spatial or environmental distance between observations. +#' * \code{"bias"}: This option removes explicitly points that are considered biased only +#' (based on \code{"env"}). Points are only thinned from grid cells which are above the bias +#' quantile (larger values equals greater bias). Thins the observations returning +#' \code{"remainpoints"} from each over-sampled and biased cell. +#' * \code{"zones"}: Thins observations from each zone that is above the over-sampled +#' threshold and returns \code{"remainpoints"} for each zone. Careful: If the zones are +#' relatively wide this can remove quite a few observations. #' * \code{"environmental"}: This approach creates an observation-wide clustering (k-means) under the assumption #' that the full environmental niche has been comprehensively sampled and is -#' covered by the provided covariates \code{env}. We then obtain an number -#' equal to (\code{"minpoints"}) of observations for each cluster. +#' covered by the provided covariates \code{env}. For each over-sampled cluster, +#' we then obtain (\code{"remainpoints"}) by thinning points. #' * \code{"spatial"}: Calculates the spatial distance between all observations. Then points are removed #' iteratively until the minimum distance between points is crossed. The #' \code{"mindistance"} parameter has to be set for this function to work. @@ -1296,7 +1297,7 @@ explode_factorized_raster <- function(ras, name = NULL){ #' \code{NULL}). #' @param method A [`character`] of the method to be applied (Default: #' \code{"random"}). -#' @param minpoints A [`numeric`] giving the number of data points at minimum to +#' @param remainpoints A [`numeric`] giving the number of data points at minimum to #' remain (Default: \code{10}). #' @param mindistance A [`numeric`] for the minimum distance of neighbouring #' observations (Default: \code{NULL}). @@ -1304,8 +1305,9 @@ explode_factorized_raster <- function(ras, name = NULL){ #' chosen (Default: \code{NULL}). #' @param probs A [`numeric`] used as quantile threshold in \code{"bias"} method. #' (Default: \code{0.75}). -#' @param global A [`logical`] if during \code{"bias"} method global or local, extracted -#' bias values are used as threshold. (Default: \code{TRUE}). +#' @param global A [`logical`] if during \code{"bias"} method global (entire \code{env} raster) +#' or local (extracted at point locations) bias values are used as for quantile threshold. +#' (Default: \code{TRUE}). #' @param centers A [`numeric`] used as number of centers for \code{"environmental"} method. #' (Default: \code{NULL}). If not set, automatically set to three or nlayers - 1 (whatever #' is bigger). @@ -1325,7 +1327,7 @@ explode_factorized_raster <- function(ras, name = NULL){ #' * Steen, V. A., Tingley, M. W., Paton, P. W., & Elphick, C. S. (2021). Spatial thinning and class balancing: Key choices lead to variation in the performance of species distribution models with citizen science data. Methods in Ecology and Evolution, 12(2), 216-226. #' @keywords utils #' @export -thin_observations <- function(data, background, env = NULL, method = "random", minpoints = 10, mindistance = NULL, +thin_observations <- function(data, background, env = NULL, method = "random", remainpoints = 10, mindistance = NULL, zones = NULL, probs = 0.75, global = TRUE, centers = NULL, verbose = TRUE){ assertthat::assert_that( inherits(data, "sf"), @@ -1333,7 +1335,7 @@ thin_observations <- function(data, background, env = NULL, method = "random", m is.Raster(background), is.Raster(env) || is.null(env), is.character(method), - is.numeric(minpoints) && minpoints > 0, + is.numeric(remainpoints) && remainpoints > 0, is.null(mindistance) || is.numeric(mindistance), (is.Raster(zones) && is.factor(zones)) || is.null(zones), is.numeric(probs) && probs > 0 && probs < 1 && length(probs)==1, @@ -1354,18 +1356,18 @@ thin_observations <- function(data, background, env = NULL, method = "random", m coords <- sf::st_coordinates(data) ras <- terra::rasterize(coords, background, fun = sum) # Get the number of observations per grid cell - # Bounds for thinning - # MH: Would be nice if upper is either for cells (random, bias) or zones/cluster - totake <- c(lower = minpoints, upper = max(terra::global(ras, "min", na.rm = TRUE)[,1], minpoints)) + # Lower and upper bounds for thinning + totake <- c(lower = remainpoints, upper = max(terra::global(ras, "min", na.rm = TRUE)[,1], + remainpoints)) # -- # if(method == "random"){ + # For each unique grid cell id, get the minimum value up to a maximum of the # points by sampling at random from the occupied grid cells # extract cell id for each point - ex <- cbind(id = 1:nrow(coords), - terra::extract(ras, coords, cell = TRUE)) + ex <- cbind(id = 1:nrow(coords), terra::extract(ras, coords, cell = TRUE)) # remove NA points ex <- subset(ex, stats::complete.cases(ex)) @@ -1445,10 +1447,15 @@ thin_observations <- function(data, background, env = NULL, method = "random", m # remove NA points ex <- subset(ex, stats::complete.cases(ex)) + # count points per cluster + points_zone <- dplyr::group_by(ex, zone) |> + dplyr::summarise(sum = dplyr::n()) + # count points per zone - ex <- dplyr::left_join(x = ex, y = dplyr::group_by(ex, zone) |> - dplyr::summarise(sum = dplyr::n()), - by = "zone") + ex <- dplyr::left_join(x = ex, y = points_zone, by = "zone") + + # Upper bound for thinning + totake["upper"] <- max(min(points_zone$sum), remainpoints) # Points to return sel <- ex$id[which(ex$sum <= totake[["lower"]])] @@ -1507,9 +1514,14 @@ thin_observations <- function(data, background, env = NULL, method = "random", m ex <- subset(ex, stats::complete.cases(ex)) # count points per cluster - ex <- dplyr::left_join(x = ex, y = dplyr::group_by(ex, cluster) |> - dplyr::summarise(sum = dplyr::n()), - by = "cluster") + points_cluster <- dplyr::group_by(ex, cluster) |> + dplyr::summarise(sum = dplyr::n()) + + # count points per cluster + ex <- dplyr::left_join(x = ex, y = points_cluster, by = "cluster") + + # Upper bound for thinning + totake["upper"] <- max(min(points_cluster$sum), remainpoints) # Points to return sel <- ex$id[which(ex$sum <= totake[["lower"]])] @@ -1529,7 +1541,9 @@ thin_observations <- function(data, background, env = NULL, method = "random", m } else if(method == "spatial"){ # Spatial thinning stop("Not yet implemented!") + } + # else if (method == "intensity") { # check_package("spatstat.geom") # check_package("spatstat.explore") # @@ -1571,8 +1585,7 @@ thin_observations <- function(data, background, env = NULL, method = "random", m # # if(anyDuplicated(sel)) sel <- unique(sel) # suppressWarnings(try({rm(o, ex, bg_owin, lambda_xy, coords_ppp)})) - - } + # } # check if any points were selected to thin if (length(sel) == 0){ diff --git a/man/thin_observations.Rd b/man/thin_observations.Rd index 12fc39e0..37407267 100644 --- a/man/thin_observations.Rd +++ b/man/thin_observations.Rd @@ -9,7 +9,7 @@ thin_observations( background, env = NULL, method = "random", - minpoints = 10, + remainpoints = 10, mindistance = NULL, zones = NULL, probs = 0.75, @@ -33,7 +33,7 @@ method is set to \code{"environmental"} or \code{"bias"} (Default: \item{method}{A \code{\link{character}} of the method to be applied (Default: \code{"random"}).} -\item{minpoints}{A \code{\link{numeric}} giving the number of data points at minimum to +\item{remainpoints}{A \code{\link{numeric}} giving the number of data points at minimum to remain (Default: \code{10}).} \item{mindistance}{A \code{\link{numeric}} for the minimum distance of neighbouring @@ -45,8 +45,9 @@ chosen (Default: \code{NULL}).} \item{probs}{A \code{\link{numeric}} used as quantile threshold in \code{"bias"} method. (Default: \code{0.75}).} -\item{global}{A \code{\link{logical}} if during \code{"bias"} method global or local, extracted -bias values are used as threshold. (Default: \code{TRUE}).} +\item{global}{A \code{\link{logical}} if during \code{"bias"} method global (entire \code{env} raster) +or local (extracted at point locations) bias values are used as for quantile threshold. +(Default: \code{TRUE}).} \item{centers}{A \code{\link{numeric}} used as number of centers for \code{"environmental"} method. (Default: \code{NULL}). If not set, automatically set to three or nlayers - 1 (whatever @@ -61,32 +62,33 @@ that occurrence records are unbiased, which is rarely the case. While model-based control can alleviate some of the effects of sampling bias, it can often be desirable to account for some sampling biases through spatial thinning (Aiello‐Lammens et al. 2015). This is an approach based on the -assumption that oversampled grid cells contribute little more than bias, -rather than strengthing any environmental responses. This function provides +assumption that over-sampled grid cells contribute little more than bias, +rather than strengthening any environmental responses. This function provides some methods to apply spatial thinning approaches. Note that this effectively removes data prior to any estimation and its use should be considered with care (see also Steen et al. 2021). } \details{ All methods only remove points from "over-sampled" grid cells/areas. These are -defined as all cells/area which either have more points than \code{minpoints} or -more points than the global minimum point count per cell (whichever is larger). +defined as all cells/areas which either have more points than \code{remainpoints} or +more points than the global minimum point count per cell/area (whichever is larger). Currently implemented thinning methods: \itemize{ \item \code{"random"}: Samples at random across all over-sampled grid cells returning -at minimum \code{"minpoints"} . -Does not account for any spatial or environmental distance between observations. -\item \code{"bias"}: This option removes explicitly points that are considered biased (parameter \code{"env"}) only. -Points are only thinned from grid cells which are above the bias quantile (larger values -equals greater bias). Thins the observations up to \code{"minpoints"}. -\item \code{"zones"}: Assesses for each observation that it falls with a maximum of \code{"minpoints"} into -each occupied zone. Careful: If the zones are relatively wide this can -remove quite a few observations. +only \code{"remainpoints"} from over-sampled cells. Does not account for any +spatial or environmental distance between observations. +\item \code{"bias"}: This option removes explicitly points that are considered biased only +(based on \code{"env"}). Points are only thinned from grid cells which are above the bias +quantile (larger values equals greater bias). Thins the observations returning +\code{"remainpoints"} from each over-sampled and biased cell. +\item \code{"zones"}: Thins observations from each zone that is above the over-sampled +threshold and returns \code{"remainpoints"} for each zone. Careful: If the zones are +relatively wide this can remove quite a few observations. \item \code{"environmental"}: This approach creates an observation-wide clustering (k-means) under the assumption that the full environmental niche has been comprehensively sampled and is -covered by the provided covariates \code{env}. We then obtain an number -equal to (\code{"minpoints"}) of observations for each cluster. +covered by the provided covariates \code{env}. For each over-sampled cluster, +we then obtain (\code{"remainpoints"}) by thinning points. \item \code{"spatial"}: Calculates the spatial distance between all observations. Then points are removed iteratively until the minimum distance between points is crossed. The \code{"mindistance"} parameter has to be set for this function to work. diff --git a/tests/testthat/test_functions.R b/tests/testthat/test_functions.R index f9492ffb..32df3ca7 100644 --- a/tests/testthat/test_functions.R +++ b/tests/testthat/test_functions.R @@ -216,7 +216,7 @@ test_that('Test data preparation convenience functions', { # --- # # Apply thinning methods pp1 <- thin_observations(data = virtual_points, background = background, - method = "random", minpoints = 3,verbose = FALSE) + method = "random", remainpoints = 3,verbose = FALSE) expect_gt(nrow(pp1),0) # - # expect_error(pp2 <- thin_observations(data = virtual_points, background = background, diff --git a/vignettes/articles/01_data_preparationhelpers.Rmd b/vignettes/articles/01_data_preparationhelpers.Rmd index d0d8ff23..83adb665 100644 --- a/vignettes/articles/01_data_preparationhelpers.Rmd +++ b/vignettes/articles/01_data_preparationhelpers.Rmd @@ -178,7 +178,7 @@ plot(virtual_species['Observed'], main = "Original data") point1 <- thin_observations(data = virtual_species, background = background, method = 'random', - minpoints = 1 # Retain at minimum one point per grid cell! + remainpoints = 1 # Retain at minimum one point per grid cell! ) plot(point1['Observed'], main = "Random thinning") @@ -191,7 +191,7 @@ point2 <- thin_observations(data = virtual_species, background = background, env = covariates, method = 'environmental', - minpoints = 5 # Retain at minimum five points! + remainpoints = 5 # Retain at minimum five points! ) plot(point2['Observed'], main = "Environmentally stratified data") From 690dad145c7f90c43b8b5097231c1a381e0ea90c Mon Sep 17 00:00:00 2001 From: mhesselbarth Date: Mon, 13 Nov 2023 08:52:06 +0000 Subject: [PATCH 06/20] Update CITATION.cff --- CITATION.cff | 40 ---------------------------------------- 1 file changed, 40 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 34bdef0d..30251521 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -866,43 +866,3 @@ references: given-names: Jiaming email: jm.yuan@outlook.com year: '2023' -- type: software - title: spatstat.geom - abstract: 'spatstat.geom: Geometrical Functionality of the ''spatstat'' Family' - notes: Suggests - url: http://spatstat.org/ - repository: https://CRAN.R-project.org/package=spatstat.geom - authors: - - family-names: Baddeley - given-names: Adrian - email: Adrian.Baddeley@curtin.edu.au - orcid: https://orcid.org/0000-0001-9499-8382 - - family-names: Turner - given-names: Rolf - email: rolfturner@posteo.net - orcid: https://orcid.org/0000-0001-5521-5218 - - family-names: Rubak - given-names: Ege - email: rubak@math.aau.dk - orcid: https://orcid.org/0000-0002-6675-533X - year: '2023' -- type: software - title: spatstat.explore - abstract: 'spatstat.explore: Exploratory Data Analysis for the ''spatstat'' Family' - notes: Suggests - url: http://spatstat.org/ - repository: https://CRAN.R-project.org/package=spatstat.explore - authors: - - family-names: Baddeley - given-names: Adrian - email: Adrian.Baddeley@curtin.edu.au - orcid: https://orcid.org/0000-0001-9499-8382 - - family-names: Turner - given-names: Rolf - email: rolfturner@posteo.net - orcid: https://orcid.org/0000-0001-5521-5218 - - family-names: Rubak - given-names: Ege - email: rubak@math.aau.dk - orcid: https://orcid.org/0000-0002-6675-533X - year: '2023' From 0923c685109ec1e4a8ee9de3e84c73f7d274dab9 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Sat, 9 Dec 2023 18:52:47 +0100 Subject: [PATCH 07/20] :train: travel work: Addition of easier extrapolation controls --- DESCRIPTION | 1 + NAMESPACE | 2 + NEWS.md | 3 + R/add_control_bias.R | 18 +- R/add_control_extrapolation.R | 175 ++++++++++++++++++ R/bdproto-biodiversitydataset.R | 2 +- R/bdproto-biodiversitydistribution.R | 68 ++++--- R/bdproto-biodiversityscenario.R | 2 +- R/bdproto-distributionmodel.R | 17 +- R/bdproto-predictors.R | 4 +- R/distribution.R | 2 +- R/mask.R | 8 +- R/scenario.R | 26 ++- R/similarity.R | 33 +++- R/simulate_population_steps.R | 2 +- R/train.R | 148 ++++++++++----- R/zzz.R | 4 +- _pkgdown.yml | 1 + man/add_control_bias.Rd | 15 +- man/add_control_extrapolation.Rd | 109 +++++++++++ man/mask.Rd | 8 +- man/scenario.Rd | 12 +- .../testthat/test_BiodiversityDistribution.R | 2 +- tests/testthat/test_controls.R | 78 ++++++++ tests/testthat/test_rangesOffsets.R | 4 +- 25 files changed, 628 insertions(+), 116 deletions(-) create mode 100644 R/add_control_extrapolation.R create mode 100644 man/add_control_extrapolation.Rd create mode 100644 tests/testthat/test_controls.R diff --git a/DESCRIPTION b/DESCRIPTION index 63cb54f5..36c32d89 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -92,6 +92,7 @@ Collate: 'add_constraint.R' 'add_constraint_MigClim.R' 'add_control_bias.R' + 'add_control_extrapolation.R' 'add_latent.R' 'bdproto-log.R' 'add_log.R' diff --git a/NAMESPACE b/NAMESPACE index c545fe9a..c9a0ec49 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -73,6 +73,7 @@ export(add_constraint_connectivity) export(add_constraint_dispersal) export(add_constraint_minsize) export(add_control_bias) +export(add_control_extrapolation) export(add_latent_spatial) export(add_log) export(add_offset) @@ -174,6 +175,7 @@ exportMethods(add_constraint_connectivity) exportMethods(add_constraint_dispersal) exportMethods(add_constraint_minsize) exportMethods(add_control_bias) +exportMethods(add_control_extrapolation) exportMethods(add_latent_spatial) exportMethods(add_log) exportMethods(add_offset) diff --git a/NEWS.md b/NEWS.md index 55f2a9d4..19868ebd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ibis.iSDM 0.1.1 (current dev branch) +#### New features +* Harmonized controls settings and added option to contrain extrapolation `add_control_extrapolation()` + #### Minor improvements and bug fixes * Several bug fixes and improvements in `thin_observations` * `global`, `probs`, and `centers` argument for better control of `thin_observations` diff --git a/R/add_control_bias.R b/R/add_control_bias.R index e99ab6f9..1c38ad64 100644 --- a/R/add_control_bias.R +++ b/R/add_control_bias.R @@ -1,4 +1,4 @@ -#' Add a specified variable which should be controlled for somehow. +#' Add a control to a BiodiversityModel object to control biases #' #' @description Sampling and other biases are pervasive drivers of the spatial #' location of biodiversity datasets. While the integration of other, presumably @@ -10,10 +10,11 @@ #' control the biases in a model, by including a specified variable ("layer") in #' the model, but "partialling" it out during the projection phase. Specifically #' the variable is set to a specified value ("bias_value"), which is by default -#' the minimum value observed across the background. [*] \code{"offset"} - Dummy +#' the minimum value observed across the background. +#' [*] \code{"offset"} - Dummy #' method that points to the [`add_offset_bias()`] functionality (see note). -#' Makes use of offsets to factor out a specified bias variable. [*] -#' \code{"proximity"} - Use the proximity or distance between points as a weight +#' Makes use of offsets to factor out a specified bias variable. +#' [*] \code{"proximity"} - Use the proximity or distance between points as a weight #' in the model. This option effectively places greater weight on points farther #' away. *Note:* In the best case this can control for spatial bias and #' aggregation, in the worst case it can place a lot of emphasis on points that @@ -71,7 +72,8 @@ #' * Merow, C., Allen, J.M., Aiello-Lammens, M., Silander, J.A., 2016. Improving niche and range estimates with Maxent and point process models by integrating spatially explicit information. Glob. Ecol. Biogeogr. 25, 1022–1036. https://doi.org/10.1111/geb.12453 #' * Botella, C., Joly, A., Bonnet, P., Munoz, F., & Monestiez, P. (2021). Jointly estimating spatial sampling effort and habitat suitability for multiple species from opportunistic presence‐only data. Methods in Ecology and Evolution, 12(5), 933-945. #' @returns Adds bias control option to a [`distribution`] object. -#' @keywords bias, offset +#' @keywords bias, offset, control +#' @seealso [add_control_extrapolation()] #' @aliases add_control_bias #' @examples #' \dontrun{ @@ -133,11 +135,11 @@ methods::setMethod( if(method == "partial"){ if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Adding bias controlled variable...') - if(!is.Waiver(x$get_biascontrol())){ + if(!is.Waiver(x$get_control())){ if(getOption('ibis.setupmessages')) myLog('[Setup]','yellow','Overwriting existing bias variable...') } # Add to bias control - x <- x$set_biascontrol(layer, method, bias_value) + x <- x$set_control(type = "bias", layer, method, bias_value) } else if(method == "offset") { x <- x |> add_offset_bias(layer = layer, add = add) @@ -147,7 +149,7 @@ methods::setMethod( # Here we use proximity as a weight to any points. Those will be applied # during the model training, thus we simply define the bias control here if(is.null(maxdist)) maxdist <- 0 - x <- x$set_biascontrol(method = method, value = c(maxdist, alpha)) + x <- x$set_control(type = "bias", method = method, value = c(maxdist, alpha)) } return(x) } diff --git a/R/add_control_extrapolation.R b/R/add_control_extrapolation.R new file mode 100644 index 00000000..c5d34d3e --- /dev/null +++ b/R/add_control_extrapolation.R @@ -0,0 +1,175 @@ +#' Add a control to a BiodiversityModel object to control extrapolation +#' +#' @description One of the main aims of species distribution models (SDMs) is to project +#' in space and time. For projections a common issue is extrapolation as - unconstrained - +#' SDMs can indicate areas as suitable which are unlikely to be occupied by species +#' or habitats (often due to historic or biotic factors). To some extent this can +#' be related to an insufficient quantification of the niche (e.g. niche truncation +#' by considering only a subset of observations within the actual distribution), +#' in other cases there can also be general barriers or constraints that limit +#' any projections (e.g. islands). This control method adds some of those options +#' to a model distribution object. Currently supported methods are: +#' +#' [*] \code{"zones"} - This is a wrapper to allow the addition of zones to a +#' distribution model object, similar to what is also possible via [distribution()]. +#' Required is a spatial layer that describes a environmental zoning. +#' +#' [*] \code{"mcp"} - Rather than using an external or additional layer, this option constraints +#' predictions by a certain distance of points in its vicinity. Buffer distances +#' have to be in the unit of the projection used and can be configured via +#' \code{"mcp_buffer"}. +#' +#' [*] \code{"nt2"} - Constraints the predictions using the multivariate combination novelty index (NT2) +#' following Mesgaran et al. (2014). This method is also available in the [similarity()] +#' function. +#' +#' [*] \code{"shape"} - This is an implementation of the 'shape' method introduced +#' by Velazco et al. (2023). Through a user defined threshold it effectively limits +#' model extrapolation so that no projections are made beyond the extent judged as +#' defensible and informed by the training observations. +#' +#' See also details for further explanations. +#' +#' @details +#' For method \code{"zones"} a zoning layer can be supplied which is then used to intersect +#' the provided training points with. Any projections made with the model can +#' then be constrained so as to not project into areas that do not consider any +#' training points and are unlikely to have any. Examples for zones are for the +#' separation of islands and mainlands, biomes, or lithological soil conditions. +#' +#' If no layer is available, it is also possible to constraint predictions by the +#' distance to a minimum convex polygon surrounding the training points with +#' method \code{"mcp"} (optionally buffered). This can make sense particular for +#' rare species or those fully sampled across their niche. +#' +#' For the \code{"NT2"} and \code{"MESS"} index it is possible to constrain +#' the prediction to conditions within (\code{novel = "within"}) or also include +#' outside (\code{novel = "outside"}) conditions. +#' +#' @note +#' The method \code{"zones"} is also possible directly within [distribution()]. +#' +#' @param x [distribution()] (i.e. [`BiodiversityDistribution-class`]) object. +#' @param layer A [`SpatRaster`] or [`sf`] object that limits the prediction +#' surface when intersected with input data (Default: \code{NULL}). +#' @param method A [`character`] vector describing the method used for controlling +#' extrapolation. Available options are \code{"zones"}, \code{"mcp"} (Default), +#' or \code{"nt2"} or \code{"shape"}. +#' @param mcp_buffer A [`numeric`] distance to buffer the mcp (Default +#' \code{0}). Only used if \code{"mcp"} is used. +#' @param novel Which conditions are to be masked out respectively, either the +#' novel conditions within only \code{"within"} (Default) or also including outside +#' reference conditions \code{"outside"}. Only use for \code{method = "nt2"}, for +#' \code{method = "mess"} this variable is always \code{"within"}. +#' @param limits_clip [`logical`] Should the limits clip all predictors before +#' fitting a model (\code{TRUE}) or just the prediction (\code{FALSE}, +#' default). +#' +#' @references +#' * Randin, C. F., Dirnböck, T., Dullinger, S., Zimmermann, N. E., Zappa, M., & Guisan, A. (2006). Are niche‐based species distribution models transferable in space?. Journal of biogeography, 33(10), 1689-1703. https://doi.org/10.1111/j.1365-2699.2006.01466.x +#' * Chevalier, M., Broennimann, O., Cornuault, J., & Guisan, A. (2021). Data integration methods to account for spatial niche truncation effects in regional projections of species distribution. Ecological Applications, 31(7), e02427. https://doi.org/10.1002/eap.2427 +#' * Velazco, S. J. E., Brooke, M. R., De Marco Jr., P., Regan, H. M., & Franklin, J. (2023). How far can I extrapolate my species distribution model? Exploring Shape, a novel method. Ecography, 11, e06992. https://doi.org/10.1111/ecog.06992 +#' * Mesgaran, M. B., R. D. Cousens, B. L. Webber, and J. Franklin. (2014) Here be dragons: a tool for quantifying novelty due to covariate range and correlation change when projecting species distribution models. Diversity and Distributions 20:1147-1159. +#' @returns Adds extrapolation control option to a [`distribution`] object. +#' @keywords control +#' @aliases add_control_extrapolation +#' @examples +#' \dontrun{ +#' # To add a zone layer for extrapolation constraints. +#' x <- distribution(background) |> +#' add_predictors(covariates) |> +#' add_control_extrapolation(method = "zones", layer = zones) +#' } +#' @name add_control_extrapolation +NULL + +#' @name add_control_extrapolation +#' @rdname add_control_extrapolation +#' @exportMethod add_control_extrapolation +#' @export +methods::setGeneric( + "add_control_extrapolation", + signature = methods::signature("x"), + function(x, layer, method = "mcp", mcp_buffer = 0, + novel = "within", limits_clip = FALSE) standardGeneric("add_control_extrapolation")) + +#' @name add_control_extrapolation +#' @rdname add_control_extrapolation +#' @usage +#' \S4method{add_control_extrapolation}{BiodiversityDistribution,SpatRaster,character,numeric,character,logical}(x,layer,method,mcp_buffer,novel,limits_clip) +methods::setMethod( + "add_control_extrapolation", + methods::signature(x = "BiodiversityDistribution"), + function(x, layer, method = "mcp", mcp_buffer = 0, novel = "within", limits_clip = FALSE) { + assertthat::assert_that(inherits(x, "BiodiversityDistribution"), + missing(layer) || (is.Raster(layer) || is.sf(layer)), + (is.numeric(mcp_buffer) && mcp_buffer >=0), + is.logical(limits_clip), + is.character(novel), + is.character(method) + ) + # Match method + method <- match.arg(method, c("zones", "mess", "nt2", "mcp", "shape"), several.ok = FALSE) + novel <- match.arg(novel, c("within", "outside"), several.ok = FALSE) + + # Apply method specific settings + if(method == "zones"){ + assertthat::assert_that((is.Raster(layer) || is.sf(layer)), + msg = "No zone layer specified!") + + if(inherits(layer,'SpatRaster')){ + assertthat::assert_that(terra::is.factor(layer), + msg = 'Provided limit raster needs to be ratified (categorical)!') + layer <- sf::st_as_sf( terra::as.polygons(layer, dissolve = TRUE) ) |> sf::st_cast("MULTIPOLYGON") + } + assertthat::assert_that(inherits(layer, "sf"), + unique(sf::st_geometry_type(layer)) %in% c('MULTIPOLYGON','POLYGON'), + msg = "Limits need to be of polygon type." + ) + + # Get background + background <- x$background + + # Ensure that limits has the same projection as background + if(sf::st_crs(layer) != sf::st_crs(background)) layer <- sf::st_transform(layer, background) + + # Ensure that limits is intersecting the background + if(is.Raster(background)){ + if(suppressMessages(length( sf::st_intersects(layer, terra::as.polygons(background) |> sf::st_as_sf()) )) == 0 ) { layer <- NULL; warning('Provided zones do not intersect the background!') } + } else { + if(suppressMessages(length( sf::st_intersects(layer, background |> sf::st_as_sf()) )) == 0 ) { layer <- NULL; warning('Provided zones do not intersect the background!') } + } + + # Get first column for zone description and rename + layer <- layer[,1]; names(layer) <- c('limit','geometry') + limits <- list(layer = layer, "limits_method" = method, + "mcp_buffer" = mcp_buffer, "limits_clip" = limits_clip) + x <- x$set_limits(x = limits) + } else if(method == "mcp"){ + # Specify the option to calculate a mcp based on the added data. + # This is done directly in train. + limits <- list("layer" = NULL, "limits_method" = method, + "mcp_buffer" = mcp_buffer, "limits_clip" = limits_clip) + x <- x$set_limits(x = limits) + } else if(method == "nt2"){ + # Specify that the multivariate combination novelty index (NT2) is + # to be applied + limits <- list("layer" = NULL, "limits_method" = method, + "mcp_buffer" = mcp_buffer, "novel" = novel, + "limits_clip" = limits_clip) + x <- x$set_limits(x = limits) + } else if(method == "mess"){ + # Specify that the multivariate combination novelty index (NT2) is + # to be applied + limits <- list("layer" = NULL, "limits_method" = method, + "mcp_buffer" = mcp_buffer, "novel" = novel, + "limits_clip" = limits_clip) + x <- x$set_limits(x = limits) + } else if(method == "shape"){ + stop("Method not yet implemented") + } + + # Return the altered object + return(x) + } +) diff --git a/R/bdproto-biodiversitydataset.R b/R/bdproto-biodiversitydataset.R index 8e796963..0b593514 100644 --- a/R/bdproto-biodiversitydataset.R +++ b/R/bdproto-biodiversitydataset.R @@ -318,7 +318,7 @@ BiodiversityDataset <- bdproto( nrow(self$data) }, # Masking function - mask = function(self, mask, inverse = FALSE){ + mask = function(self, mask, inverse = FALSE, ...){ # Check whether prediction has been created biob <- self$data if(!is.Waiver(biob)){ diff --git a/R/bdproto-biodiversitydistribution.R b/R/bdproto-biodiversitydistribution.R index 70577a64..9261451c 100644 --- a/R/bdproto-biodiversitydistribution.R +++ b/R/bdproto-biodiversitydistribution.R @@ -28,7 +28,7 @@ BiodiversityDistribution <- bdproto( biodiversity = bdproto(NULL, BiodiversityDatasetCollection), predictors = new_waiver(), priors = new_waiver(), - bias = new_waiver(), + control = new_waiver(), latentfactors = new_waiver(), offset = new_waiver(), log = new_waiver(), @@ -44,8 +44,12 @@ BiodiversityDistribution <- bdproto( paste0( "\n offset: <", name_atomic(self$get_offset()),">" ) ) pio <- ifelse(is.Waiver(self$priors), '', paste0('Priors specified (',self$priors$length(), ')') ) - bv <- ifelse(is.Waiver(self$bias), '', - paste0( "\n bias control: <", self$bias$method, ">" ) ) + bv <- ifelse(is.Waiver(self$control), '', + paste0( "\n control: <", name_atomic( + paste0( self$control$type, " - ", self$control$method) + ), ">" ) ) + li <- ifelse(is.Waiver(self$limits), '', + paste0( "\n limits: <",paste0( self$limits$limits_method,collapse = ", "), ">" )) en <- ifelse(is.null(self$get_engine()), text_red(""), self$get_engine() ) @@ -62,6 +66,7 @@ BiodiversityDistribution <- bdproto( "\n latent: ", paste(self$get_latent(), collapse = ', '), of, bv, + li, "\n log: ", self$get_log(), "\n engine: ", en ) @@ -85,13 +90,13 @@ BiodiversityDistribution <- bdproto( return(o) }, # Set limits - set_limits = function(self, x, mcp_buffer = 0, limits_clip = FALSE){ - assertthat::assert_that(is.Raster(x) || inherits(x, "sf"), - msg = "Provide a SpatRaster or sf object!") - # Construct limits object assuming zones - x <- list(layer = x, limits_method = "zones", - "mcp_buffer" = mcp_buffer, "limits_clip" = limits_clip) - + set_limits = function(self, x){ + # Specify list + assertthat::assert_that(is.list(x), + msg = "Provide a prepared list for the limits!") + assertthat::assert_that( + utils::hasName(x, "layer"), utils::hasName(x, "limits_method") + ) bdproto(NULL, self, limits = x ) }, # Get provided limits @@ -237,31 +242,44 @@ BiodiversityDistribution <- bdproto( at[['logistic_coefficients']] <- attr(self$offset, "logistic_coefficients") return(at) }, - # set_biascontrol - set_biascontrol = function(self, x, method, value){ + # set_control + set_control = function(self, type = "bias", x, method, value){ assertthat::assert_that(missing(x) || is.Raster(x), all(is.numeric(value))) - if(missing(x)) { - assertthat::assert_that(method == "proximity", - msg = paste0("Supply a layer for method ", method)) - x <- NULL + # Check type of control + type <- match.arg(type, c("bias", "extrapolation"), several.ok = FALSE) + if(type == "bias"){ + if(missing(x)) { + assertthat::assert_that(method == "proximity", + msg = paste0("Supply a layer for method ", method)) + x <- NULL + } + bdproto(NULL, self, control = list(type = type, layer = x, + method = method, bias_value = value) ) + } else if(type == "extrapolation"){ + bdproto(NULL, self, control = list(type = type, layer = x, method = method, value = value) ) } - bdproto(NULL, self, bias = list(layer = x, method = method, bias_value = value) ) }, # Get bias control (print name) - get_biascontrol = function(self){ - if(is.Waiver(self$bias)) return( self$bias ) - names( self$bias ) + get_control = function(self, type = "bias"){ + # Check type of control + type <- match.arg(type, c("bias", "extrapolation"), several.ok = FALSE) + control <- self$control + if(is.Waiver(control)) return( control ) + if(control$type == "bias" && type == "bias") names( control ) }, # Remove bias controls - rm_biascontrol = function(self){ - bdproto(NULL, self, bias = new_waiver() ) + rm_control = function(self){ + bdproto(NULL, self, control = new_waiver() ) }, # Plot bias variable plot_bias = function(self){ - if(is.Waiver(self$bias)) return( self$bias ) - terra::plot(self$bias$layer, - col = ibis_colours$viridis_plasma, main = "Bias variable") + if(is.Waiver(self$control)) return( self$control ) + control <- self$control + if(control$type == "bias"){ + terra::plot(control$layer, + col = ibis_colours$viridis_plasma, main = "Bias variable") + } }, # Get log get_log = function(self){ diff --git a/R/bdproto-biodiversityscenario.R b/R/bdproto-biodiversityscenario.R index c4851d21..6f48ceff 100644 --- a/R/bdproto-biodiversityscenario.R +++ b/R/bdproto-biodiversityscenario.R @@ -549,7 +549,7 @@ BiodiversityScenario <- bdproto( return(out) }, # Masking function - mask = function(self, mask, inverse = FALSE){ + mask = function(self, mask, inverse = FALSE, ...){ # Check whether prediction has been created projection <- self$get_data() if(!is.Waiver(projection)){ diff --git a/R/bdproto-distributionmodel.R b/R/bdproto-distributionmodel.R index be7cd920..6e9e689c 100644 --- a/R/bdproto-distributionmodel.R +++ b/R/bdproto-distributionmodel.R @@ -20,6 +20,7 @@ DistributionModel <- bdproto( "DistributionModel", id = character(), # An id for any trained model model = list(), + settings = new_waiver(), fits = list(), # List of fits with data # Print message with summary of model print = function(self) { @@ -453,8 +454,18 @@ DistributionModel <- bdproto( } return(cent) }, + # Has Limits + has_limits = function(self){ + # Check for settings + settings <- self$settings + if(!is.Waiver(settings)){ + return( + settings$get('has_limits') + ) + } + }, # Masking function - mask = function(self, mask, inverse = FALSE){ + mask = function(self, mask, inverse = FALSE, ...){ # Check whether prediction has been created prediction <- self$get_data() if(!is.Waiver(prediction)){ @@ -467,7 +478,7 @@ DistributionModel <- bdproto( mask <- terra::resample(mask, prediction, method = "near") } # Now mask and save - prediction <- terra::mask(prediction, mask, inverse = inverse) + prediction <- terra::mask(prediction, mask, inverse = inverse, ...) # Save data self$fits[["prediction"]] <- prediction @@ -476,7 +487,7 @@ DistributionModel <- bdproto( tr <- grep("threshold", self$show_rasters(), value = TRUE) if(length(tr)){ m <- self$get_data(x = tr) - m <- terra::mask(m, mask, inverse = inverse) + m <- terra::mask(m, mask, inverse = inverse, ...) self$fits[[tr]] <- m } invisible() diff --git a/R/bdproto-predictors.R b/R/bdproto-predictors.R index 32884e23..2af0957c 100644 --- a/R/bdproto-predictors.R +++ b/R/bdproto-predictors.R @@ -108,7 +108,7 @@ PredictorDataset <- bdproto( invisible() }, # Masking function - mask = function(self, mask, inverse = FALSE){ + mask = function(self, mask, inverse = FALSE, ...){ # Check whether prediction has been created prediction <- self$get_data(df = FALSE) if(!is.Waiver(prediction)){ @@ -121,7 +121,7 @@ PredictorDataset <- bdproto( mask <- terra::resample(mask, prediction, method = "near") } # Now mask and save - prediction <- terra::mask(prediction, mask, inverse = inverse) + prediction <- terra::mask(prediction, mask, inverse = inverse, ...) # Save data self$fits[["data"]] <- prediction diff --git a/R/distribution.R b/R/distribution.R index 09233880..e0b56c82 100644 --- a/R/distribution.R +++ b/R/distribution.R @@ -165,7 +165,7 @@ methods::setMethod( msg = 'No background file supplied!') assertthat::assert_that( inherits(background,'sf'), - unique(st_geometry_type(background)) %in% c('MULTIPOLYGON','POLYGON') + unique(sf::st_geometry_type(background)) %in% c('MULTIPOLYGON','POLYGON') ) # Check that provided background has a valid crs diff --git a/R/mask.R b/R/mask.R index 5834935f..f9a8a623 100644 --- a/R/mask.R +++ b/R/mask.R @@ -42,22 +42,22 @@ NULL #' @method mask DistributionModel #' @keywords utils #' @export -mask.DistributionModel <- function(x, mask, inverse = FALSE) x$mask(mask,inverse) +mask.DistributionModel <- function(x, mask, inverse = FALSE, ...) x$mask(mask,inverse,...) #' @rdname mask #' @method mask BiodiversityDatasetCollection #' @keywords utils #' @export -mask.BiodiversityDatasetCollection <- function(x, mask, inverse = FALSE) x$mask(mask,inverse) +mask.BiodiversityDatasetCollection <- function(x, mask, inverse = FALSE, ...) x$mask(mask,inverse,...) #' @rdname mask #' @method mask PredictorDataset #' @keywords utils #' @export -mask.PredictorDataset <- function(x, mask, inverse = FALSE) x$mask(mask,inverse) +mask.PredictorDataset <- function(x, mask, inverse = FALSE, ...) x$mask(mask,inverse,...) #' @rdname mask #' @method mask BiodiversityScenario #' @keywords utils #' @export -mask.BiodiversityScenario <- function(x, mask, inverse = FALSE) x$mask(mask,inverse) +mask.BiodiversityScenario <- function(x, mask, inverse = FALSE, ...) x$mask(mask,inverse,...) diff --git a/R/scenario.R b/R/scenario.R index 262ab625..612aadab 100644 --- a/R/scenario.R +++ b/R/scenario.R @@ -5,11 +5,19 @@ NULL #' #' @description This function creates a new [BiodiversityScenario-class] object #' that contains the projections of a model. +#' @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 +#' reused for the projections. **Note: This effectively fixes the projections to certain areas.** +#' #' @param fit A [`BiodiversityDistribution`] object containing a trained model. #' @param limits A [`SpatRaster`] or [`sf`] object that limits the projection #' surface when intersected with the prediction data (Default: \code{NULL}). #' This can for instance be set as an expert-delineated constrain to limit #' spatial projections. +#' @param reuse_limits A [`logical`] on whether to reuse limits if found in the +#' trained [`BiodiversityDistribution`] object (Default: \code{FALSE}). See also notes! +#' #' @param copy_model A [`logical`] of whether the model object is to be copied #' to the scenario object. Note that setting this option to \code{TRUE} can #' increase the required amount of memory (Default: \code{FALSE}). @@ -24,18 +32,19 @@ NULL #' @export methods::setGeneric("scenario", signature = methods::signature("fit"), - function(fit, limits = NULL, copy_model = FALSE) standardGeneric("scenario")) + function(fit, limits = NULL, reuse_limits = FALSE, copy_model = FALSE) standardGeneric("scenario")) #' @name scenario -#' @usage \S4method{scenario}{ANY,ANY,logical}(fit,limits,copy_model) +#' @usage \S4method{scenario}{ANY,ANY,logical,logical}(fit,limits,reuse_limits,copy_model) #' @rdname scenario methods::setMethod( "scenario", methods::signature(fit = "ANY"), - function(fit, limits = NULL, copy_model = FALSE) { + function(fit, limits = NULL, reuse_limits = FALSE, copy_model = FALSE) { # Check that arguments are valid assertthat::assert_that(!missing(fit) || inherits(fit,'DistributionModel'), inherits(limits, 'SpatRaster') || inherits(limits, 'sf') || inherits(limits, 'Spatial') || is.null(limits), + is.logical(reuse_limits), is.logical(copy_model), msg = 'No trained model supplied!') @@ -65,6 +74,17 @@ methods::setMethod( # Get fir column and rename limits <- limits[,1]; names(limits) <- c('limit','geometry') } + + # Also check if limits are to be reused if found + if(reuse_limits){ + # Check if limits have been found. + if(fit$has_limits()){ + if(getOption('ibis.setupmessages')) myLog('[Scenario]','yellow', "Found existing extrapolation limits and will reuse them!") + settings <- fit$settings + limits <- settings$get('limits')[['layer']] + } + } + if(is.null(limits)){ # Convert to waiver if NULL limits <- new_waiver() diff --git a/R/similarity.R b/R/similarity.R index a4fec33c..abdaada6 100644 --- a/R/similarity.R +++ b/R/similarity.R @@ -163,7 +163,7 @@ methods::setMethod( graphics::par(mfrow=c(3,1)) terra::plot(exp(out$NT1),col = ibis_colours[['viridis_plasma']],main = paste0('Univariate extrapolation\n(exp. transformed)')) terra::plot(log(out$NT2),col = ibis_colours[['viridis_orig']],main = paste0('Non-analogous dissimilarity\n(log. transformed)')) - terra::plot(out$novel,col = ibis_colours[['distinct_random']][4:6],main = paste0('Novel conditions (method: ',method,')')) + terra::plot(out$novel,col = ibis_colours[['distinct_random']][4:7],main = paste0('Novel conditions (method: ',method,')')) graphics::par(par.ori) } } else { @@ -206,9 +206,10 @@ methods::setMethod( ref = ex, full = full) # Calculate interpolation/extrapolated - rip <- terra::global(out$mis, + rip <- terra::classify(out$mis, c(terra::global(out$mis,'min', na.rm = TRUE)[,1], 0, - terra::global(out$mis,'max', na.rm = TRUE)[,1]), na.rm = TRUE) + terra::global(out$mis,'max', na.rm = TRUE)[,1]), + na.rm = TRUE) rip <- terra::as.factor(rip) for(i in 1:terra::nlyr(rip)){ ca <- data.frame(ID = levels(rip[[i]])[[1]][,1]) @@ -289,6 +290,13 @@ methods::setMethod( #' @keywords internal .nt12 <- function(prodat, refdat){ check_package("matrixStats") + assertthat::assert_that( + is.data.frame(refdat) || is.matrix(refdat) + ) + # If not matching, check if this can be corrected + if(terra::nlyr(prodat) != ncol(refdat)){ + refdat <- subset(refdat, select = names(prodat)) + } # Input checks assertthat::assert_that(is.Raster(prodat), @@ -368,12 +376,14 @@ methods::setMethod( # non-analogous covariate combinations o_high <- nt2 > 1 + nt_novel[o_low == 0] <- 0 nt_novel[o_low == 1] <- 1 nt_novel[o_mid == 1] <- 2 nt_novel[o_high == 1] <- 3 nt_novel <- terra::as.factor(nt_novel) - levels(nt_novel) <- data.frame(ID = c(1,2,3), - what = c('Outside reference','Within reference','Novel combinations')) + levels(nt_novel) <- data.frame(ID = c(0,1,2,3), + what = c('Reference','Within reference', + 'Outside reference','Novel combinations')) # Create output stack out <- c(nt1, nt2, nt_novel) @@ -390,9 +400,20 @@ methods::setMethod( #' @noRd #' @keywords internal .mess <- function(covs, ref, full=FALSE) { + assertthat::assert_that( + is.data.frame(ref) || is.matrix(ref), + nrow(ref)>0, + is.logical(full) + ) + # If not matching, check if this can be corrected + if(terra::nlyr(covs) != ncol(ref)){ + ref <- subset(ref, select = names(covs)) + } + assertthat::assert_that(terra::nlyr(covs) == ncol(ref)) + # Convert to data.frame if(!is.data.frame(ref)) { - ref <- as.data.frame(ref,na.rm = FALSE) + ref <- as.data.frame(ref, na.rm = FALSE) } # Make dummy template rasters if(is.Raster(covs)) { diff --git a/R/simulate_population_steps.R b/R/simulate_population_steps.R index 8fbf8479..4929525e 100644 --- a/R/simulate_population_steps.R +++ b/R/simulate_population_steps.R @@ -220,7 +220,7 @@ methods::setMethod( foreach::foreach(i = 1:raster::nlayers(popN)) %do% { max_pop <- ceiling(raster::cellStats(popN[[i]], max, na.rm = T)) pop_values <- popN[[i]][idx] - popN[[i]][idx] <- rbinom(prob = (pop_values/max_pop), + popN[[i]][idx] <- stats::rbinom(prob = (pop_values/max_pop), size = max_pop, n = length(pop_values)) popN[[i]] diff --git a/R/train.R b/R/train.R index 081d69b3..bcc942c5 100644 --- a/R/train.R +++ b/R/train.R @@ -203,6 +203,9 @@ methods::setMethod( # Start time settings$set('start.time', Sys.time()) + # Load control + control <- x$get_control() + # Set up logging if specified if(!is.Waiver(x$log)) x$log$open() @@ -386,23 +389,26 @@ methods::setMethod( } else { model[['offset']] <- new_waiver() } # Setting up variable bias control if method == partial - if(!is.Waiver( x$get_biascontrol())){ - bias <- x$bias - if(bias$method == "partial"){ - if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Adding bias variable using partial control.') - settings$set("bias_variable", names(bias$layer) ) - settings$set("bias_value", bias$bias_value ) - # Check that variable is already in the predictors object - if(!(names(bias$layer) %in% model$predictors_names)){ - model$predictors_object <- model$predictors_object$set_data(names(bias$layer), bias$layer) - # Also set predictor names - model[['predictors_names']] <- model$predictors_object$get_names() - model[['predictors']] <- model$predictors_object$get_data(df = TRUE, na.rm = FALSE) - # Get predictor types - lu <- sapply(model[['predictors']][model[['predictors_names']]], is.factor) - model[['predictors_types']] <- data.frame(predictors = names(lu), type = ifelse(lu, 'factor', 'numeric') ) + if(!is.Waiver( control )){ + if(control$type == "bias"){ + bias <- control + if(bias$method == "partial"){ + if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Adding bias variable using partial control.') + settings$set("bias_variable", names(bias$layer) ) + settings$set("bias_value", bias$bias_value ) + # Check that variable is already in the predictors object + if(!(names(bias$layer) %in% model$predictors_names)){ + model$predictors_object <- model$predictors_object$set_data(names(bias$layer), bias$layer) + # Also set predictor names + model[['predictors_names']] <- model$predictors_object$get_names() + model[['predictors']] <- model$predictors_object$get_data(df = TRUE, na.rm = FALSE) + # Get predictor types + lu <- sapply(model[['predictors']][model[['predictors_names']]], is.factor) + model[['predictors_types']] <- data.frame(predictors = names(lu), + type = ifelse(lu, 'factor', 'numeric') ) + } + assertthat::assert_that(nrow(model[['predictors']]) == terra::ncell(model$predictors_object$get_data())) } - assertthat::assert_that(nrow(model[['predictors']]) == terra::ncell(model$predictors_object$get_data())) } } @@ -607,24 +613,26 @@ methods::setMethod( } # Add proximity weights if relevant option is found - if(!is.Waiver( x$get_biascontrol())){ - bias <- x$bias - if(bias$method == "proximity"){ - if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Adding proximity bias weights to points.') - assertthat::assert_that(length(model$biodiversity)==1, - msg = "This method is not yet implemented for multiple datasets.") - - # For each biodiversity dataset collect the points and reassign weights - poi <- collect_occurrencepoints(model = model, - include_absences = TRUE, - addName = TRUE, - tosf = TRUE) - neww <- sf_proximity_weight(poi = poi, - maxdist = bias$bias_value[1], - alpha = bias$bias_value[2]) - # Now set the expectation respectively - model$biodiversity[[1]]$expect <- model$biodiversity[[1]]$expect * exp(neww) - rm(neww) + if(!is.Waiver( control )){ + if(control$type == "bias"){ + bias <- control + if(bias$method == "proximity"){ + if(getOption('ibis.setupmessages')) myLog('[Setup]','green','Adding proximity bias weights to points.') + assertthat::assert_that(length(model$biodiversity)==1, + msg = "This method is not yet implemented for multiple datasets.") + + # For each biodiversity dataset collect the points and reassign weights + poi <- collect_occurrencepoints(model = model, + include_absences = TRUE, + addName = TRUE, + tosf = TRUE) + neww <- sf_proximity_weight(poi = poi, + maxdist = bias$bias_value[1], + alpha = bias$bias_value[2]) + # Now set the expectation respectively + model$biodiversity[[1]]$expect <- model$biodiversity[[1]]$expect * exp(neww) + rm(neww) + } } } @@ -661,20 +669,22 @@ methods::setMethod( } else { spec_priors <- new_waiver() } model[['priors']] <- spec_priors - # - Applying prediction filter based on model input data if specified + # Applying prediction filter based on model input data if specified # Check if MCP should be calculated if(!is.Waiver(x$get_limits())){ # Build MCP based zones ? if(x$limits$limits_method=="mcp"){ # Create a polygon using all available information # Then overwrite limits - x <- x$set_limits(x = create_mcp(model, x$limits), - mcp_buffer = x$limits$mcp_buffer, - limits_clip = x$limits$limits_clip) + l <- list("layer" = create_mcp(model, x$limits), + "limits_method" = "mcp", + "mcp_buffer" = x$limits$mcp_buffer, + "limits_clip" = x$limits$limits_clip) + x <- x$set_limits(x = l) zones <- x$limits$layer assertthat::assert_that(!is.null(zones), utils::hasName(zones, "limit")) - } else { + } else if(x$limits$limits_method=="zones") { # Zones # Get biodiversity data coords <- collect_occurrencepoints(model = model,include_absences = FALSE, @@ -694,6 +704,50 @@ methods::setMethod( ) # Limit zones zones <- subset(x$limits$layer, limit %in% unique(zones$limit) ) + } else if(x$limits$limits_method %in% c("nt2", "mess")){ + # If there are more than one data source, raise warning + if(length(model$biodiversity)>1){ + if(getOption('ibis.setupmessages')) myLog('[Estimation]','yellow', + 'MESS and Novelty index work only for a single datasource. Combining all presence points...') + coords <- collect_occurrencepoints(model = model,include_absences = FALSE, + tosf = TRUE) + refs <- terra::extract(model$predictors_object$get_data(), coords) + } else { + refs <- model$biodiversity[[1]]$predictors + } + + # Multivariate novelty index for the training data + if(x$limits$limits_method=="nt2"){ + rip <- .nt12(prodat = model$predictors_object$get_data(), + refdat = refs)[["novel"]] + # Get only within reference to make a mask + rip <- switch (x$limits$novel, + "within" = (rip %in% c("Reference","Within reference")), + "outside" = (rip %in% c("Reference", "Within reference", "Outside reference")) + ) + rip <- terra::mask(rip, model[['background']]) + } else { + # MESS index + nt2 <- .mess(covs = model$predictors_object$get_data(), + ref = refs, full = FALSE) + # Calculate interpolation/extrapolated + rip <- terra::classify(nt2$mis, + c( terra::global(nt2$mis,'min', na.rm = TRUE)[,1], 0, + terra::global(nt2$mis,'max', na.rm = TRUE)[,1])) + rip <- terra::as.factor(rip) + for(i in 1:terra::nlyr(rip)){ + ca <- data.frame(ID = levels(rip[[i]])[[1]][,1]) + ca[names(rip[[i]])] <- c('Extrapolation','Interpolation') + levels(rip[[i]]) <- ca + } + rip <- rip == 'Interpolation' + rm(nt2) + } + # Convert to polygon + zones <- terra::as.polygons(rip) |> sf::st_as_sf() + names(zones)[1] <- "limit" + zones <- subset(zones, limit==1) # Only use valid areas + try({ rm(nt2) },silent = TRUE) } if(nrow(zones)==0){ @@ -746,10 +800,12 @@ methods::setMethod( # )), "spatial_offset" ] <- NA # Fill with NA # } } - - x <- x$set_limits(x = zones, - mcp_buffer = x$limits$mcp_buffer, - limits_clip = x$limits$limits_clip) + # Reset the zones, but save the created layer + l <- list("layer" = zones, "limits_method" = x$limits$limits_method, + "mcp_buffer" = x$limits$mcp_buffer, + "limits_clip" = x$limits$limits_clip) + settings$set("limits", l) + x <- x$set_limits(x = l) rm(zones) } @@ -1411,9 +1467,11 @@ methods::setMethod( if(getOption('ibis.setupmessages')) myLog('[Done]','green',paste0('Completed after ', round( as.numeric(out$settings$duration()), 2),' ',attr(out$settings$duration(),'units') )) # Clip to limits again to be sure - if(!is.Waiver(x$limits)) { + if(!is.Waiver(x$get_limits())) { if(settings$get('inference_only')==FALSE){ - out <- out$set_data("prediction", terra::mask(out$get_data("prediction"), x$limits$layer)) + out <- out$set_data("prediction", + terra::mask(out$get_data("prediction"), + settings$get("limits")$layer)) } out$settings$set("has_limits", TRUE) } else { diff --git a/R/zzz.R b/R/zzz.R index 312d9bce..8869688b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -39,9 +39,9 @@ "pdp", "scales", "biscale", "modEvA", "dplyr", "geodist", "geosphere", "progress", "glmnet", "glmnetUtils", "xgboost","BoomSpikeSlab", "INLA", "inlabru", "gnlm", "cubelyr", "matrixStats", "Boruta", "abess", - "dbarts", "mboost", "rstan", "cmdstanr", + "dbarts", "mboost", "rstan", "cmdstanr", "biscale", # Mechanistic stuff - "poems" + "poems", "BiocManager" )) # Set default corrrelation coefficient threshold for evaluating correlated diff --git a/_pkgdown.yml b/_pkgdown.yml index a1d0e76f..ef8bb076 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -79,6 +79,7 @@ reference: - starts_with("sel_") - starts_with("rm_") - starts_with("get_") + - has_keyword("control") - title: Engines diff --git a/man/add_control_bias.Rd b/man/add_control_bias.Rd index 94b62833..aedc61c8 100644 --- a/man/add_control_bias.Rd +++ b/man/add_control_bias.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/add_control_bias.R \name{add_control_bias} \alias{add_control_bias} -\title{Add a specified variable which should be controlled for somehow.} +\title{Add a control to a BiodiversityModel object to control biases} \usage{ add_control_bias( x, @@ -58,10 +58,11 @@ methods are: control the biases in a model, by including a specified variable ("layer") in the model, but "partialling" it out during the projection phase. Specifically the variable is set to a specified value ("bias_value"), which is by default -the minimum value observed across the background. \link{*} \code{"offset"} - Dummy +the minimum value observed across the background. +\link{*} \code{"offset"} - Dummy method that points to the \code{\link[=add_offset_bias]{add_offset_bias()}} functionality (see note). -Makes use of offsets to factor out a specified bias variable. \link{*} -\code{"proximity"} - Use the proximity or distance between points as a weight +Makes use of offsets to factor out a specified bias variable. +\link{*} \code{"proximity"} - Use the proximity or distance between points as a weight in the model. This option effectively places greater weight on points farther away. \emph{Note:} In the best case this can control for spatial bias and aggregation, in the worst case it can place a lot of emphasis on points that @@ -105,7 +106,11 @@ through the \code{\link[=add_offset_bias]{add_offset_bias()}} method. Setting th \item Botella, C., Joly, A., Bonnet, P., Munoz, F., & Monestiez, P. (2021). Jointly 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{ +\code{\link[=add_control_extrapolation]{add_control_extrapolation()}} +} \concept{The spatial bias weighting was inspired by code in the \code{enmSdmX} package.} \keyword{bias,} -\keyword{offset} +\keyword{control} +\keyword{offset,} diff --git a/man/add_control_extrapolation.Rd b/man/add_control_extrapolation.Rd new file mode 100644 index 00000000..fd1c0b31 --- /dev/null +++ b/man/add_control_extrapolation.Rd @@ -0,0 +1,109 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_control_extrapolation.R +\name{add_control_extrapolation} +\alias{add_control_extrapolation} +\title{Add a control to a BiodiversityModel object to control extrapolation} +\usage{ +add_control_extrapolation( + x, + layer, + method = "mcp", + mcp_buffer = 0, + novel = "within", + limits_clip = FALSE +) + +\S4method{add_control_extrapolation}{BiodiversityDistribution,SpatRaster,character,numeric,character,logical}(x,layer,method,mcp_buffer,novel,limits_clip) +} +\arguments{ +\item{x}{\code{\link[=distribution]{distribution()}} (i.e. \code{\linkS4class{BiodiversityDistribution}}) object.} + +\item{layer}{A \code{\link{SpatRaster}} or \code{\link{sf}} object that limits the prediction +surface when intersected with input data (Default: \code{NULL}).} + +\item{method}{A \code{\link{character}} vector describing the method used for controlling +extrapolation. Available options are \code{"zones"}, \code{"mcp"} (Default), +or \code{"nt2"} or \code{"shape"}.} + +\item{mcp_buffer}{A \code{\link{numeric}} distance to buffer the mcp (Default +\code{0}). Only used if \code{"mcp"} is used.} + +\item{novel}{Which conditions are to be masked out respectively, either the +novel conditions within only \code{"within"} (Default) or also including outside +reference conditions \code{"outside"}. Only use for \code{method = "nt2"}, for +\code{method = "mess"} this variable is always \code{"within"}.} + +\item{limits_clip}{\code{\link{logical}} Should the limits clip all predictors before +fitting a model (\code{TRUE}) or just the prediction (\code{FALSE}, +default).} +} +\value{ +Adds extrapolation control option to a \code{\link{distribution}} object. +} +\description{ +One of the main aims of species distribution models (SDMs) is to project +in space and time. For projections a common issue is extrapolation as - unconstrained - +SDMs can indicate areas as suitable which are unlikely to be occupied by species +or habitats (often due to historic or biotic factors). To some extent this can +be related to an insufficient quantification of the niche (e.g. niche truncation +by considering only a subset of observations within the actual distribution), +in other cases there can also be general barriers or constraints that limit +any projections (e.g. islands). This control method adds some of those options +to a model distribution object. Currently supported methods are: + +\link{*} \code{"zones"} - This is a wrapper to allow the addition of zones to a +distribution model object, similar to what is also possible via \code{\link[=distribution]{distribution()}}. +Required is a spatial layer that describes a environmental zoning. + +\link{*} \code{"mcp"} - Rather than using an external or additional layer, this option constraints +predictions by a certain distance of points in its vicinity. Buffer distances +have to be in the unit of the projection used and can be configured via +\code{"mcp_buffer"}. + +\link{*} \code{"nt2"} - Constraints the predictions using the multivariate combination novelty index (NT2) +following Mesgaran et al. (2014). This method is also available in the \code{\link[=similarity]{similarity()}} +function. + +\link{*} \code{"shape"} - This is an implementation of the 'shape' method introduced +by Velazco et al. (2023). Through a user defined threshold it effectively limits +model extrapolation so that no projections are made beyond the extent judged as +defensible and informed by the training observations. + +See also details for further explanations. +} +\details{ +For method \code{"zones"} a zoning layer can be supplied which is then used to intersect +the provided training points with. Any projections made with the model can +then be constrained so as to not project into areas that do not consider any +training points and are unlikely to have any. Examples for zones are for the +separation of islands and mainlands, biomes, or lithological soil conditions. + +If no layer is available, it is also possible to constraint predictions by the +distance to a minimum convex polygon surrounding the training points with +method \code{"mcp"} (optionally buffered). This can make sense particular for +rare species or those fully sampled across their niche. + +For the \code{"NT2"} and \code{"MESS"} index it is possible to constrain +the prediction to conditions within (\code{novel = "within"}) or also include +outside (\code{novel = "outside"}) conditions. +} +\note{ +The method \code{"zones"} is also possible directly within \code{\link[=distribution]{distribution()}}. +} +\examples{ +\dontrun{ + # To add a zone layer for extrapolation constraints. + x <- distribution(background) |> + add_predictors(covariates) |> + add_control_extrapolation(method = "zones", layer = zones) +} +} +\references{ +\itemize{ +\item Randin, C. F., Dirnböck, T., Dullinger, S., Zimmermann, N. E., Zappa, M., & Guisan, A. (2006). Are niche‐based species distribution models transferable in space?. Journal of biogeography, 33(10), 1689-1703. https://doi.org/10.1111/j.1365-2699.2006.01466.x +\item Chevalier, M., Broennimann, O., Cornuault, J., & Guisan, A. (2021). Data integration methods to account for spatial niche truncation effects in regional projections of species distribution. Ecological Applications, 31(7), e02427. https://doi.org/10.1002/eap.2427 +\item Velazco, S. J. E., Brooke, M. R., De Marco Jr., P., Regan, H. M., & Franklin, J. (2023). How far can I extrapolate my species distribution model? Exploring Shape, a novel method. Ecography, 11, e06992. https://doi.org/10.1111/ecog.06992 +\item Mesgaran, M. B., R. D. Cousens, B. L. Webber, and J. Franklin. (2014) Here be dragons: a tool for quantifying novelty due to covariate range and correlation change when projecting species distribution models. Diversity and Distributions 20:1147-1159. +} +} +\keyword{control} diff --git a/man/mask.Rd b/man/mask.Rd index 273bdaee..998fc414 100644 --- a/man/mask.Rd +++ b/man/mask.Rd @@ -8,13 +8,13 @@ \alias{mask.BiodiversityScenario} \title{Mask data with an external layer} \usage{ -\method{mask}{DistributionModel}(x, mask, inverse = FALSE) +\method{mask}{DistributionModel}(x, mask, inverse = FALSE, ...) -\method{mask}{BiodiversityDatasetCollection}(x, mask, inverse = FALSE) +\method{mask}{BiodiversityDatasetCollection}(x, mask, inverse = FALSE, ...) -\method{mask}{PredictorDataset}(x, mask, inverse = FALSE) +\method{mask}{PredictorDataset}(x, mask, inverse = FALSE, ...) -\method{mask}{BiodiversityScenario}(x, mask, inverse = FALSE) +\method{mask}{BiodiversityScenario}(x, mask, inverse = FALSE, ...) } \arguments{ \item{x}{Any object belonging to \link{DistributionModel}, diff --git a/man/scenario.Rd b/man/scenario.Rd index fdb1b77c..bce816ff 100644 --- a/man/scenario.Rd +++ b/man/scenario.Rd @@ -4,9 +4,9 @@ \alias{scenario} \title{Create a new scenario based on trained model parameters} \usage{ -scenario(fit, limits = NULL, copy_model = FALSE) +scenario(fit, limits = NULL, reuse_limits = FALSE, copy_model = FALSE) -\S4method{scenario}{ANY,ANY,logical}(fit,limits,copy_model) +\S4method{scenario}{ANY,ANY,logical,logical}(fit,limits,reuse_limits,copy_model) } \arguments{ \item{fit}{A \code{\link{BiodiversityDistribution}} object containing a trained model.} @@ -16,6 +16,9 @@ surface when intersected with the prediction data (Default: \code{NULL}). This can for instance be set as an expert-delineated constrain to limit spatial projections.} +\item{reuse_limits}{A \code{\link{logical}} on whether to reuse limits if found in the +trained \code{\link{BiodiversityDistribution}} object (Default: \code{FALSE}). See also notes!} + \item{copy_model}{A \code{\link{logical}} of whether the model object is to be copied to the scenario object. Note that setting this option to \code{TRUE} can increase the required amount of memory (Default: \code{FALSE}).} @@ -24,6 +27,11 @@ increase the required amount of memory (Default: \code{FALSE}).} This function creates a new \linkS4class{BiodiversityScenario} object 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 +reused for the projections. \strong{Note: This effectively fixes the projections to certain areas.} +} \examples{ \dontrun{ scenario(fit, limits = island_area) diff --git a/tests/testthat/test_BiodiversityDistribution.R b/tests/testthat/test_BiodiversityDistribution.R index 381e0b60..130695be 100644 --- a/tests/testthat/test_BiodiversityDistribution.R +++ b/tests/testthat/test_BiodiversityDistribution.R @@ -71,7 +71,7 @@ test_that('Setting up a distribution model',{ expect_no_error(y <- x |> add_control_bias(predictors$hmi_mean_50km,method = "offset",bias_value = 0)) expect_equal(y$get_offset(),"hmi_mean_50km") expect_no_error(y <- x |> add_control_bias(method = "proximity",bias_value = 0)) - expect_length(y$bias$bias_value, 2) + expect_length(y$control$bias_value, 2) # Add Predictors x <- x |> add_predictors(predictors) diff --git a/tests/testthat/test_controls.R b/tests/testthat/test_controls.R new file mode 100644 index 00000000..038f5c45 --- /dev/null +++ b/tests/testthat/test_controls.R @@ -0,0 +1,78 @@ +# ---- # +# Train a full distribution model with glmnet +test_that('Test controls', { + + skip_if_not_installed('glmnet') + skip_on_travis() + skip_on_cran() + + suppressWarnings( requireNamespace('glmnet', quietly = TRUE) ) + + # No messages + options(ibis.setupmessages = FALSE) + + # 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) + virtual_range <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'range',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)) + + # Now set them one up step by step + x <- distribution(background) |> + add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', name = 'Virtual points') |> + add_predictors(predictors, transform = 'none',derivates = 'none') + + # Expect error + expect_error(x |> add_control_extrapolation(method = "nomethod")) + + # Add the various controls to see that they are working + zones <- terra::as.factor( predictors$koeppen_50km ) + y <- x |> add_control_extrapolation(layer = zones, method = "zones") + expect_false(y$get_limits() |> is.Waiver()) + + # Add mcp limits + y <- x |> add_control_extrapolation(method = "mcp") + expect_false(y$get_limits() |> is.Waiver()) + + # Add NT2 + y <- x |> add_control_extrapolation(method = "nt2") + expect_false(y$get_limits() |> is.Waiver()) + + # Add MESS + y <- x |> add_control_extrapolation(method = "mess") + expect_false(y$get_limits() |> is.Waiver()) + + # Train the model with limits set + x <- x |> add_control_extrapolation(layer = zones, method = "zones") + suppressWarnings( + mod <- train(x |> engine_glmnet(alpha = 1), "test", inference_only = FALSE, only_linear = TRUE, + varsel = "none", verbose = FALSE) + ) + + # Run a check (should work without errors at least) + expect_no_error( suppressMessages( check(mod) ) ) + + # Expect true + expect_true( mod$has_limits() ) + + # --- # + # Also try mess + x <- x$rm_limits() + x <- x |> add_control_extrapolation(method = "mess") + suppressWarnings( + mod <- train(x |> engine_glmnet(alpha = 1), "test", inference_only = FALSE, only_linear = TRUE, + varsel = "none", verbose = FALSE) + ) + + # Expect true + expect_true( mod$has_limits() ) + + # Create a scenario object and reuse limits + expect_no_error( scenario(mod, reuse_limits = TRUE) ) + +}) diff --git a/tests/testthat/test_rangesOffsets.R b/tests/testthat/test_rangesOffsets.R index e9fa0a9d..26a9cb9b 100644 --- a/tests/testthat/test_rangesOffsets.R +++ b/tests/testthat/test_rangesOffsets.R @@ -43,7 +43,7 @@ test_that('Load ranges and add them to distribution object', { # Add bias variable suppressWarnings( y <- x |> add_control_bias(layer = predictors$hmi_mean_50km,bias_value = 0) ) - expect_type(y$bias, 'list') - expect_length(y$get_biascontrol(), 3) + expect_type(y$control, 'list') + expect_length(y$get_control(), 4) }) From 00ae3d9f0252dff57920a46de1dd72f1a6e5ced5 Mon Sep 17 00:00:00 2001 From: Martin-Jung Date: Sat, 9 Dec 2023 17:55:40 +0000 Subject: [PATCH 08/20] Update CITATION.cff --- CITATION.cff | 1 + 1 file changed, 1 insertion(+) diff --git a/CITATION.cff b/CITATION.cff index 30251521..a60a2c3f 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -638,6 +638,7 @@ references: authors: - family-names: Csárdi given-names: Gábor + email: csardi.gabor@gmail.com - family-names: FitzJohn given-names: Rich year: '2023' From 43500e1e53b3a365c7699ef6267866631a034d00 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Mon, 11 Dec 2023 00:03:13 +0100 Subject: [PATCH 09/20] Addition of default glm() engine and adoption in tests --- DESCRIPTION | 1 + NAMESPACE | 1 + NEWS.md | 2 + R/bdproto-distributionmodel.R | 29 + R/engine_glm.R | 710 ++++++++++++++++++++ R/engine_glmnet.R | 12 +- R/train.R | 101 ++- R/utils-glmnet.R | 26 + R/zzz.R | 1 + man/engine_bart.Rd | 1 + man/engine_breg.Rd | 1 + man/engine_gdb.Rd | 1 + man/engine_glm.Rd | 64 ++ man/engine_glmnet.Rd | 3 +- man/engine_inla.Rd | 1 + man/engine_inlabru.Rd | 1 + man/engine_stan.Rd | 1 + man/engine_xgboost.Rd | 1 + man/train.Rd | 2 +- tests/testthat/test_controls.R | 7 +- tests/testthat/test_modelFits.R | 38 +- tests/testthat/test_objectinheritance.R | 9 +- tests/testthat/test_priors.R | 2 +- tests/testthat/test_rangesOffsets.R | 47 +- vignettes/articles/06_engine_comparison.Rmd | 3 +- 25 files changed, 1015 insertions(+), 50 deletions(-) create mode 100644 R/engine_glm.R create mode 100644 man/engine_glm.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 36c32d89..7586cb7d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -116,6 +116,7 @@ Collate: 'engine_bart.R' 'engine_breg.R' 'engine_gdb.R' + 'engine_glm.R' 'engine_glmnet.R' 'utils-inla.R' 'engine_inla.R' diff --git a/NAMESPACE b/NAMESPACE index c9a0ec49..8c3d896c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -96,6 +96,7 @@ export(emptyraster) export(engine_bart) export(engine_breg) export(engine_gdb) +export(engine_glm) export(engine_glmnet) export(engine_inla) export(engine_inlabru) diff --git a/NEWS.md b/NEWS.md index 19868ebd..efb71191 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,11 @@ # ibis.iSDM 0.1.1 (current dev branch) #### New features +* Added default `engine_glm()` for dependency-free inference and projection. * Harmonized controls settings and added option to contrain extrapolation `add_control_extrapolation()` #### Minor improvements and bug fixes +* Switch to `engine_glm()` in many of the unittests for better coverage. * Several bug fixes and improvements in `thin_observations` * `global`, `probs`, and `centers` argument for better control of `thin_observations` * Harmonization of parameters for `spartial()` and addressing #80 diff --git a/R/bdproto-distributionmodel.R b/R/bdproto-distributionmodel.R index 6e9e689c..df0488f6 100644 --- a/R/bdproto-distributionmodel.R +++ b/R/bdproto-distributionmodel.R @@ -160,6 +160,25 @@ DistributionModel <- bdproto( "") )) + } else if(inherits(self, 'GLM-Model')) { + obj <- self$get_data('fit_best') + + # Summarise coefficients within 1 standard deviation + ms <- tidy_glm_summary(obj) + + message(paste0( + 'Trained ',class(self)[1],' (',self$show(),')', + '\n \033[1mStrongest summary effects:\033[22m', + '\n \033[34mPositive:\033[39m ', name_atomic(ms$variable[ms$mean>0]), + '\n \033[31mNegative:\033[39m ', name_atomic(ms$variable[ms$mean<0]), + ifelse(has_prediction, + paste0("\n Prediction fitted: ",text_green("yes")), + ""), + ifelse(!is.na(has_threshold), + paste0("\n Threshold created: ",text_green("yes")), + "") + )) + } else { message(paste0( 'Trained distribution model (',self$show(),')', @@ -267,6 +286,8 @@ DistributionModel <- bdproto( xgboost::xgb.importance(model = self$get_data(obj)) } else if(inherits(self, 'GLMNET-Model')){ tidy_glmnet_summary(self$get_data(obj)) + } else if(inherits(self, 'GLM-Model')){ + tidy_glm_summary(self$get_data(obj)) } }, # Model convergence check @@ -302,6 +323,14 @@ DistributionModel <- bdproto( } else if(inherits(self, 'INLA-Model')) { plot_inla_marginals(self$get_data(x),what = what) } else if(inherits(self, 'GLMNET-Model')) { + if(what == "fixed"){ + ms <- tidy_glm_summary(mod) + graphics::dotchart(ms$mean, + labels = ms$variable, + frame.plot = FALSE, + color = "grey20") + } else{ plot(self$get_data(x)) } + } else if(inherits(self, 'GLM-Model')) { if(what == "fixed"){ glmnet:::plot.glmnet(self$get_data(x)$glmnet.fit, xvar = "lambda") # Deviance explained } else{ plot(self$get_data(x)) } diff --git a/R/engine_glm.R b/R/engine_glm.R new file mode 100644 index 00000000..70859f11 --- /dev/null +++ b/R/engine_glm.R @@ -0,0 +1,710 @@ +#' @include bdproto-engine.R utils-spatial.R bdproto-distributionmodel.R +NULL + +#' Engine for Generalized linear models (GLM) +#' +#' @description +#' This engine implements a basic generalized linear modle (GLM) for creating +#' species distribution models. The main purpose of this engine is to support +#' a basic, dependency-free method for inference and projection that can be used +#' within the package for examples and vignettes. That being said, the engine is +#' fully functional as any other engine. +#' +#' The basic implementation of GLMs here is part of a general class oflinear models +#' and has - with exception of offsets - only minimal options to integrate other +#' sources of information such as priors or joint integration. The general +#' recommendation is to [engine_glmnet()] instead for regularization support. +#' However basic GLMs can in some cases be useful for quick projections or +#' for [ensemble()] of small models (a practice common for rare species). +#' +#' @details +#' This engine is essentially a wrapper for [stats::glm.fit()], however with customized +#' settings to support offsets and weights. +#' +#' @param x [distribution()] (i.e. [`BiodiversityDistribution-class`]) object. +#' @param control A [`list`] containing parameters for controlling the fitting +#' process (Default: \code{NULL}). +#' @param type The mode used for creating posterior predictions. Either making +#' \code{"link"} or \code{"response"} (Default: \code{"response"}). +#' @param ... Other parameters passed on to [stats::glm()]. +#' @references +#' * Hastie, T. J. and Pregibon, D. (1992) Generalized linear models. Chapter 6 of Statistical Models in S eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. +#' @family engine +#' @returns An [Engine]. +#' @aliases engine_glm +#' @examples +#' # Load background +#' background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) +#' +#' # Add GLM as an engine +#' x <- distribution(background) |> engine_glm() +#' x +#' @name engine_glm +NULL +#' @rdname engine_glm +#' @export + +engine_glm <- function(x, + control = NULL, + type = "response", + ...) { + + # Check whether package is available (Default installed) + check_package('stats') + + # assert that arguments are valid + assertthat::assert_that(inherits(x, "BiodiversityDistribution"), + inherits(x$background,'sf'), + is.null(control) || is.list(control), + is.character(type) + ) + type <- match.arg(type, choices = c("predictor","link", "response"),several.ok = FALSE) + if(type=="predictor") type <- "link" # Convenience conversion + + # Create a background raster + if(is.Waiver(x$predictors)){ + # Create from background + template <- terra::rast( + ext = terra::ext(x$background), + crs = terra::crs(x$background), + res = c(diff( (sf::st_bbox(x$background)[c(1,3)]) ) / 100, # Simplified assumption for resolution + diff( (sf::st_bbox(x$background)[c(1,3)]) ) / 100 + ) + ) + } else { + # If predictor existing, use them + template <- emptyraster(x$predictors$get_data() ) + } + + # Burn in the background + template <- terra::rasterize(x$background, template, field = 0) + + # Specify default control + if(is.null(control)){ + control <- stats::glm.control() + } + + # Set up the parameter list + params <- list( + control = control, + type = type, + ... + ) + + # Print a message in case there is already an engine object + if(!is.Waiver(x$engine)) myLog('[Setup]','yellow','Replacing currently selected engine.') + + # Set engine in distribution object + x$set_engine( + bdproto( + "GLM-Engine", + Engine, + name = "", + data = list( + 'template' = template, + 'params' = params + ), + # Dummy function for spatial latent effects + calc_latent_spatial = function(self, type = NULL, priors = NULL){ + new_waiver() + }, + # Dummy function for getting the equation of latent effects + get_equation_latent_spatial = function(self, method){ + new_waiver() + }, + # Function to respecify the control parameters + set_control = function(self, + params + ){ + assertthat::assert_that(is.list(params)) + # Overwrite existing + self$data$params <- params + invisible() + }, + # Setup function + setup = function(self, model, settings = NULL, ...){ + # Simple security checks + assertthat::assert_that( + assertthat::has_name(model, 'background'), + assertthat::has_name(model, 'biodiversity'), + inherits(settings,'Settings') || is.null(settings), + nrow(model$predictors) == terra::ncell(self$get_data('template')), + !is.Waiver(self$get_data("params")), + length(model$biodiversity) == 1 # Only works with single likelihood. To be processed separately + ) + # Messenger + if(getOption('ibis.setupmessages')) myLog('[Estimation]','green','Engine setup.') + + # Get parameters + params <- self$data$params + settings$set('type', params$type) + + # Distribution specific procedure + fam <- model$biodiversity[[1]]$family + form <- model$biodiversity[[1]]$equation + + # If a poisson family is used, weight the observations by their exposure + if(fam == "poisson"){ + # Get background layer + bg <- self$get_data("template") + assertthat::assert_that(!is.na( terra::global(bg, "min", na.rm = TRUE)[,1])) + + # Add pseudo-absence points + presabs <- add_pseudoabsence(df = model$biodiversity[[1]]$observations, + field_occurrence = 'observed', + template = bg, + settings = model$biodiversity[[1]]$pseudoabsence_settings) + if(inherits(presabs, 'sf')) presabs <- presabs |> sf::st_drop_geometry() + # Sample environmental points for absence only points + abs <- subset(presabs, observed == 0) + # Re-extract environmental information for absence points + envs <- get_rastervalue(coords = abs[,c('x','y')], + env = model$predictors_object$get_data(df = FALSE), + rm.na = FALSE) + if(assertthat::has_name(model$biodiversity[[1]]$predictors, "Intercept")){ envs$Intercept <- 1} + + # Format out + df <- rbind(model$biodiversity[[1]]$predictors[,c('x','y','Intercept', model$biodiversity[[1]]$predictors_names)], + envs[,c('x','y','Intercept', model$biodiversity[[1]]$predictors_names)] ) + any_missing <- which(apply(df, 1, function(x) any(is.na(x)))) + if(length(any_missing)>0) { + presabs <- presabs[-any_missing,] # This works as they are in the same order + model$biodiversity[[1]]$expect <- model$biodiversity[[1]]$expect[-any_missing] + } + df <- subset(df, stats::complete.cases(df)) + assertthat::assert_that(nrow(presabs) == nrow(df)) + + # Check that expect matches + if(length(model$biodiversity[[1]]$expect)!=nrow(df)){ + # Fill the absences with 1 as multiplier. This works since absences follow the presences + model$biodiversity[[1]]$expect <- c( model$biodiversity[[1]]$expect, + rep(1, nrow(presabs)-length(model$biodiversity[[1]]$expect) )) + } + + # Overwrite observation data + model$biodiversity[[1]]$observations <- presabs + + # Preprocessing security checks + assertthat::assert_that( all( model$biodiversity[[1]]$observations[['observed']] >= 0 ), + any(!is.na(presabs[['observed']])), + length(model$biodiversity[[1]]$expect) == nrow(model$biodiversity[[1]]$observations), + nrow(df) == nrow(model$biodiversity[[1]]$observations) + ) + + # Add offset if existent + if(!is.Waiver(model$offset)){ + ofs <- get_rastervalue(coords = df[,c('x','y')], + env = model$offset_object, + rm.na = FALSE) + # Rename to spatial offset + names(ofs)[which(names(ofs)==names(model$offset_object))] <- "spatial_offset" + model$biodiversity[[1]]$offset <- ofs + } + + # Define expectation as very small vector following Renner et al. + w <- ppm_weights(df = df, + pa = model$biodiversity[[1]]$observations[['observed']], + bg = bg, + weight = 1e-6, # Arbitrary small weight + type = "DWPR" # Weights for down-weighted Poisson regression + ) + assertthat::assert_that(length(w) == nrow(df)) + + model$biodiversity[[1]]$predictors <- df + model$biodiversity[[1]]$expect <- w * (1/model$biodiversity[[1]]$expect) # Multiply with prior weight + + # Rasterize observed presences + pres <- terra::rasterize( guess_sf(model$biodiversity[[1]]$observations[,c("x","y")]), + bg, fun = 'count', background = 0) + # Get for the full dataset + w_full <- ppm_weights(df = model$predictors, + pa = pres[], + bg = bg, + weight = 1 # Set those to 1 so that absences become ratio of pres/abs + ) + + # Add exposure to full model predictor + model$exposure <- w_full * (1/unique(model$biodiversity[[1]]$expect)[1]) # Multiply with prior weight (first value) + + } else if(fam == "binomial"){ + # Check that observations are all <=1 + model$biodiversity[[1]]$observations[['observed']] <- ifelse(model$biodiversity[[1]]$observations[['observed']]>=1,1,0) + # calculating the case weights (equal weights) + # the order of weights should be the same as presences and backgrounds in the training data + prNum <- as.numeric(table(model$biodiversity[[1]]$observations[['observed']])["1"]) # number of presences + bgNum <- as.numeric(table(model$biodiversity[[1]]$observations[['observed']])["0"]) # number of backgrounds + w <- ifelse(model$biodiversity[[1]]$observations[['observed']] == 1, 1, prNum / bgNum) + model$biodiversity[[1]]$expect <- w * model$biodiversity[[1]]$expect + model$biodiversity[[1]]$observations$observed <- as.factor( model$biodiversity[[1]]$observations$observed ) + } + + # Instead of invisible return the model object + return( model ) + }, + # Training function + train = function(self, model, settings, ...){ + assertthat::assert_that( + inherits(settings,'Settings'), + is.list(model),length(model)>1, + # Check that model id and setting id are identical + settings$modelid == model$id + ) + # Get name + name <- model$biodiversity[[1]]$name + + # Messenger + if(getOption('ibis.setupmessages')) myLog('[Estimation]','green',paste0('Starting fitting: ', name)) + + # Verbosity + verbose <- settings$get("verbose") + + # Set prediction type also for later + settings$set('type', self$get_data("params")$type) + + # seed + seed <- settings$get("seed") + if(is.Waiver(seed)) { settings$set('seed', getOption("ibis.seed")) } + + # Get output raster + prediction <- self$get_data('template') + + # Get parameters control + params <- self$get_data('params') + + # All other needed data for model fitting + fam <- model$biodiversity[[1]]$family + li <- model$biodiversity[[1]]$link + if(!is.null(li)){ + if(li %in% c("cloglog", "logit", "probit")){ + fam <- stats::binomial(link = li) + } else { + if(getOption('ibis.setupmessages')) myLog('[Estimation]','red',paste0("Custom link functions not supported!")) + } + } + + form <- model$biodiversity[[1]]$equation + df <- cbind(model$biodiversity[[1]]$predictors, + data.frame(observed = model$biodiversity[[1]]$observations[,'observed', drop = TRUE]) + ) + df <- subset(df, select = c(model$biodiversity[[1]]$predictors_names, "observed")) + w <- df$w <- model$biodiversity[[1]]$expect # The expected exposure + # Get full prediction container + full <- model$predictors + w_full <- model$exposure + + # Subset the predictor types to only those present + te <- formula_terms(form) + model$biodiversity[[1]]$predictors_types <- + model$biodiversity[[1]]$predictors_types |> dplyr::filter(predictors %in% te) + model$biodiversity[[1]]$predictors_names <- intersect(model$biodiversity[[1]]$predictors_names, te) + + # Get offset and add it to exposure + if(!is.Waiver(model$offset)){ + # Add offset to full prediction and load vector + ofs <- model$biodiversity[[1]]$offset[, 'spatial_offset'] + ofs_pred <- model$offset[,'spatial_offset'] + } else { ofs <- NULL; ofs_pred <- NULL } + + # Clamp? + if( settings$get("clamp") ) full <- clamp_predictions(model, full) + + # -- # + # Expand predictors if non-linear is specified in settings + if(settings$get('only_linear') == FALSE){ + if(getOption('ibis.setupmessages')) myLog('[Estimation]','yellow', + 'Non-linearity to glm is best introduced by adding derivates. Ignored!') + } + + assertthat::assert_that( + is.null(w) || length(w) == nrow(df), + is.null(ofs) || is.vector(ofs), + is.null(ofs_pred) || is.vector(ofs_pred), + 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 + if( (settings$get('optim_hyperparam')) ){ + if(getOption('ibis.setupmessages')) myLog('[Estimation]','yellow', + 'No hyperparameter optimization for glm implemented!') + } else { + if(!is.null(ofs)){ + # Split since GLM cannot handle NULL offsets + suppressWarnings( + fit_glm <- try({ + stats::glm(formula = form, + data = df, + weights = w, # Case weights + offset = ofs, + family = fam, + na.action = "na.pass", + control = params$control + ) + },silent = FALSE) + ) + } else { + 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!") + + # --- # + # Predict spatially + if(!settings$get('inference_only')){ + # Messenger + if(getOption('ibis.setupmessages')) myLog('[Estimation]','green','Starting prediction...') + # Set target variables to bias_value for prediction if specified + if(!is.Waiver(settings$get('bias_variable'))){ + for(i in 1:length(settings$get('bias_variable'))){ + if(settings$get('bias_variable')[i] %notin% names(full)){ + if(getOption('ibis.setupmessages')) myLog('[Estimation]','red','Did not find bias variable in prediction object!') + next() + } + full[[settings$get('bias_variable')[i]]] <- settings$get('bias_value')[i] + } + } + # 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 + ) + },silent = TRUE) + if(!inherits(out,"try-error")){ + # Fill output with summaries of the posterior + prediction <- fill_rasters(out |> as.data.frame(), + background = prediction)[[1:2]] + names(prediction) <- c("mean", "se") + prediction <- terra::mask(prediction, self$get_data("template")) + + } else { + stop("GLM prediction failed!") + } + try({rm(out, full, full_sub)},silent = TRUE) + } else { + # No prediction done + prediction <- NULL + } + # Compute end of computation time + settings$set('end.time', Sys.time()) + + # Definition of GLMNET Model object ---- + # Create output + out <- bdproto( + "GLM-Model", + DistributionModel, + id = model$id, + model = model, + settings = settings, + fits = list( + "fit_best" = fit_glm, + "fit_best_equation" = form, + "prediction" = prediction + ), + # Partial effects + partial = function(self, x.var = NULL, constant = NULL, variable_length = 100, + values = NULL, newdata = NULL, plot = FALSE, type = NULL, ...){ + assertthat::assert_that(is.character(x.var) || is.null(x.var), + is.null(constant) || is.numeric(constant), + is.null(type) || is.character(type), + is.null(newdata) || is.data.frame(newdata), + is.numeric(variable_length) + ) + # Settings + settings <- self$settings + + mod <- self$get_data('fit_best') + model <- self$model + co <- stats::coefficients(mod) |> names() # Get model coefficient names + # Set type + if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) + + # Get data + df <- model$biodiversity[[length( model$biodiversity )]]$predictors + + # Match x.var to argument + if(is.null(x.var)){ + x.var <- colnames(df) + } else { + x.var <- match.arg(x.var, names(df), several.ok = FALSE) + } + + # Calculate range of predictors + if(any(model$predictors_types$type=="factor")){ + rr <- sapply(df[model$predictors_types$predictors[model$predictors_types$type=="numeric"]], + function(x) range(x, na.rm = TRUE)) |> as.data.frame() + } else { + rr <- sapply(df, function(x) range(x, na.rm = TRUE)) |> as.data.frame() + } + + if(is.null(newdata)){ + # if values are set, make sure that they cover the data.frame + if(!is.null(values)){ + assertthat::assert_that(length(x.var) == 1) + df2 <- list() + df2[[x.var]] <- values + # Then add the others + for(var in colnames(df)){ + if(var == x.var) next() + df2[[var]] <- mean(df[[var]], na.rm = TRUE) + } + df2 <- df2 |> as.data.frame() + } else { + df2 <- list() + for(i in x.var) { + df2[[i]] <- as.data.frame(seq(rr[1,i],rr[2,i], length.out = variable_length)) + } + df2 <- do.call(cbind, df2); names(df2) <- x.var + } + } else { + # Assume all variables are present + df2 <- newdata |> dplyr::select(dplyr::any_of(names(df))) + assertthat::assert_that(nrow(df2)>1, ncol(df2)>1) + } + + # Get offset if set + if(!is.Waiver(model$offset)){ + of <- model$offset$spatial_offset + } else of <- new_waiver() + + # Check that variables are in + assertthat::assert_that(all( x.var %in% colnames(df) ), + msg = 'Variable not in predicted model.') + + # Inverse link function + ilf <- switch (settings$get('type'), + "link" = NULL, + "response" = ifelse(model$biodiversity[[1]]$family=='poisson', + exp, logistic) + ) + + pp <- data.frame() + pb <- progress::progress_bar$new(total = length(x.var)) + for(v in x.var){ + if(!is.Waiver(of)){ + # Predict with offset + p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, + ice = FALSE, center = FALSE, + type = "regression", newoffset = of, + inv.link = ilf, + plot = FALSE, rug = TRUE, train = df) + } else { + p1 <- pdp::partial(mod, pred.var = v, pred.grid = df2, + ice = FALSE, center = FALSE, + type = "regression", inv.link = ilf, + plot = FALSE, rug = TRUE, train = df + ) + } + p1 <- p1[,c(v, "yhat")] + names(p1) <- c("partial_effect", "mean") + p1$variable <- v + pp <- rbind(pp, p1) + rm(p1) + if(length(x.var) > 1) pb$tick() + } + + if(plot){ + # Make a plot + g <- ggplot2::ggplot(data = pp, ggplot2::aes(x = partial_effect, y = mean)) + + ggplot2::theme_classic(base_size = 18) + + ggplot2::geom_line() + + ggplot2::labs(x = "", y = expression(hat(y))) + + ggplot2::facet_wrap(~variable,scales = 'free') + print(g) + } + return(pp) + }, + # Spatial partial dependence plot + spartial = function(self, x.var, constant = NULL, newdata = NULL, plot = TRUE, type = NULL){ + assertthat::assert_that(is.character(x.var), + "model" %in% names(self), + is.null(constant) || is.numeric(constant), + is.null(newdata) || is.data.frame(newdata), + is.logical(plot), + is.character(type) || is.null(type) + ) + # Settings + settings <- self$settings + # Set type + if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) + + mod <- self$get_data('fit_best') + model <- self$model + # For Integrated model, take the last one + fam <- model$biodiversity[[length(model$biodiversity)]]$family + + # If new data is set + if(!is.null(newdata)){ + df <- newdata + } else { + df <- model$predictors + df$w <- model$exposure + } + assertthat::assert_that(all(x.var %in% colnames(df))) + df$rowid <- 1:nrow(df) + # Match x.var to argument + x.var <- match.arg(x.var, names(df), several.ok = FALSE) + + # Add all others as constant + if(is.null(constant)){ + for(n in names(df)) if(!n %in% c(x.var, "rowid", "w")) df[[n]] <- suppressWarnings( mean(model$predictors[[n]], na.rm = TRUE) ) + } else { + for(n in names(df)) if(!n %in% c(x.var, "rowid", "w")) df[[n]] <- constant + } + # Reclassify factor levels + if(any(model$predictors_types$type=="factor")){ + lvl <- levels(model$predictors[[model$predictors_types$predictors[model$predictors_types$type=="factor"]]]) + df[[model$predictors_types$predictors[model$predictors_types$type=="factor"]]] <- + factor(lvl[1], levels = lvl) + } + + # Predict + 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() + assertthat::assert_that(nrow(pred_glm)>0, nrow(pred_glm) == nrow(df)) + + # Now create spatial prediction + prediction <- fill_rasters(pred_glm, model_to_background(model)) + names(prediction) <- paste0("spartial_",x.var) + + # Do plot and return result + if(plot) terra::plot(prediction, col = ibis_colours$ohsu_palette) + return(prediction) + }, + # Convergence check + has_converged = function(self){ + obj <- self$get_data("fit_best") + return( obj$converged ) + }, + # Residual function + get_residuals = function(self, type = NULL){ + # Get best object + obj <- self$get_data("fit_best") + if(is.Waiver(obj)) return(obj) + settings <- self$settings + if(is.null(type)) type <- settings$get('type') + # Calculate residuals + rd <- stats::residuals.glm(obj, type = type) + return(rd) + }, + # Get coefficients from glmnet + get_coefficients = function(self){ + # Returns a vector of the coefficients with direction/importance + obj <- self$get_data("fit_best") + cofs <- tidy_glm_summary(obj) + names(cofs)[1:2] <- c("Feature", "Beta") + return(cofs) + }, + # Engine-specific projection function + project = function(self, newdata, type = NULL, layer = "mean"){ + assertthat::assert_that("model" %in% names(self), + nrow(newdata) > 0, + all( c("x", "y") %in% names(newdata) ), + is.character(type) || is.null(type) + ) + + # Settings + settings <- self$settings + # Set type + if(is.null(type)) type <- self$settings$get("type") + type <- match.arg(type, c("link", "response"), several.ok = FALSE) + settings$set("type", type) + + mod <- self$get_data('fit_best') + model <- self$model + # For Integrated model, take the last one + fam <- model$biodiversity[[length(model$biodiversity)]]$family + + # Clamp? + if( settings$get("clamp") ) newdata <- clamp_predictions(model, newdata) + + # Set target variables to bias_value for prediction if specified + if(!is.Waiver(settings$get('bias_variable'))){ + for(i in 1:length(settings$get('bias_variable'))){ + if(settings$get('bias_variable')[i] %notin% names(newdata)){ + if(getOption('ibis.setupmessages')) myLog('[Estimation]','red','Did not find bias variable in prediction object!') + next() + } + newdata[[settings$get('bias_variable')[i]]] <- settings$get('bias_value')[i] + } + } + + df <- newdata + df$w <- model$exposure # Also get exposure variable + df$rowid <- 1:nrow(df) + 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() + } 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)) + + # Now create spatial prediction + prediction <- fill_rasters(pred_glm, + model_to_background(model) + ) + + return(prediction) + } + ) + return(out) + } + ) + ) # End of bdproto object +} # End of function diff --git a/R/engine_glmnet.R b/R/engine_glmnet.R index 3833e1b7..2f7485e3 100644 --- a/R/engine_glmnet.R +++ b/R/engine_glmnet.R @@ -50,7 +50,7 @@ NULL #' @aliases engine_glmnet #' @examples #' \dontrun{ -#' # Add BREG as an engine +#' # Add GLMNET as an engine #' x <- distribution(background) |> engine_glmnet(iter = 1000) #' } #' @name engine_glmnet @@ -298,7 +298,7 @@ engine_glmnet <- function(x, # seed seed <- settings$get("seed") - if(is.Waiver(seed)) { seed <- 1337; settings$set('seed', 1337) } + if(is.Waiver(seed)) { settings$set('seed', getOption("ibis.seed")) } # Get output raster prediction <- self$get_data('template') @@ -833,13 +833,7 @@ engine_glmnet <- function(x, assertthat::assert_that(nrow(pred_gn)>0, nrow(pred_gn) == nrow(df_sub)) # Now create spatial prediction - prediction <- try({emptyraster( model$predictors_object$get_data()[[1]] )},silent = TRUE) # Background - if(inherits(prediction, "try-error")){ - prediction <- terra::rast(model$predictors[,c("x", "y")], crs = terra::crs(model$background),type = "xyz") |> - emptyraster() - } - # sf::st_as_sf(df_sub, coords = c("x","y") ) - # terra::values(prediction) <- pred_gn[, layer] + prediction <- model_to_background(model) prediction[df_sub$rowid] <- pred_gn[, layer] return(prediction) diff --git a/R/train.R b/R/train.R index bcc942c5..d6bf6290 100644 --- a/R/train.R +++ b/R/train.R @@ -117,7 +117,7 @@ NULL #' * Zhu, J., Wen, C., Zhu, J., Zhang, H., & Wang, X. (2020). A polynomial algorithm for best-subset selection problem. Proceedings of the National Academy of Sciences, 117(52), 33117-33123. #' * Leung, B., Hudgins, E. J., Potapova, A. & Ruiz‐Jaen, M. C. A new baseline for countrywide α‐diversity and species distributions: illustration using >6,000 plant species in Panama. Ecol. Appl. 29, 1–13 (2019). #' @seealso [engine_gdb], [engine_xgboost], [engine_bart], [engine_inla], -#' [engine_inlabru], [engine_breg], [engine_stan] +#' [engine_inlabru], [engine_breg], [engine_stan], [engine_glm] #' @returns A [DistributionModel] object. #' @examples #' \dontrun{ @@ -1458,8 +1458,103 @@ methods::setMethod( model$priors <- po } } # End of multiple ides - } - # End of GLMNET engine + } # End of GLMNET engine + } else if (inherits(x$engine,"GLM-Engine") ){ + # ----------------------------------------------------------- # + if(method_integration == "prior") warning("Priors not supported for GLM!") + #### GLM Engine #### + # For each formula, process in sequence + for(id in ids){ + + # We use the same function as for glmnet here + model$biodiversity[[id]]$equation <- built_formula_glmnet( model$biodiversity[[id]] ) + + # Remove those not part of the modelling + model2 <- model + model2$biodiversity <- NULL; model2$biodiversity[[id]] <- model$biodiversity[[id]] + + # Run the engine setup script + model2 <- x$engine$setup(model2, settings) + + # Now train the model and create a predicted distribution model + settings2 <- settings + if(id != ids[length(ids)]){ + # For predictors and offsets + settings2$set('inference_only', FALSE) + } else { + settings2$set('inference_only', inference_only) + } + out <- x$engine$train(model2, settings2) + + # Add Prediction of model to next object if multiple are supplied + if(length(ids)>1 && id != ids[length(ids)]){ + if(method_integration == "predictor"){ + # Add to predictors frame + new <- out$get_data("prediction")[["mean"]] + pred_name <- paste0(model$biodiversity[[id]]$type, "_", make.names(model$biodiversity[[id]]$name),"_mean") + names(new) <- pred_name + # Add the object to the overall prediction object + model$predictors_object$data <- c(model$predictors_object$get_data(), new) + + # Now for each biodiversity dataset and the overall predictors + # extract and add as variable + for(k in names(model$biodiversity)){ + env <- get_rastervalue(coords = guess_sf( model$biodiversity[[k]]$observations[,c('x','y')]), + env = new) + env <- env[names(new)] + # Add + model$biodiversity[[k]]$predictors <- cbind(model$biodiversity[[k]]$predictors, env) + model$biodiversity[[k]]$predictors_names <- c(model$biodiversity[[k]]$predictors_names, + names(env) ) + model$biodiversity[[k]]$predictors_types <- rbind( + model$biodiversity[[k]]$predictors_types, + data.frame(predictors = names(env), type = c('numeric')) + ) + } + # Add to overall predictors + model$predictors <- cbind(model$predictors, as.data.frame(new, na.rm = FALSE)) + model$predictors_names <- c(model$predictors_names, names(new)) + model$predictors_types <- rbind(model$predictors_types, + data.frame(predictors = names(new), type = c('numeric'))) + + # Finally if custom formula found, add the variable there. + for(other_id in names(model$biodiversity)){ + if(other_id == id) next() # Skip if current id + ff <- model$biodiversity[[other_id]]$equation + if(is.formula(ff)){ + ff <- stats::update.formula(ff, paste0("~ . + ", pred_name)) + model$biodiversity[[other_id]]$equation <- ff + } # Else skip + } + + } else if(method_integration == "offset"){ + # Adding the prediction as offset + new <- out$get_data("prediction") + # Back transforming offset to linear scale + new[] <- switch (model$biodiversity[[id]]$family, + "binomial" = ilink(new[], link = "logit"), + "poisson" = ilink(new[], link = "log") + ) + if(is.Waiver(model$offset)){ + ofs <- terra::as.data.frame(new, xy = TRUE, na.rm = FALSE) + names(ofs)[which(names(ofs)==names(new))] <- "spatial_offset" + model[['offset']] <- ofs + # Also add offset object for faster extraction + model[['offset_object']] <- new + } else { + # New offset + news <- sum( model[['offset_object']], new, na.rm = TRUE) + news <- terra::mask(news, x$background) + model[['offset_object']] <- news + ofs <- terra::as.data.frame(news, xy = TRUE, na.rm = FALSE) + names(ofs)[which(names(ofs)=="layer")] <- "spatial_offset" + model[['offset']] <- ofs + rm(news) + } + rm(new) + } + } # End of multiple ides + } # End of GLM engine } else { stop('Specified Engine not implemented yet.') } if(is.null(out)) return(NULL) diff --git a/R/utils-glmnet.R b/R/utils-glmnet.R index acb7470e..f1a64df6 100644 --- a/R/utils-glmnet.R +++ b/R/utils-glmnet.R @@ -178,3 +178,29 @@ tidy_glmnet_summary <- function(obj){ } return(ms) } + +#' Tidy GLM summary +#' +#' @description This helper function summarizes the coefficients from a glm +#' model. +#' @param obj An object created with [stats::glm.fit()] +#' @keywords internal, utils +#' @noRd +tidy_glm_summary <- function(obj){ + assertthat::assert_that( + inherits(obj, 'glm') + ) + + # Summarize + ms <- stats::summary.glm(obj)$coefficients |> + as.data.frame() |> + tibble::rownames_to_column(var = "variable") + + # Remove intercept + int <- grep("Intercept",ms$variable,ignore.case = TRUE) + if(length(int)>0) ms <- ms[-int,] + + # Rename the estimate and std.error column + ms <- ms |> dplyr::rename(mean = "Estimate", se = "Std. Error") + return(ms) +} diff --git a/R/zzz.R b/R/zzz.R index 8869688b..bfdd2a2f 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -22,6 +22,7 @@ # Known engines options('ibis.engines' = c('GDB-Model','BART-Model', 'INLABRU-Model','BREG-Model','GLMNET-Model', + 'GLM-Model', 'INLA-Model','STAN-Model','XGBOOST-Model')) # Names of priors options('ibis.priors' = c('INLAPrior', 'BARTPrior', 'GDBPrior','GLMNETPrior', diff --git a/man/engine_bart.Rd b/man/engine_bart.Rd index aa72f263..570b4fa1 100644 --- a/man/engine_bart.Rd +++ b/man/engine_bart.Rd @@ -65,6 +65,7 @@ Other engine: \code{\link{engine_breg}()}, \code{\link{engine_gdb}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_inla}()}, \code{\link{engine_stan}()}, diff --git a/man/engine_breg.Rd b/man/engine_breg.Rd index 633cae83..ffee3a54 100644 --- a/man/engine_breg.Rd +++ b/man/engine_breg.Rd @@ -58,6 +58,7 @@ Other engine: \code{\link{engine_bart}()}, \code{\link{engine_gdb}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_inla}()}, \code{\link{engine_stan}()}, diff --git a/man/engine_gdb.Rd b/man/engine_gdb.Rd index 2e415dd0..0f523727 100644 --- a/man/engine_gdb.Rd +++ b/man/engine_gdb.Rd @@ -73,6 +73,7 @@ Other engine: \code{\link{engine_bart}()}, \code{\link{engine_breg}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_inla}()}, \code{\link{engine_stan}()}, diff --git a/man/engine_glm.Rd b/man/engine_glm.Rd new file mode 100644 index 00000000..5117a801 --- /dev/null +++ b/man/engine_glm.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/engine_glm.R +\name{engine_glm} +\alias{engine_glm} +\title{Engine for Generalized linear models (GLM)} +\usage{ +engine_glm(x, control = NULL, type = "response", ...) +} +\arguments{ +\item{x}{\code{\link[=distribution]{distribution()}} (i.e. \code{\linkS4class{BiodiversityDistribution}}) object.} + +\item{control}{A \code{\link{list}} containing parameters for controlling the fitting +process (Default: \code{NULL}).} + +\item{type}{The mode used for creating posterior predictions. Either making +\code{"link"} or \code{"response"} (Default: \code{"response"}).} + +\item{...}{Other parameters passed on to \code{\link[stats:glm]{stats::glm()}}.} +} +\value{ +An \link{Engine}. +} +\description{ +This engine implements a basic generalized linear modle (GLM) for creating +species distribution models. The main purpose of this engine is to support +a basic, dependency-free method for inference and projection that can be used +within the package for examples and vignettes. That being said, the engine is +fully functional as any other engine. + +The basic implementation of GLMs here is part of a general class oflinear models +and has - with exception of offsets - only minimal options to integrate other +sources of information such as priors or joint integration. The general +recommendation is to \code{\link[=engine_glmnet]{engine_glmnet()}} instead for regularization support. +However basic GLMs can in some cases be useful for quick projections or +for \code{\link[=ensemble]{ensemble()}} of small models (a practice common for rare species). +} +\details{ +This engine is essentially a wrapper for \code{\link[stats:glm]{stats::glm.fit()}}, however with customized +settings to support offsets and weights. +} +\examples{ +# Load background +background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) +# Add GLM as an engine +x <- distribution(background) |> engine_glm() +x +} +\references{ +\itemize{ +\item Hastie, T. J. and Pregibon, D. (1992) Generalized linear models. Chapter 6 of Statistical Models in S eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. +} +} +\seealso{ +Other engine: +\code{\link{engine_bart}()}, +\code{\link{engine_breg}()}, +\code{\link{engine_gdb}()}, +\code{\link{engine_glmnet}()}, +\code{\link{engine_inlabru}()}, +\code{\link{engine_inla}()}, +\code{\link{engine_stan}()}, +\code{\link{engine_xgboost}()} +} +\concept{engine} diff --git a/man/engine_glmnet.Rd b/man/engine_glmnet.Rd index 2b465ca3..46ec1c57 100644 --- a/man/engine_glmnet.Rd +++ b/man/engine_glmnet.Rd @@ -67,7 +67,7 @@ determined via cross-validation. For this option set \code{"varsel"} in } \examples{ \dontrun{ -# Add BREG as an engine +# Add GLMNET as an engine x <- distribution(background) |> engine_glmnet(iter = 1000) } } @@ -83,6 +83,7 @@ Other engine: \code{\link{engine_bart}()}, \code{\link{engine_breg}()}, \code{\link{engine_gdb}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_inla}()}, \code{\link{engine_stan}()}, diff --git a/man/engine_inla.Rd b/man/engine_inla.Rd index f95009e2..d73ebf28 100644 --- a/man/engine_inla.Rd +++ b/man/engine_inla.Rd @@ -134,6 +134,7 @@ Other engine: \code{\link{engine_breg}()}, \code{\link{engine_gdb}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_stan}()}, \code{\link{engine_xgboost}()} diff --git a/man/engine_inlabru.Rd b/man/engine_inlabru.Rd index 98cc0516..9e5f1d28 100644 --- a/man/engine_inlabru.Rd +++ b/man/engine_inlabru.Rd @@ -118,6 +118,7 @@ Other engine: \code{\link{engine_breg}()}, \code{\link{engine_gdb}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inla}()}, \code{\link{engine_stan}()}, \code{\link{engine_xgboost}()} diff --git a/man/engine_stan.Rd b/man/engine_stan.Rd index 755ff642..ddb29d34 100644 --- a/man/engine_stan.Rd +++ b/man/engine_stan.Rd @@ -95,6 +95,7 @@ Other engine: \code{\link{engine_breg}()}, \code{\link{engine_gdb}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_inla}()}, \code{\link{engine_xgboost}()} diff --git a/man/engine_xgboost.Rd b/man/engine_xgboost.Rd index 4ceee8c4..58372f76 100644 --- a/man/engine_xgboost.Rd +++ b/man/engine_xgboost.Rd @@ -101,6 +101,7 @@ Other engine: \code{\link{engine_breg}()}, \code{\link{engine_gdb}()}, \code{\link{engine_glmnet}()}, +\code{\link{engine_glm}()}, \code{\link{engine_inlabru}()}, \code{\link{engine_inla}()}, \code{\link{engine_stan}()} diff --git a/man/train.Rd b/man/train.Rd index 65b2166d..9183aa1c 100644 --- a/man/train.Rd +++ b/man/train.Rd @@ -174,5 +174,5 @@ necessarily make sense or are useful. } \seealso{ \link{engine_gdb}, \link{engine_xgboost}, \link{engine_bart}, \link{engine_inla}, -\link{engine_inlabru}, \link{engine_breg}, \link{engine_stan} +\link{engine_inlabru}, \link{engine_breg}, \link{engine_stan}, \link{engine_glm} } diff --git a/tests/testthat/test_controls.R b/tests/testthat/test_controls.R index 038f5c45..5ae1dc42 100644 --- a/tests/testthat/test_controls.R +++ b/tests/testthat/test_controls.R @@ -1,13 +1,10 @@ # ---- # -# Train a full distribution model with glmnet +# Train a full distribution model with glm base model test_that('Test controls', { - skip_if_not_installed('glmnet') skip_on_travis() skip_on_cran() - suppressWarnings( requireNamespace('glmnet', quietly = TRUE) ) - # No messages options(ibis.setupmessages = FALSE) @@ -50,7 +47,7 @@ test_that('Test controls', { # Train the model with limits set x <- x |> add_control_extrapolation(layer = zones, method = "zones") suppressWarnings( - mod <- train(x |> engine_glmnet(alpha = 1), "test", inference_only = FALSE, only_linear = TRUE, + mod <- train(x |> engine_glm(), "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) ) diff --git a/tests/testthat/test_modelFits.R b/tests/testthat/test_modelFits.R index a9fae5dd..295096a4 100644 --- a/tests/testthat/test_modelFits.R +++ b/tests/testthat/test_modelFits.R @@ -1,10 +1,7 @@ # Further tests for model fits test_that('Add further tests for model fits', { - skip_if_not_installed('glmnet') - skip_if_not_installed('pdp') - skip_on_travis() - skip_on_cran() + skip_if_not_installed("pdp") # Set to verbose options("ibis.setupmessages" = FALSE) @@ -23,23 +20,29 @@ test_that('Add further tests for model fits', { # Add pseudo absence abs <- pseudoabs_settings(nrpoints = 0,min_ratio = 1,method = "mcp") suppressMessages( - virtual_points <- add_pseudoabsence(virtual_points,template = background, field_occurrence = "Observed", settings = abs) + virtual_points2 <- add_pseudoabsence(virtual_points,template = background, field_occurrence = "Observed", settings = abs) ) # Create testing and training data - ind <- sample(1:nrow(virtual_points), 70) - train_data <- virtual_points[-ind,] - test_data <- virtual_points[ind,] + ind <- sample(1:nrow(virtual_points2), 70) + train_data <- virtual_points2[-ind,] + test_data <- virtual_points2[ind,] # Now set them one up step by step x <- distribution(background) |> - add_biodiversity_poipa(train_data, field_occurrence = 'Observed', name = 'Virtual points') |> add_predictors(predictors, transform = 'none',derivates = 'none') |> - engine_glmnet() + engine_glm() - # Train the model + # Train 2 model suppressWarnings( - mod <- train(x, "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) + mod <- train(x |> add_biodiversity_poipa(train_data, field_occurrence = 'Observed', + name = 'Virtual points',docheck = F), + "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) + ) + suppressWarnings( + mod_poipo <- train(x |> add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', + name = 'Virtual points',docheck = F), + "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) ) expect_s4_class(mod$get_data(), "SpatRaster") @@ -65,6 +68,11 @@ test_that('Add further tests for model fits', { val <- validate(mod, method = "disc", point = test_data,point_column = "Observed") expect_s3_class(val, "data.frame") + # ----------- # + # Project with separate data + pp <- mod$project(predictors |> as.data.frame(xy = TRUE, na.rm = FALSE)) + expect_s4_class(pp, "SpatRaster") + # ----------- # # Partial stuff pp <- partial(mod, x.var = "bio19_mean_50km",plot = FALSE) @@ -83,6 +91,12 @@ test_that('Add further tests for model fits', { # Clip the projected data with an external mask expect_no_error( mod$mask(virtual_range) ) + # ----------- # + # Other functions + pp <- mod$get_centroid() + expect_s3_class(pp, "sf") + expect_length(mod$show_rasters(), 2) + # ----------- # # Write model outputs tf <- base::tempfile() diff --git a/tests/testthat/test_objectinheritance.R b/tests/testthat/test_objectinheritance.R index 6d817ab1..ea0f7186 100644 --- a/tests/testthat/test_objectinheritance.R +++ b/tests/testthat/test_objectinheritance.R @@ -3,11 +3,6 @@ test_that('Check that distribution objects are properly inherited', { skip_if_not_installed('igraph') skip_if_not_installed('abind') - skip_if_not_installed("glmnet") - skip_if_not_installed("INLA") - # skip_if_not_installed("cmdstanr") - # skip_if(condition = tryCatch(expr = cmdstanr::cmdstan_path(), error = function(e) return(TRUE)), - # message = "No cmdstan path") # Load packages suppressWarnings( requireNamespace("terra", quietly = TRUE) ) @@ -73,9 +68,7 @@ test_that('Check that distribution objects are properly inherited', { expect_true(is.Waiver(x$latentfactors)) # Engine - x |> engine_gdb(boosting_iterations = 500) - expect_true(is.Waiver(x$engine)) - x |> engine_glmnet() + x |> engine_glm() expect_true(is.Waiver(x$engine)) # Priors diff --git a/tests/testthat/test_priors.R b/tests/testthat/test_priors.R index d43d2999..6237d0f9 100644 --- a/tests/testthat/test_priors.R +++ b/tests/testthat/test_priors.R @@ -2,7 +2,7 @@ test_that('Create and add priors', { # MH: Quick-and-dirty fix for now - skip_if_not_installed('INLA') + # skip_if_not_installed('INLA') # Create list of priors p1 <- priors( INLAPrior(variable = 'bias',type = 'normal', diff --git a/tests/testthat/test_rangesOffsets.R b/tests/testthat/test_rangesOffsets.R index 26a9cb9b..a2c844da 100644 --- a/tests/testthat/test_rangesOffsets.R +++ b/tests/testthat/test_rangesOffsets.R @@ -1,12 +1,12 @@ -# First check that INLA works +# First check that offsets work test_that('Load ranges and add them to distribution object', { - skip_on_travis() - skip_on_cran() - skip_if_not_installed('INLA') - skip_if_not_installed('igraph') + # Igraph should be by default installed, but check + skip_if_not_installed('igraph') suppressWarnings( requireNamespace("igraph", quietly = TRUE) ) + suppressWarnings( requireNamespace("terra", quietly = TRUE) ) + # Set to verbose options("ibis.setupmessages" = FALSE) # --- # @@ -41,9 +41,38 @@ test_that('Load ranges and add them to distribution object', { virtual_range_ras <- terra::aggregate(virtual_range_ras, 5) suppressWarnings( expect_s3_class( x |> add_predictor_range(virtual_range_ras), class = "BiodiversityDistribution" ) ) - # Add bias variable - suppressWarnings( y <- x |> add_control_bias(layer = predictors$hmi_mean_50km,bias_value = 0) ) - expect_type(y$control, 'list') - expect_length(y$get_control(), 4) + # --------- # + # Add offsets + y <- x |> add_offset_bias(layer = predictors$hmi_mean_50km) + expect_equal(y$get_offset(), "hmi_mean_50km") + + y <- x |> add_offset(layer = virtual_range) + expect_s4_class(y$offset, "SpatRaster") + + suppressWarnings( + y <- x |> add_offset_elevation(elev = predictors$elevation_mean_50km,pref = c(100,800)) + ) + expect_s4_class(y$offset, "SpatRaster") + # --------- # + + # --------- # + # Build a full model with various elements + suppressWarnings( + x <- distribution(background) |> + add_predictors(predictors) |> + add_biodiversity_poipo(virtual_points,field_occurrence = "Observed") |> + add_predictor_range(virtual_range) |> + # add_offset_elevation(elev = predictors$elevation_mean_50km,pref = c(100,800)) |> + # add_offset_bias(layer = predictors$hmi_mean_50km) |> + engine_glm() + ) + # expect_length(x$get_offset(), 2) + + # Train + suppressWarnings( + fit <- train(x,only_linear = T) + ) + expect_s4_class(fit$get_data(), "SpatRaster") + # --------- # }) diff --git a/vignettes/articles/06_engine_comparison.Rmd b/vignettes/articles/06_engine_comparison.Rmd index c235bcce..0a86ac46 100644 --- a/vignettes/articles/06_engine_comparison.Rmd +++ b/vignettes/articles/06_engine_comparison.Rmd @@ -20,7 +20,8 @@ Stating the name and function call of each engine and its supported model comple | Name | Complexity | Engine | `offsets` | `priors` | Joint likel. | `ensemble` | |---------------------------------------------------|:----------:|:------------:|:------------:|:------------:|:------------:|-------------:| -| Regularized elastic net regression (GLMNET) | ln | [`engine_glmnet`] | x | `GLMNETPrior()` | | x | +| Generalized linear model (GLM) | ln | [`engine_glm()`] | x | | | x | +| Regularized elastic net regression (GLMNET) | ln | [`engine_glmnet()`] | x | `GLMNETPrior()` | | x | | Bayesian additive regression trees (BART) | nl | [`engine_bart()`] | (x)| `BARTPrior()` | | x | | Bayesian regularized regression (BREG) | ln | [`engine_breg()`] | | `BREGPrior()` | | x | | Gradient descent boosting (GDB) | ln/nl | [`engine_gdb()`] | x | `GDBPrior()` | | x | From c12da473ba71044942a0675fca6225221555081c Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Mon, 11 Dec 2023 23:37:31 +0100 Subject: [PATCH 10/20] :bug: fixes to unittests, pseudo-absence and glm offsets --- R/add_biodiversity.R | 11 +++++------ R/bdproto-biodiversityscenario.R | 2 ++ R/bdproto-distributionmodel.R | 8 ++++++++ R/engine_glm.R | 22 ++++++---------------- R/prior_inla.R | 8 +++++++- R/pseudoabsence.R | 7 ++++--- R/train.R | 26 ++++++++++++++++++-------- man/add_biodiversity_poipo.Rd | 11 +++++------ man/engine_glm.Rd | 1 + man/train.Rd | 26 ++++++++++++++++++-------- tests/testthat/test_Scenarios.R | 15 +++++++++------ tests/testthat/test_rangesOffsets.R | 7 ++++--- 12 files changed, 87 insertions(+), 57 deletions(-) diff --git a/R/add_biodiversity.R b/R/add_biodiversity.R index 76087b87..f6e36b17 100644 --- a/R/add_biodiversity.R +++ b/R/add_biodiversity.R @@ -52,15 +52,14 @@ NULL #' @keywords biodiversity #' @aliases add_biodiversity_poipo #' @examples -#' \dontrun{ -#' background <- terra::rast("inst/extdata/europegrid_50km.tif") -#' # Load virtual species -#' virtual_species <- sf::st_read("inst/extdata/input_data.gpkg", "points") +#' # Load background +#' background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) +#' # Load virtual species +#' virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) #' # Define model #' x <- distribution(background) |> -#' add_biodiversity_poipo(virtual_species) +#' add_biodiversity_poipo(virtual_points) #' x -#' } #' @name add_biodiversity_poipo NULL diff --git a/R/bdproto-biodiversityscenario.R b/R/bdproto-biodiversityscenario.R index 6f48ceff..466a1747 100644 --- a/R/bdproto-biodiversityscenario.R +++ b/R/bdproto-biodiversityscenario.R @@ -354,6 +354,8 @@ BiodiversityScenario <- bdproto( # Not get the baseline raster baseline <- self$get_model()$get_data(thresh_reference) + # Get only the variable + if(terra::nlyr(baseline)>1) baseline <- terra::subset(baseline, grep(variable, names(baseline))) # And the last scenario prediction scenario <- self$get_data()['threshold'] time <- stars::st_get_dimension_values(scenario, which = 3) # 3 assumed to be time band diff --git a/R/bdproto-distributionmodel.R b/R/bdproto-distributionmodel.R index df0488f6..5f01cc52 100644 --- a/R/bdproto-distributionmodel.R +++ b/R/bdproto-distributionmodel.R @@ -493,6 +493,14 @@ DistributionModel <- bdproto( ) } }, + # Has offset + has_offset = function(self){ + model <- self$model$offset + if(!is.Waiver(model$offset)) return( TRUE ) + # Also check whether offset is somehow in the equation + ind <- attr(terms.formula(fit$get_equation()), "offset") + if(!is.null(ind)) return( TRUE ) + }, # Masking function mask = function(self, mask, inverse = FALSE, ...){ # Check whether prediction has been created diff --git a/R/engine_glm.R b/R/engine_glm.R index 70859f11..cee0b735 100644 --- a/R/engine_glm.R +++ b/R/engine_glm.R @@ -155,6 +155,7 @@ engine_glm <- function(x, template = bg, settings = model$biodiversity[[1]]$pseudoabsence_settings) if(inherits(presabs, 'sf')) presabs <- presabs |> sf::st_drop_geometry() + # Sample environmental points for absence only points abs <- subset(presabs, observed == 0) # Re-extract environmental information for absence points @@ -291,6 +292,7 @@ engine_glm <- function(x, # Get full prediction container full <- model$predictors w_full <- model$exposure + assertthat::assert_that(nrow(df)<=nrow(full)) # Security check? # Subset the predictor types to only those present te <- formula_terms(form) @@ -303,6 +305,10 @@ engine_glm <- function(x, # Add offset to full prediction and load vector ofs <- model$biodiversity[[1]]$offset[, 'spatial_offset'] ofs_pred <- model$offset[,'spatial_offset'] + # Add to data.frame and form + form <- stats::update.formula(form, . ~ . + offset(spatial_offset)) + df$spatial_offset <- ofs + full$spatial_offset <- ofs_pred } else { ofs <- NULL; ofs_pred <- NULL } # Clamp? @@ -332,21 +338,6 @@ engine_glm <- function(x, if(getOption('ibis.setupmessages')) myLog('[Estimation]','yellow', 'No hyperparameter optimization for glm implemented!') } else { - if(!is.null(ofs)){ - # Split since GLM cannot handle NULL offsets - suppressWarnings( - fit_glm <- try({ - stats::glm(formula = form, - data = df, - weights = w, # Case weights - offset = ofs, - family = fam, - na.action = "na.pass", - control = params$control - ) - },silent = FALSE) - ) - } else { suppressWarnings( fit_glm <- try({ stats::glm(formula = form, @@ -358,7 +349,6 @@ engine_glm <- function(x, ) },silent = FALSE) ) - } } if(inherits(fit_glm, "try-error")) stop("Model failed to converge with provided input data!") diff --git a/R/prior_inla.R b/R/prior_inla.R index 8415efe4..90a927e3 100644 --- a/R/prior_inla.R +++ b/R/prior_inla.R @@ -148,7 +148,13 @@ methods::setMethod( assertthat::assert_that(length(variables)>1, msg = 'Only one prior variable supplied. Use INLAPrior') # Match supplied type in case someone has been lazy - type <- match.arg(type, names(INLA::inla.models()$prior), several.ok = FALSE) + gg <- try({find.package("INLA")}, silent = TRUE) + if(!inherits(gg, "try-error")){ + pn <- names(INLA::inla.models()$prior) + } else { + pn <- c("normal", "gaussian","gamma","flat","pc", "pc.range","pc.prec") + } + type <- match.arg(type, pn, several.ok = FALSE) multiple_priors <- list() for(k in variables){ diff --git a/R/pseudoabsence.R b/R/pseudoabsence.R index ac8f1aec..207bd005 100644 --- a/R/pseudoabsence.R +++ b/R/pseudoabsence.R @@ -417,11 +417,12 @@ add_pseudoabsence <- function(df, field_occurrence = "observed", template = NULL sf::st_geometry(abs) <- attr(df, "sf_column") # Rename geom column to be the same as for df assertthat::assert_that( nrow(abs) > 0, all(names(abs) %in% names(df))) + # Unique to remove any duplicate values (otherwise double counted cells) - # FIXME: Ignoring this as one might want to stress contrast to biases cells - # abs <- unique(abs) + # MJ: Need this as otherwise nrow(abs) can exceed ncell(bg1). + abs <- unique(abs) # Combine with presence information and return - out <- rbind.data.frame(subset(df, select = names(abs)), + out <- rbind(subset(df, select = names(abs)), abs) return(out) } diff --git a/R/train.R b/R/train.R index d6bf6290..5f17d146 100644 --- a/R/train.R +++ b/R/train.R @@ -120,19 +120,29 @@ NULL #' [engine_inlabru], [engine_breg], [engine_stan], [engine_glm] #' @returns A [DistributionModel] object. #' @examples -#' \dontrun{ -#' # Fit a linear penalized logistic regression model via stan +#' # Load example data +#' 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)) +#' +#' # Use a basic GLM to fit a SDM #' x <- distribution(background) |> -#' # Presence-absence data -#' add_biodiversity_poipa(surveydata) |> +#' # Presence-only data +#' add_biodiversity_poipo(virtual_points) |> #' # Add predictors and scale them #' add_predictors(env = predictors, transform = "scale", derivates = "none") |> -#' # Use Stan for estimation -#' engine_stan(chains = 2, iter = 1000, warmup = 500) -#' # Train the model +#' # Use GLM as engine +#' engine_glm() +#' +#' # Train the model, Also filter out co-linear predictors using a pearson threshold #' mod <- train(x, only_linear = TRUE, filter_predictors = 'pearson') #' mod -#' } +#' #' @name train #' @exportMethod train #' @aliases train, train-method diff --git a/man/add_biodiversity_poipo.Rd b/man/add_biodiversity_poipo.Rd index 2c733577..a7857d2b 100644 --- a/man/add_biodiversity_poipo.Rd +++ b/man/add_biodiversity_poipo.Rd @@ -79,16 +79,15 @@ in which presence-only points are fitted through a down-weighted Poisson regression. See Renner et al. 2015 for an overview. } \examples{ -\dontrun{ - background <- terra::rast("inst/extdata/europegrid_50km.tif") - # Load virtual species - virtual_species <- sf::st_read("inst/extdata/input_data.gpkg", "points") +# Load background +background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) +# Load virtual species +virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) # Define model x <- distribution(background) |> - add_biodiversity_poipo(virtual_species) + add_biodiversity_poipo(virtual_points) x } -} \references{ \itemize{ \item Guisan A. and Zimmerman N. 2000. Predictive habitat distribution models in ecology. Ecol. Model. 135: 147–186. diff --git a/man/engine_glm.Rd b/man/engine_glm.Rd index 5117a801..682f3215 100644 --- a/man/engine_glm.Rd +++ b/man/engine_glm.Rd @@ -41,6 +41,7 @@ settings to support offsets and weights. \examples{ # Load background background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) + # Add GLM as an engine x <- distribution(background) |> engine_glm() x diff --git a/man/train.Rd b/man/train.Rd index 9183aa1c..d3bb9437 100644 --- a/man/train.Rd +++ b/man/train.Rd @@ -151,19 +151,29 @@ predictions can be obtained from the same data and parameters and not all necessarily make sense or are useful. } \examples{ -\dontrun{ - # Fit a linear penalized logistic regression model via stan + # Load example data + 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)) + + # Use a basic GLM to fit a SDM x <- distribution(background) |> - # Presence-absence data - add_biodiversity_poipa(surveydata) |> + # Presence-only data + add_biodiversity_poipo(virtual_points) |> # Add predictors and scale them add_predictors(env = predictors, transform = "scale", derivates = "none") |> - # Use Stan for estimation - engine_stan(chains = 2, iter = 1000, warmup = 500) - # Train the model + # Use GLM as engine + engine_glm() + + # Train the model, Also filter out co-linear predictors using a pearson threshold mod <- train(x, only_linear = TRUE, filter_predictors = 'pearson') mod -} + } \references{ \itemize{ diff --git a/tests/testthat/test_Scenarios.R b/tests/testthat/test_Scenarios.R index d6363939..bff72830 100644 --- a/tests/testthat/test_Scenarios.R +++ b/tests/testthat/test_Scenarios.R @@ -76,14 +76,12 @@ test_that('Testing functions for spatial-temporal data in stars', { # Test scenario creation and constraints test_that('Scenarios and constraints', { - skip_if_not_installed('glmnet') skip_if_not_installed('geosphere') skip_if_not_installed('cubelyr') skip_if_not_installed('lwgeom') skip_on_travis() skip_on_cran() - suppressWarnings( requireNamespace('glmnet', quietly = TRUE) ) suppressWarnings( requireNamespace('igraph', quietly = TRUE) ) suppressWarnings( requireNamespace('stars', quietly = TRUE) ) suppressWarnings( requireNamespace('geosphere', quietly = TRUE) ) @@ -134,7 +132,7 @@ test_that('Scenarios and constraints', { fit <- distribution(background) |> add_biodiversity_poipa(virtual_points, field_occurrence = 'Observed', name = 'Virtual points') |> add_predictors(pred_current) |> - engine_glmnet(alpha = 0) |> + engine_glm() |> train("test", inference_only = FALSE, verbose = FALSE) |> threshold(method = "perc", value = .3) @@ -197,7 +195,7 @@ test_that('Scenarios and constraints', { expect_s3_class(mod$get_data(), "stars") # Apply a mask - mod$mask(virtual_range) + expect_no_error( mod$mask(virtual_range) ) mod <- x |> project() # Project anew # Calculate centroids @@ -228,7 +226,9 @@ test_that('Scenarios and constraints', { expect_s3_class(mod |> get_data(), "stars") # Make a first projection - mod <- sc |> add_predictors(pred_future) |> project() + expect_no_error( + mod <- sc |> add_predictors(pred_future) |> project() + ) suppressWarnings( expect_s3_class(summary(mod), "data.frame") ) invisible( suppressWarnings( expect_s3_class(mod$calc_scenarios_slope(plot = FALSE), "stars") ) @@ -238,8 +238,11 @@ test_that('Scenarios and constraints', { # These will throw errors as we haven't added thresholds expect_error(mod$plot_relative_change()) expect_error(mod$summary_beforeafter()) + # Now add threshold - mod <- sc |> add_predictors(pred_future) |> threshold() |> project() + expect_no_error( + mod <- sc |> add_predictors(pred_future) |> threshold() |> project() + ) expect_s3_class(mod$summary_beforeafter(), "data.frame") expect_true(inherits(mod$plot_relative_change(plot=FALSE), "SpatRaster")) diff --git a/tests/testthat/test_rangesOffsets.R b/tests/testthat/test_rangesOffsets.R index a2c844da..316fb9e7 100644 --- a/tests/testthat/test_rangesOffsets.R +++ b/tests/testthat/test_rangesOffsets.R @@ -62,17 +62,18 @@ test_that('Load ranges and add them to distribution object', { add_predictors(predictors) |> add_biodiversity_poipo(virtual_points,field_occurrence = "Observed") |> add_predictor_range(virtual_range) |> - # add_offset_elevation(elev = predictors$elevation_mean_50km,pref = c(100,800)) |> - # add_offset_bias(layer = predictors$hmi_mean_50km) |> + add_offset_elevation(elev = predictors$elevation_mean_50km,pref = c(100,800)) |> + add_offset_bias(layer = predictors$hmi_mean_50km) |> engine_glm() ) - # expect_length(x$get_offset(), 2) + expect_length(x$get_offset(), 2) # Train suppressWarnings( fit <- train(x,only_linear = T) ) expect_s4_class(fit$get_data(), "SpatRaster") + expect_true(fit$has_offset()) # --------- # }) From f0901bde670ada13416a75c165dfd9aea12cb51c Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Tue, 12 Dec 2023 00:09:49 +0100 Subject: [PATCH 11/20] Damn you INLA, damn you to hell --- R/train.R | 2 +- tests/testthat/test_objectinheritance.R | 1 + tests/testthat/test_priors.R | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/train.R b/R/train.R index 5f17d146..0722654c 100644 --- a/R/train.R +++ b/R/train.R @@ -133,7 +133,7 @@ NULL #' # Use a basic GLM to fit a SDM #' x <- distribution(background) |> #' # Presence-only data -#' add_biodiversity_poipo(virtual_points) |> +#' add_biodiversity_poipo(virtual_points, field_occurrence = "Observed") |> #' # Add predictors and scale them #' add_predictors(env = predictors, transform = "scale", derivates = "none") |> #' # Use GLM as engine diff --git a/tests/testthat/test_objectinheritance.R b/tests/testthat/test_objectinheritance.R index ea0f7186..0c16ebf5 100644 --- a/tests/testthat/test_objectinheritance.R +++ b/tests/testthat/test_objectinheritance.R @@ -3,6 +3,7 @@ test_that('Check that distribution objects are properly inherited', { skip_if_not_installed('igraph') skip_if_not_installed('abind') + skip_if_not_installed('INLA') # Load packages suppressWarnings( requireNamespace("terra", quietly = TRUE) ) diff --git a/tests/testthat/test_priors.R b/tests/testthat/test_priors.R index 6237d0f9..d43d2999 100644 --- a/tests/testthat/test_priors.R +++ b/tests/testthat/test_priors.R @@ -2,7 +2,7 @@ test_that('Create and add priors', { # MH: Quick-and-dirty fix for now - # skip_if_not_installed('INLA') + skip_if_not_installed('INLA') # Create list of priors p1 <- priors( INLAPrior(variable = 'bias',type = 'normal', From 6049023403c515e4681847ef3b19ec5eb3f1f63a Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Tue, 12 Dec 2023 07:07:34 +0100 Subject: [PATCH 12/20] Small example failure correction --- R/add_biodiversity.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/add_biodiversity.R b/R/add_biodiversity.R index f6e36b17..044c0927 100644 --- a/R/add_biodiversity.R +++ b/R/add_biodiversity.R @@ -58,7 +58,7 @@ NULL #' virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) #' # Define model #' x <- distribution(background) |> -#' add_biodiversity_poipo(virtual_points) +#' add_biodiversity_poipo(virtual_points, field_occurrence = "Observed") #' x #' @name add_biodiversity_poipo NULL From 4becbeae6f4d91b1091593fe97ab092e35645c67 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Tue, 12 Dec 2023 07:38:49 +0100 Subject: [PATCH 13/20] Forgot to update documentation... --- man/add_biodiversity_poipo.Rd | 2 +- man/train.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/man/add_biodiversity_poipo.Rd b/man/add_biodiversity_poipo.Rd index a7857d2b..30f28e41 100644 --- a/man/add_biodiversity_poipo.Rd +++ b/man/add_biodiversity_poipo.Rd @@ -85,7 +85,7 @@ background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ib virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) # Define model x <- distribution(background) |> - add_biodiversity_poipo(virtual_points) + add_biodiversity_poipo(virtual_points, field_occurrence = "Observed") x } \references{ diff --git a/man/train.Rd b/man/train.Rd index d3bb9437..4545cfee 100644 --- a/man/train.Rd +++ b/man/train.Rd @@ -164,7 +164,7 @@ necessarily make sense or are useful. # Use a basic GLM to fit a SDM x <- distribution(background) |> # Presence-only data - add_biodiversity_poipo(virtual_points) |> + add_biodiversity_poipo(virtual_points, field_occurrence = "Observed") |> # Add predictors and scale them add_predictors(env = predictors, transform = "scale", derivates = "none") |> # Use GLM as engine From 9bc2e265363ae531a32444dff36f7bd79fa5a3c3 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Tue, 12 Dec 2023 07:50:53 +0100 Subject: [PATCH 14/20] T used instead of TRUE ???? --- R/train.R | 2 +- man/train.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/train.R b/R/train.R index 0722654c..62c02f8a 100644 --- a/R/train.R +++ b/R/train.R @@ -126,7 +126,7 @@ NULL #' 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) +#' 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)) #' diff --git a/man/train.Rd b/man/train.Rd index 4545cfee..b9e6a96c 100644 --- a/man/train.Rd +++ b/man/train.Rd @@ -157,7 +157,7 @@ necessarily make sense or are useful. 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) + 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)) From ce27e74d954e2e85a7843c34520293326ceb2796 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Wed, 13 Dec 2023 00:01:48 +0100 Subject: [PATCH 15/20] Minor offset fixes --- NEWS.md | 1 + R/add_offset.R | 26 ++++++++++++++++--------- man/add_offset_range.Rd | 11 ++++++++--- tests/testthat/test_controls.R | 2 +- tests/testthat/test_loadData.R | 2 +- tests/testthat/test_rangesOffsets.R | 7 ++++--- tests/testthat/test_trainOtherEngines.R | 2 +- 7 files changed, 33 insertions(+), 18 deletions(-) diff --git a/NEWS.md b/NEWS.md index efb71191..78c90852 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,7 @@ * Harmonized controls settings and added option to contrain extrapolation `add_control_extrapolation()` #### Minor improvements and bug fixes +* Minor corrective fixes and additions to `add_offset()`. * Switch to `engine_glm()` in many of the unittests for better coverage. * Several bug fixes and improvements in `thin_observations` * `global`, `probs`, and `centers` argument for better control of `thin_observations` diff --git a/R/add_offset.R b/R/add_offset.R index 609c6112..bd3d63d3 100644 --- a/R/add_offset.R +++ b/R/add_offset.R @@ -362,7 +362,7 @@ methods::setMethod( #' @param distance_clip [`logical`] as to whether distance should be clipped #' after the maximum distance (Default: \code{FALSE}). #' @param distance_function A [`character`] specifying the distance function to -#' be used. Available are negative exponential kernels (\code{"negexp"}, +#' be used. Available are linear (\code{"linear"}), negative exponential kernels (\code{"negexp"}, #' default) and a five parameters logistic curve (code{"logcurve"}) as #' proposed by Merow et al. 2017. #' @param point An optional [`sf`] layer with points or [`logical`] argument. In @@ -380,8 +380,13 @@ methods::setMethod( #' @aliases add_offset_range #' @examples #' \dontrun{ -#' # Adds the offset to a distribution object -#' distribution(background) |> add_offset_range(species_range) +#' # Train a presence-only model with a simple offset +#' fit <- distribution(background) |> +#' add_biodiversity_poipo(virtual_points, field_occurrence = "Observed") |> +#' add_predictors(predictors) |> +#' add_offset_range(virtual_range, distance_max = 5,distance_function = "logcurve", distance_clip = TRUE ) |> +#' engine_glm() |> +#' train() #' } #' @keywords prior, offset #' @family offset @@ -480,12 +485,12 @@ methods::setMethod( is.character(field_occurrence), is.logical(add) ) - # distance_max = Inf; family = "poisson"; presence_prop = 0.9; distance_clip = FALSE; distance_function = "negexp"; field_occurrence = "observed"; fraction = NULL; add = TRUE + # distance_max = Inf; family = "poisson"; presence_prop = 0.9; distance_clip = FALSE; distance_function = "negexp"; field_occurrence = "observed"; fraction = NULL; add = TRUE;point =NULL # Match the type if set family <- match.arg(family, c("poisson", "binomial"), several.ok = FALSE) # Distance function - distance_function <- match.arg(distance_function, c("negexp", "logcurve"), several.ok = FALSE) + distance_function <- match.arg(distance_function, c("linear","negexp", "logcurve"), several.ok = FALSE) # Check that necessary dependency is present for log curve if(distance_function=="logcurve"){ @@ -565,6 +570,7 @@ methods::setMethod( } # Inverse of distance if(is.infinite(distance_max)) distance_max <- terra::global(dis, "max", na.rm = TRUE)[,1] + suppressWarnings( ar <- terra::cellSize(ras_range, unit = "km") ) # Calculate area in km # ---- # if(distance_function == "negexp"){ alpha <- 1 / (distance_max / 4 ) # Divide by 4 for a quarter in each direction @@ -576,7 +582,6 @@ methods::setMethod( # Inside I want all X across the entire area for the PPMs, indicating a # lambda per area of at least X/A (per unit area) within the range - suppressWarnings( ar <- terra::cellSize(ras_range, unit = "km") ) # Calculate area in km pres <- 1 + ( ( terra::global(ar * ras_range, "sum", na.rm = TRUE)[,1] / terra::global(ar, "sum", na.rm = TRUE)[,1]) * (presence_prop) ) abs <- 1 + ( ( terra::global(ar * ras_range, "sum", na.rm = TRUE)[,1] / terra::global(ar, "sum", na.rm = TRUE)[,1]) * (1-presence_prop) ) # Now set all values inside the range to pres and outside to abs @@ -586,7 +591,6 @@ methods::setMethod( ras_range <- ras_range * dis # Normalize the result by dividing by the sum ras_range <- ras_range / terra::global(ras_range, "sum", na.rm = TRUE)[,1] - } else if(distance_function == "logcurve"){ # Extract the point values from the raster ex <- get_rastervalue(coords = point, env = dis) @@ -617,6 +621,10 @@ methods::setMethod( skew = co["skew"]) attr(ras_range, "logistic_coefficients") <- co + } else if (distance_function == "linear") { + # Multiply with distance layer + ras_range <- abs( dis / terra::global(ras_range, "sum", na.rm = TRUE)[,1]) * -1 + ras_range[is.na(ras_range)] <- terra::global(ras_range, "min", na.rm = TRUE)[,1] } else { stop("Distance method not yet implemented.") } @@ -637,14 +645,14 @@ methods::setMethod( # -------------- # # Log transform for better scaling - if(family == "negexp"){ + if(family %in% c("negexp", "linear")){ ras_range <- switch (family, "poisson" = terra::app(ras_range, log), "binomial" = terra::app(ras_range, logistic) ) } # Rescaling does not affect relative differences. - ras_range <- terra::scale(ras_range, scale = FALSE) + ras_range <- terra::scale(ras_range, scale = F) names(ras_range) <- "range_distance" assertthat::assert_that( diff --git a/man/add_offset_range.Rd b/man/add_offset_range.Rd index 6830a819..4e7e3cc1 100644 --- a/man/add_offset_range.Rd +++ b/man/add_offset_range.Rd @@ -48,7 +48,7 @@ indicating that 10\% of all records are likely outside the range.} after the maximum distance (Default: \code{FALSE}).} \item{distance_function}{A \code{\link{character}} specifying the distance function to -be used. Available are negative exponential kernels (\code{"negexp"}, +be used. Available are linear (\code{"linear"}), negative exponential kernels (\code{"negexp"}, default) and a five parameters logistic curve (code{"logcurve"}) as proposed by Merow et al. 2017.} @@ -91,8 +91,13 @@ to a very small constant (\code{1e-10}). } \examples{ \dontrun{ - # Adds the offset to a distribution object - distribution(background) |> add_offset_range(species_range) + # Train a presence-only model with a simple offset + fit <- distribution(background) |> + add_biodiversity_poipo(virtual_points, field_occurrence = "Observed") |> + add_predictors(predictors) |> + add_offset_range(virtual_range, distance_max = 5,distance_function = "logcurve", distance_clip = TRUE ) |> + engine_glm() |> + train() } } \references{ diff --git a/tests/testthat/test_controls.R b/tests/testthat/test_controls.R index 5ae1dc42..ed1fe563 100644 --- a/tests/testthat/test_controls.R +++ b/tests/testthat/test_controls.R @@ -62,7 +62,7 @@ test_that('Test controls', { x <- x$rm_limits() x <- x |> add_control_extrapolation(method = "mess") suppressWarnings( - mod <- train(x |> engine_glmnet(alpha = 1), "test", inference_only = FALSE, only_linear = TRUE, + mod <- train(x |> engine_glm(), "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) ) diff --git a/tests/testthat/test_loadData.R b/tests/testthat/test_loadData.R index 45766e3c..3e5d5ea0 100644 --- a/tests/testthat/test_loadData.R +++ b/tests/testthat/test_loadData.R @@ -14,7 +14,7 @@ test_that('Check that data can be loaded.',{ expect_true(unique(sf::st_geometry_type(virtual_range)) == 'POLYGON') # Get list of test predictors - ll <- list.files(system.file('extdata/predictors/',package = 'ibis.iSDM',mustWork = TRUE),full.names = T) + ll <- list.files(system.file('extdata/predictors/',package = 'ibis.iSDM',mustWork = TRUE),full.names = TRUE) expect_gt(length(ll),0) expect_true(all( assertthat::has_extension(ll,'tif') )) diff --git a/tests/testthat/test_rangesOffsets.R b/tests/testthat/test_rangesOffsets.R index 316fb9e7..665c6822 100644 --- a/tests/testthat/test_rangesOffsets.R +++ b/tests/testthat/test_rangesOffsets.R @@ -17,7 +17,7 @@ test_that('Load ranges and add them to distribution object', { virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) virtual_range <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'range',quiet = TRUE) # Get list of test predictors - ll <- list.files(system.file('extdata/predictors/', package = 'ibis.iSDM', mustWork = TRUE),full.names = T) + 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)) @@ -61,12 +61,13 @@ test_that('Load ranges and add them to distribution object', { x <- distribution(background) |> add_predictors(predictors) |> add_biodiversity_poipo(virtual_points,field_occurrence = "Observed") |> - add_predictor_range(virtual_range) |> + add_offset_range(virtual_range,distance_function = "linear",distance_max = 300, + distance_clip = TRUE) |> add_offset_elevation(elev = predictors$elevation_mean_50km,pref = c(100,800)) |> add_offset_bias(layer = predictors$hmi_mean_50km) |> engine_glm() ) - expect_length(x$get_offset(), 2) + expect_length(x$get_offset(), 3) # Train suppressWarnings( diff --git a/tests/testthat/test_trainOtherEngines.R b/tests/testthat/test_trainOtherEngines.R index a7bfb9ed..d3ffe7bc 100644 --- a/tests/testthat/test_trainOtherEngines.R +++ b/tests/testthat/test_trainOtherEngines.R @@ -325,7 +325,7 @@ test_that('Train a distribution model with glmnet', { expect_s4_class(ex, 'SpatRaster') suppressWarnings( - suppressMessages( mod2 <- train(x |> engine_glmnet(alpha = 0),verbose = FALSE) ) + suppressMessages( mod2 <- train(x |> engine_glmnet(alpha = 1),verbose = FALSE) ) ) expect_no_error(ex <- ensemble(mod, mod2)) expect_s4_class(ex, "SpatRaster") From 0e6e1d7d6d72477262d6992ad343228489f47b50 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 14 Dec 2023 00:15:36 +0100 Subject: [PATCH 16/20] Small bug fixes and addition of temporal interpolation #52 --- NAMESPACE | 1 + NEWS.md | 1 + R/add_control_extrapolation.R | 4 +- R/ibis.iSDM-package.R | 4 +- R/project.R | 8 +- R/utils-scenario.R | 88 ++++++++++--------- R/utils-spatial.R | 2 +- man/interpolate_gaps.Rd | 30 +++++++ tests/testthat/test_Scenarios.R | 9 +- tests/testthat/test_trainOtherEngines.R | 27 +++++- .../articles/01_data_preparationhelpers.Rmd | 41 ++++++++- 11 files changed, 163 insertions(+), 52 deletions(-) create mode 100644 man/interpolate_gaps.Rd diff --git a/NAMESPACE b/NAMESPACE index 8c3d896c..113e656c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -229,3 +229,4 @@ importFrom(stats,terms.formula) importFrom(stats,update.formula) importFrom(terra,mask) importFrom(utils,install.packages) +importFrom(zoo,na.approx) diff --git a/NEWS.md b/NEWS.md index 78c90852..d4613bb4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ #### New features * Added default `engine_glm()` for dependency-free inference and projection. * Harmonized controls settings and added option to contrain extrapolation `add_control_extrapolation()` +* Adding a function for temporal interpolation of predictors #52 #### Minor improvements and bug fixes * Minor corrective fixes and additions to `add_offset()`. diff --git a/R/add_control_extrapolation.R b/R/add_control_extrapolation.R index c5d34d3e..5321c6f7 100644 --- a/R/add_control_extrapolation.R +++ b/R/add_control_extrapolation.R @@ -102,7 +102,7 @@ methods::setMethod( methods::signature(x = "BiodiversityDistribution"), function(x, layer, method = "mcp", mcp_buffer = 0, novel = "within", limits_clip = FALSE) { assertthat::assert_that(inherits(x, "BiodiversityDistribution"), - missing(layer) || (is.Raster(layer) || is.sf(layer)), + missing(layer) || (is.Raster(layer) || inherits(layer, "sf")), (is.numeric(mcp_buffer) && mcp_buffer >=0), is.logical(limits_clip), is.character(novel), @@ -114,7 +114,7 @@ methods::setMethod( # Apply method specific settings if(method == "zones"){ - assertthat::assert_that((is.Raster(layer) || is.sf(layer)), + assertthat::assert_that((is.Raster(layer) || inherits(layer, "sf")), msg = "No zone layer specified!") if(inherits(layer,'SpatRaster')){ diff --git a/R/ibis.iSDM-package.R b/R/ibis.iSDM-package.R index eca0abc9..1ea9a940 100644 --- a/R/ibis.iSDM-package.R +++ b/R/ibis.iSDM-package.R @@ -23,7 +23,7 @@ globalVariables(c("background", "band", "bi_class", "bias", "form2", "geometry", "id", "included", - "km", + "km", "vt", "limit", "lower", "median", "model", "name", @@ -36,5 +36,5 @@ globalVariables(c("background", "band", "bi_class", "bias", "upper", "layer", "rug", "var1", "var2", "value", "variable", - "x", "y", "z", + "i", "x", "y", "z", ".")) diff --git a/R/project.R b/R/project.R index 770649e3..ba28e835 100644 --- a/R/project.R +++ b/R/project.R @@ -131,12 +131,14 @@ methods::setMethod( new_crs <- new_preds$get_projection() if(is.na(new_crs)) if(getOption('ibis.setupmessages')) myLog('[Scenario]','yellow','Missing projection of future predictors.') - # Interpolate dates if set + # Interpolate predictor set if specified if(date_interpolation!="none"){ if(getOption('ibis.setupmessages')) myLog('[Scenario]','green',paste0('Interpolating dates for scenario predictors as: ', date_interpolation)) - o <- approximate_gaps(env = new_preds$get_data(), date_interpolation = date_interpolation) + + new <- interpolate_gaps(new_preds$get_data(), + date_interpolation = date_interpolation) # Set new data - #new_preds$set_data() + new_preds$set_data(new) } # Get limits if present diff --git a/R/utils-scenario.R b/R/utils-scenario.R index 9da09ca3..9898e61d 100644 --- a/R/utils-scenario.R +++ b/R/utils-scenario.R @@ -3,31 +3,37 @@ #' @description This function linearly approximates shares between time steps, #' so that gaps for instance between 2010 and 2020 are filled with data for #' 2010, 2011, 2012, etc. +#' #' @param env A [`stars`] object. #' @param date_interpolation [`character`] on how missing dates between events #' should be interpolated. See [`project()`]. #' @return [`logical`] indicating if the two [`SpatRaster-class`] objects have #' the same. #' @keywords scenario -#' @aliases approximate_gaps -#' @noRd -approximate_gaps <- function(env, date_interpolation = "annual"){ +#' @aliases interpolate_gaps +#' @importFrom zoo na.approx +#' @examples +#' \dontrun{ +#' # Interpolate stars stack +#' sc <- interpolate_gaps( stack, "annual") +#' } +interpolate_gaps <- function(env, date_interpolation = "annual"){ assertthat::assert_that( inherits(env, "stars"), is.character(date_interpolation) ) check_package("dplyr") + date_interpolation <- match.arg(date_interpolation, c("none", "yearly", "annual", "monthly", "daily"), several.ok = FALSE) if(date_interpolation=="none") return(env) - stop("Functionality still work in progress") # --- # # Get individual time steps at interval times <- stars::st_get_dimension_values(env, which = names(dim(env))[3], center = TRUE) times <- to_POSIXct(times) - tzone <- attr(as.POSIXlt(times), "tzone")[2] # Get timezone + tzone <- attr(as.POSIXlt(times), "tzone") # Get timezone assertthat::assert_that(tzone != "", length(times)>=2) # Interpolate time steps inc <- switch (date_interpolation, @@ -36,45 +42,47 @@ approximate_gaps <- function(env, date_interpolation = "annual"){ "monthly" = "month", "daily" = "day" ) + # Create new time layer new_times <- seq.Date(from = as.Date(times[1],tz = tzone), - to = as.Date(times[length(times)],tz = tzone), by = inc) + to = as.Date(times[length(times)],tz = tzone), + by = inc) new_times <- to_POSIXct(new_times) + ori.dims <- names(stars::st_dimensions(env)) - # Linearly approximate all attributes for new object - # FIXME: Probably terribly memory inefficient but works - # MH: Should this be stars:::as.data.frame.stars? - new <- as.data.frame(env) - assertthat::assert_that(assertthat::has_name(new,c("x","y","time"))) - new <- dplyr::right_join(new, expand.grid(x = unique(new$x), y = unique(new$y), time = new_times), - by = c("x", "y","time")) - # Sort by time - new <- new[order(new$time),] - # Now linearly interpolate the missing values per grid cell - new2 <- apply(new[,4:ncol(new)], 2, function(z){ - # if(inherits(z, "POSIXct")) return(z) - if(all(is.na(z))) return(z) - stats::approx(y = z, x = as.numeric(new$time), method = "linear") - }) - - # Steps: - # empty_stars - # Join with existing one - # approxNA - - tt <- as.numeric(new_times) - # Calc pixel-wise linear slope - out <- stars::st_apply( - env, - 1:2, - function(x) { - if (anyNA(x)) - NA_real_ - else - stats::lm.fit(cbind(1, tt), x)$coefficients[2] - } - ) + # Now for each variable, interpolate + out <- list() + if(getOption('ibis.setupmessages')) pb <- progress::progress_bar$new(total = length(env)) + for(v in names(env)){ + if(getOption('ibis.setupmessages')) pb$tick() + + # Get the variable + o <- Reduce(c, stars_to_raster(env[v]) ) + + # Create empty copies per times + nt <- new_times[new_times %notin% terra::time(o)] + oo <- rep(emptyraster(o, vals = NA), length(nt)) + terra::time(oo) <- nt + oo <- c(o,oo) + names(oo) <- paste0(v,'_',as.numeric(terra::time(oo))) + + # Linearly approximate gaps and save in list + out[[v]] <- terra::approximate(x = oo, + method = "linear", + yleft = NA, + yright = NA) |> stars::st_as_stars() + } + + # Combine + out <- Reduce(c, out) + # Rename again + names(out) <- names(env) - # new <- stars::st_redimension(out, along = list(time = new_times)) + # Checks + assertthat::assert_that( + is.stars(out), + all( names(out) %in% names(env) ) + ) + return(out) } #' Aggregate stars variables across dimensions diff --git a/R/utils-spatial.R b/R/utils-spatial.R index 8639c674..f2485a78 100644 --- a/R/utils-spatial.R +++ b/R/utils-spatial.R @@ -1367,7 +1367,7 @@ thin_observations <- function(data, background, env = NULL, method = "random", r # points by sampling at random from the occupied grid cells # extract cell id for each point - ex <- cbind(id = 1:nrow(coords), terra::extract(ras, coords, cell = TRUE)) + ex <- cbind(id = 1:nrow(coords), terra::extract(ras, coords, cells = TRUE)) # remove NA points ex <- subset(ex, stats::complete.cases(ex)) diff --git a/man/interpolate_gaps.Rd b/man/interpolate_gaps.Rd new file mode 100644 index 00000000..2f1216cf --- /dev/null +++ b/man/interpolate_gaps.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-scenario.R +\name{interpolate_gaps} +\alias{interpolate_gaps} +\title{Approximate missing time steps between dates} +\usage{ +interpolate_gaps(env, date_interpolation = "annual") +} +\arguments{ +\item{env}{A \code{\link{stars}} object.} + +\item{date_interpolation}{\code{\link{character}} on how missing dates between events +should be interpolated. See \code{\link[=project]{project()}}.} +} +\value{ +\code{\link{logical}} indicating if the two \code{\linkS4class{SpatRaster}} objects have +the same. +} +\description{ +This function linearly approximates shares between time steps, +so that gaps for instance between 2010 and 2020 are filled with data for +2010, 2011, 2012, etc. +} +\examples{ +\dontrun{ + # Interpolate stars stack + sc <- interpolate_gaps( stack, "annual") +} +} +\keyword{scenario} diff --git a/tests/testthat/test_Scenarios.R b/tests/testthat/test_Scenarios.R index bff72830..2b49ec18 100644 --- a/tests/testthat/test_Scenarios.R +++ b/tests/testthat/test_Scenarios.R @@ -13,7 +13,7 @@ test_that('Testing functions for spatial-temporal data in stars', { # Load some stars rasters ll <- list.files(system.file('extdata/predictors_presfuture/', package = 'ibis.iSDM', - mustWork = TRUE),full.names = T) + mustWork = TRUE),full.names = TRUE) # Load the same files future ones suppressWarnings( @@ -56,6 +56,13 @@ test_that('Testing functions for spatial-temporal data in stars', { "data.frame" ) + # Make a simple interpolation + expect_no_error( + new <- interpolate_gaps(pred_future, date_interpolation = "annual") + ) + expect_length(new, 9) + expect_length(stars::st_get_dimension_values(new, 3), 81) + # --- # # Create threshold expect_no_error( diff --git a/tests/testthat/test_trainOtherEngines.R b/tests/testthat/test_trainOtherEngines.R index d3ffe7bc..fd8ab108 100644 --- a/tests/testthat/test_trainOtherEngines.R +++ b/tests/testthat/test_trainOtherEngines.R @@ -9,6 +9,9 @@ test_that('Train a distribution model with XGboost', { suppressWarnings( requireNamespace('xgboost', quietly = TRUE) ) suppressWarnings( requireNamespace('pdp', quietly = TRUE) ) + # Set to verbose + options("ibis.setupmessages" = FALSE) + # Load data # Background Raster background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) @@ -102,6 +105,9 @@ test_that('Train a distribution model with Breg', { suppressWarnings( requireNamespace('BoomSpikeSlab', quietly = TRUE) ) + # Set to verbose + options("ibis.setupmessages" = FALSE) + # Load data # Background Raster background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) @@ -181,6 +187,9 @@ test_that('Train a distribution model with GDB', { suppressWarnings( requireNamespace('mboost', quietly = TRUE) ) + # Set to verbose + options("ibis.setupmessages" = FALSE) + # Load data # Background Raster background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) @@ -271,6 +280,9 @@ test_that('Train a distribution model with glmnet', { suppressWarnings( requireNamespace('glmnet', quietly = TRUE) ) suppressWarnings( requireNamespace('pdp', quietly = TRUE) ) + # Set to verbose + options("ibis.setupmessages" = FALSE) + # Load data # Background Raster background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) @@ -324,8 +336,10 @@ test_that('Train a distribution model with glmnet', { expect_no_error(ex <- spartial(mod, x.var = "CLC3_312_mean_50km")) expect_s4_class(ex, 'SpatRaster') + pp <- priors(GLMNETPrior("CLC3_312_mean_50km",hyper = 1)) # Always reatin Forest suppressWarnings( - suppressMessages( mod2 <- train(x |> engine_glmnet(alpha = 1),verbose = FALSE) ) + suppressMessages( mod2 <- train(x |> add_priors(pp) |> + engine_glmnet(alpha = 1),verbose = FALSE) ) ) expect_no_error(ex <- ensemble(mod, mod2)) expect_s4_class(ex, "SpatRaster") @@ -335,7 +349,7 @@ test_that('Train a distribution model with glmnet', { expect_s3_class(ex, 'data.frame') # Do ensemble spartials work - mod2 <- x |> train(only_linear = TRUE) + mod2 <- x |> add_priors(pp) |> train(only_linear = TRUE) expect_no_error(ex <- ensemble_spartial(mod,mod2, x.var = "CLC3_312_mean_50km")) expect_true(is.Raster(ex)) @@ -365,6 +379,9 @@ test_that('Train a distribution model with glmnet', { # Get layer expect_s4_class(mod |> get_data(), "SpatRaster") + # Expect formula + expect_s3_class(mod$get_equation(), "formula") + }) # ---- # @@ -377,6 +394,9 @@ test_that('Train a distribution model with bart', { suppressWarnings( requireNamespace('dbarts', quietly = TRUE) ) + # Set to verbose + options("ibis.setupmessages" = FALSE) + # Load data # Background Raster background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) @@ -445,6 +465,9 @@ test_that('Train a distribution model with INLABRU', { suppressWarnings( requireNamespace('inlabru', quietly = TRUE) ) + # Set to verbose + options("ibis.setupmessages" = FALSE) + # Load data # Background Raster background <- terra::rast(system.file('extdata/europegrid_50km.tif', package='ibis.iSDM',mustWork = TRUE)) diff --git a/vignettes/articles/01_data_preparationhelpers.Rmd b/vignettes/articles/01_data_preparationhelpers.Rmd index 83adb665..03b4294c 100644 --- a/vignettes/articles/01_data_preparationhelpers.Rmd +++ b/vignettes/articles/01_data_preparationhelpers.Rmd @@ -349,4 +349,43 @@ plot(!terra::noNA(new$aspect_mean_50km), main = "Missing observations") ## Preparing and altering future scenario data -< Upcoming :) > +Creating in scenarios in R requires input predictors to be formatted in a different +format than before. The *ibis.iSDM* package here makes extensive use of `stars` +to prepare and load multi-dimensional data. + +One common issue here that predictors are not in the requested time dimension. For +example climate data might only be available at a decadal scale (e.g. 2020, 2030, 2040), +yet predictions are often required on a finer temporal grain. + +For this purpose the *ibis.iSDM* contains a dedicated function (`interpolate_gaps()`), +that can also be directly called within `project()`. + +```{r} + +# Load some stars rasters +ll <- list.files(system.file('extdata/predictors_presfuture/', + package = 'ibis.iSDM', + mustWork = TRUE),full.names = TRUE) + +# Load the same files future ones +suppressWarnings( + pred_future <- stars::read_stars(ll) |> dplyr::slice('Time', seq(1, 86, by = 10)) +) +sf::st_crs(pred_future) <- sf::st_crs(4326) + +# The predictors are here only available every 10 years +stars::st_get_dimension_values(pred_future, 3) + +# --- # +# The ibis.iSDM contains here a function to make interpolation among timesteps, +# thus filling gaps in between. + +# As an example, +# Here we make a temporal interpolation to create an annual time series +new <- interpolate_gaps(pred_future, date_interpolation = "annual") + +stars::st_get_dimension_values(new, 3) + + +``` + From 5ec75be88d366e19a514ce28a6311cdbf9393478 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 14 Dec 2023 00:38:55 +0100 Subject: [PATCH 17/20] Missing dependency and listing --- DESCRIPTION | 1 + _pkgdown.yml | 1 + 2 files changed, 2 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index 7586cb7d..04fcf20b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,6 +40,7 @@ Imports: lwgeom, sf (>= 1.0), stars (>= 0.5), + zoo, stats, tibble (>= 2.0.0), uuid, diff --git a/_pkgdown.yml b/_pkgdown.yml index ef8bb076..f87aed39 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -133,6 +133,7 @@ reference: - predictor_transform - predictor_derivate - predictor_filter + - interpolate_gaps - run_stan - wrap_stanmodel - sanitize_names From 0c0c21d175847b51d75ac1591b6a71be5748c14b Mon Sep 17 00:00:00 2001 From: Martin-Jung Date: Wed, 13 Dec 2023 23:43:04 +0000 Subject: [PATCH 18/20] Update CITATION.cff --- CITATION.cff | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/CITATION.cff b/CITATION.cff index a60a2c3f..1ec53f0b 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -344,6 +344,25 @@ references: orcid: https://orcid.org/0000-0001-8049-7069 year: '2023' version: '>= 0.5' +- type: software + title: zoo + abstract: 'zoo: S3 Infrastructure for Regular and Irregular Time Series (Z''s Ordered + Observations)' + notes: Imports + url: https://zoo.R-Forge.R-project.org/ + repository: https://CRAN.R-project.org/package=zoo + authors: + - family-names: Zeileis + given-names: Achim + email: Achim.Zeileis@R-project.org + orcid: https://orcid.org/0000-0003-0918-3766 + - family-names: Grothendieck + given-names: Gabor + email: ggrothendieck@gmail.com + - family-names: Ryan + given-names: Jeffrey A. + email: jeff.a.ryan@gmail.com + year: '2023' - type: software title: stats abstract: 'R: A Language and Environment for Statistical Computing' From 395f7066d44c4a0e073239d888f446574be7ac24 Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 14 Dec 2023 00:53:34 +0100 Subject: [PATCH 19/20] Finally, addition to namespace for vignette #52 --- NAMESPACE | 1 + R/utils-scenario.R | 1 + 2 files changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 113e656c..501b5e66 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -112,6 +112,7 @@ export(get_rastervalue) export(ibis_dependencies) export(ibis_future) export(ibis_options) +export(interpolate_gaps) export(is.Id) export(is.Raster) export(is.Waiver) diff --git a/R/utils-scenario.R b/R/utils-scenario.R index 9898e61d..28c85821 100644 --- a/R/utils-scenario.R +++ b/R/utils-scenario.R @@ -17,6 +17,7 @@ #' # Interpolate stars stack #' sc <- interpolate_gaps( stack, "annual") #' } +#' @export interpolate_gaps <- function(env, date_interpolation = "annual"){ assertthat::assert_that( inherits(env, "stars"), From 51585984d3b364b3914abed5722f183717d47f4d Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Thu, 14 Dec 2023 11:27:31 +0100 Subject: [PATCH 20/20] Small documentation edits --- R/add_latent.R | 16 +- R/misc.R | 8 +- tests/testthat/test_modelFits.R | 238 +++++++++++++----------- tests/testthat/test_trainOtherEngines.R | 4 +- 4 files changed, 147 insertions(+), 119 deletions(-) diff --git a/R/add_latent.R b/R/add_latent.R index caf91dd4..6591b3a4 100644 --- a/R/add_latent.R +++ b/R/add_latent.R @@ -18,9 +18,9 @@ NULL #' #' @details There are several different options some of which depend on the #' engine used. In case a unsupported method for an engine is chosen this is -#' modified to the next similar method +#' modified to the next similar method. #' -#' Available are: +#' **Available are:** #' #' [*] \code{"spde"} - stochastic partial differential equation (SPDE) for #' [`engine_inla`] and [`engine_inlabru`]. SPDE effects aim at capturing the @@ -32,10 +32,12 @@ NULL #' elevation. Note that calculations of SPDE's can be computationally costly. #' * \code{"car"} - conditional autocorrelative errors (CAR) for [`engine_inla`]. Not yet implemented in full. #' * \code{"kde"} - additional covariate of the kernel density of input point observations. -#' * \code{"poly"} - spatial trend correction by adding coordinates as polynominal transformation. Available for all Engines. -#' * \code{"nnd"} - nearest neighbour distance. This function calculates the euclidean distance from each grid cell -#' to the nearest other grid cell with values. Applied across all datasets in -#' the [`BiodiversityDistribution-class`]) object. Available for all Engines. +#' * \code{"poly"} - spatial trend correction by adding coordinates as polynominal transformation. +#' This method assumed that a transformation of spatial coordinates can if - included as additional predictor - +#' explain some of the variance in the distribution. This method does not interact with species occurrences. +#' * \code{"nnd"} - nearest neighbour distance. This function calculates the euclidean distance from each point +#' to the nearest other grid cell with known species occurrence. Originally proposed by Allouche et al. (2008) +#' and can be applied across all datasets in the [`BiodiversityDistribution-class`]) object. #' #' @param x [distribution()] (i.e. [`BiodiversityDistribution-class`]) object. #' @param method A [`character`] describing what kind of spatial effect is to be @@ -49,7 +51,7 @@ NULL #' @param ... Other parameters passed down #' @returns Adds latent spatial effect to a [`distribution`] object. #' @references -#' * Fletcher, R., & Fortin, M. (2018). Spatial ecology and conservation modeling. Springer International Publishing. +#' * Allouche, O.; Steinitz, O.; Rotem, D.; Rosenfeld, A.; Kadmon, R. (2008). Incorporating distance constraints into species distribution models. Journal of Applied Ecology, 45(2), 599-609. doi:10.1111/j.1365-2664.2007.01445.x #' * Mendes, P., Velazco, S. J. E., de Andrade, A. F. A., & Júnior, P. D. M. (2020). Dealing with overprediction in species distribution models: How adding distance constraints can improve model accuracy. Ecological Modelling, 431, 109180. #' #' @keywords latent diff --git a/R/misc.R b/R/misc.R index 7e88c0ba..7fd360cc 100644 --- a/R/misc.R +++ b/R/misc.R @@ -94,10 +94,10 @@ ibis_dependencies <- function(deps = getOption("ibis.dependencies"), update = TR utils::install.packages("BiocManager") BiocManager::install(c("graph", "Rgraphviz"), dep=TRUE) # Then install INLA - utils::install.packages("INLA", - repos=c(getOption("repos"), - INLA="https://inla.r-inla-download.org/R/stable"), - dep=TRUE) + utils::install.packages("INLA", + repos=c(getOption("repos"), + INLA="https://inla.r-inla-download.org/R/stable"), + dep=TRUE) } suppressMessages( utils::install.packages(new.packages, dependencies = TRUE, quiet = TRUE, diff --git a/tests/testthat/test_modelFits.R b/tests/testthat/test_modelFits.R index 295096a4..d4394c0d 100644 --- a/tests/testthat/test_modelFits.R +++ b/tests/testthat/test_modelFits.R @@ -1,106 +1,132 @@ -# Further tests for model fits -test_that('Add further tests for model fits', { - - skip_if_not_installed("pdp") - - # Set to verbose - options("ibis.setupmessages" = FALSE) - - # 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) - virtual_range <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'range',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( - virtual_points2 <- add_pseudoabsence(virtual_points,template = background, field_occurrence = "Observed", settings = abs) - ) - - # Create testing and training data - ind <- sample(1:nrow(virtual_points2), 70) - train_data <- virtual_points2[-ind,] - test_data <- virtual_points2[ind,] - - # Now set them one up step by step - x <- distribution(background) |> - add_predictors(predictors, transform = 'none',derivates = 'none') |> - engine_glm() - - # Train 2 model - suppressWarnings( - mod <- train(x |> add_biodiversity_poipa(train_data, field_occurrence = 'Observed', - name = 'Virtual points',docheck = F), - "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) - ) - suppressWarnings( - mod_poipo <- train(x |> add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', - name = 'Virtual points',docheck = F), - "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) - ) - expect_s4_class(mod$get_data(), "SpatRaster") - - # Threshold with independent data - suppressMessages( - mod <- threshold(mod, method = "perc", format = "bin") - ) - expect_gt(mod$get_thresholdvalue(),0) - expect_length(mod$show_rasters(), 2) - - # Summarize model - expect_s3_class( summary(mod), "data.frame" ) - expect_s3_class( coef(mod), "data.frame" ) - - # Validate - val <- validate(mod, method = "cont") - expect_s3_class(val, "data.frame") - # Validate discrete - val <- validate(mod, method = "disc") - expect_s3_class(val, "data.frame") - - # Validate with withold data - val <- validate(mod, method = "disc", point = test_data,point_column = "Observed") - expect_s3_class(val, "data.frame") - - # ----------- # - # Project with separate data - pp <- mod$project(predictors |> as.data.frame(xy = TRUE, na.rm = FALSE)) - expect_s4_class(pp, "SpatRaster") - - # ----------- # - # Partial stuff - pp <- partial(mod, x.var = "bio19_mean_50km",plot = FALSE) - expect_s3_class(pp, "data.frame") - - # Spartial - pp <- spartial(mod,x.var = "bio19_mean_50km",plot = FALSE) - expect_s4_class(pp, "SpatRaster") - - # ----------- # - # Create a suitability index - o <- mod$calc_suitabilityindex() - expect_s4_class(o, "SpatRaster") - - # ----------- # - # Clip the projected data with an external mask - expect_no_error( mod$mask(virtual_range) ) - - # ----------- # - # Other functions - pp <- mod$get_centroid() - expect_s3_class(pp, "sf") - expect_length(mod$show_rasters(), 2) - - # ----------- # - # Write model outputs - tf <- base::tempfile() - expect_no_error(write_summary(mod, paste0(tf, ".rds"))) - expect_no_error(write_model(mod, paste0(tf, ".rds"))) - -}) +# Further tests for model fits +test_that('Add further tests for model fits', { + + skip_if_not_installed("pdp") + + # Set to verbose + options("ibis.setupmessages" = FALSE) + + # 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) + virtual_range <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'range',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( + virtual_points2 <- add_pseudoabsence(virtual_points,template = background, field_occurrence = "Observed", settings = abs) + ) + + # Create testing and training data + ind <- sample(1:nrow(virtual_points2), 70) + train_data <- virtual_points2[-ind,] + test_data <- virtual_points2[ind,] + + # Now set them one up step by step + x <- distribution(background) |> + add_predictors(predictors, transform = 'none',derivates = 'none') |> + engine_glm() + + # Train 2 model + suppressWarnings( + mod <- train(x |> add_biodiversity_poipa(train_data, field_occurrence = 'Observed', + name = 'Virtual points',docheck = F), + "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) + ) + suppressWarnings( + mod_poipo <- train(x |> add_biodiversity_poipo(virtual_points, field_occurrence = 'Observed', + name = 'Virtual points',docheck = F), + "test", inference_only = FALSE, only_linear = TRUE, varsel = "none", verbose = FALSE) + ) + expect_s4_class(mod$get_data(), "SpatRaster") + + # Threshold with independent data + suppressMessages( + mod <- threshold(mod, method = "perc", format = "bin") + ) + expect_gt(mod$get_thresholdvalue(),0) + expect_length(mod$show_rasters(), 2) + + # Summarize model + expect_s3_class( summary(mod), "data.frame" ) + expect_s3_class( coef(mod), "data.frame" ) + + # Validate + val <- validate(mod, method = "cont") + expect_s3_class(val, "data.frame") + # Validate discrete + val <- validate(mod, method = "disc") + expect_s3_class(val, "data.frame") + + # Validate with withold data + val <- validate(mod, method = "disc", point = test_data,point_column = "Observed") + expect_s3_class(val, "data.frame") + + # ----------- # + # Project with separate data + pp <- mod$project(predictors |> as.data.frame(xy = TRUE, na.rm = FALSE)) + expect_s4_class(pp, "SpatRaster") + + # ----------- # + # Partial stuff + pp <- partial(mod, x.var = "bio19_mean_50km",plot = FALSE) + expect_s3_class(pp, "data.frame") + + # Spartial + pp <- spartial(mod,x.var = "bio19_mean_50km",plot = FALSE) + expect_s4_class(pp, "SpatRaster") + + # ----------- # + # Create a suitability index + o <- mod$calc_suitabilityindex() + expect_s4_class(o, "SpatRaster") + + # ----------- # + # Clip the projected data with an external mask + expect_no_error( mod$mask(virtual_range) ) + + # ----------- # + # Other functions + pp <- mod$get_centroid() + expect_s3_class(pp, "sf") + expect_length(mod$show_rasters(), 2) + + # ----------- # + # Adding a range of latent constraints + y <- x |> add_biodiversity_poipa(train_data, field_occurrence = 'Observed', + name = 'Virtual points',docheck = F) + suppressWarnings( + mod1 <- train(y |> add_latent_spatial(method = "poly"), "test", inference_only = FALSE, + only_linear = TRUE, varsel = "none", verbose = FALSE) + ) + expect_true(length( grep("spatialtrend", mod1$get_coefficients()[,1] ) )>0) + suppressWarnings( + mod2 <- train(y |> add_latent_spatial(method = "nnd"), "test", inference_only = FALSE, + only_linear = TRUE, varsel = "none", verbose = FALSE) + ) + expect_true(length( grep("nearestpoint", mod2$get_coefficients()[,1] ) )>0) + suppressWarnings( + mod3 <- train(y |> add_latent_spatial(method = "kde"), "test", inference_only = FALSE, + only_linear = TRUE, varsel = "none", verbose = FALSE) + ) + expect_true(length( grep("kde", mod3$get_coefficients()[,1] ) )>0) + + # Make an ensemble + expect_no_error( + o <- ensemble(mod1, mod2, mod3, method = "median") + ) + expect_s4_class(o, "SpatRaster") + + # ----------- # + # Write model outputs + tf <- base::tempfile() + expect_no_error(write_summary(mod, paste0(tf, ".rds"))) + expect_no_error(write_model(mod, paste0(tf, ".rds"))) + +}) diff --git a/tests/testthat/test_trainOtherEngines.R b/tests/testthat/test_trainOtherEngines.R index fd8ab108..a1c3b526 100644 --- a/tests/testthat/test_trainOtherEngines.R +++ b/tests/testthat/test_trainOtherEngines.R @@ -290,7 +290,7 @@ test_that('Train a distribution model with glmnet', { virtual_points <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'points',quiet = TRUE) virtual_range <- sf::st_read(system.file('extdata/input_data.gpkg', package='ibis.iSDM',mustWork = TRUE),'range',quiet = TRUE) # Get list of test predictors - ll <- list.files(system.file('extdata/predictors/',package = 'ibis.iSDM',mustWork = TRUE),full.names = T) + 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)) @@ -345,7 +345,7 @@ test_that('Train a distribution model with glmnet', { expect_s4_class(ex, "SpatRaster") # Do ensemble partials work? - expect_no_error(ex <- ensemble_partial(mod,mod, x.var = "CLC3_312_mean_50km")) + expect_no_error(ex <- ensemble_partial(mod,mod2, x.var = "CLC3_312_mean_50km")) expect_s3_class(ex, 'data.frame') # Do ensemble spartials work