Merge branch 'into-the-clouds' into main

.Rbuildignore

@@ -34,3 +34,4 @@ vignettes/assets
 ^cran-comments\.md$
 ^CRAN-SUBMISSION$
 ^data-raw$
+^vsi-test$

DESCRIPTION

@@ -24,8 +24,8 @@ URL: https://mapme-initiative.github.io/mapme.biodiversity/index.html,
 BugReports: https://github.com/mapme-initiative/mapme.biodiversity/issues
 Depends: R (>= 3.5.0)
 SystemRequirements: GDAL (>= 3.0.0), PROJ (>= 4.8.0)
-Imports: curl, dplyr, furrr, httr, magrittr, progressr, purrr, rvest, R.utils,
-    sf, stringr, terra, tibble, tidyr, tidyselect
+Imports: curl, dplyr, furrr, httr, jsonlite, magrittr, progressr, purrr, 
+    R.utils, sf, terra, tibble, tidyr, tidyselect, withr
 Suggests: exactextractr, future, knitr, landscapemetrics, rmarkdown, rstac, SPEI, 
     testthat (>= 3.0.0)
 VignetteBuilder: knitr
@@ -38,6 +38,21 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Collate: 
     'register.R'
+    'buildings.R'
+    'calc_active_fire_counts.R'
+    'calc_active_fire_properties.R'
+    'calc_biome.R'
+    'calc_deforestation_drivers.R'
+    'calc_drought_indicator.R'
+    'calc_ecoregion.R'
+    'calc_elevation.R'
+    'calc_fatalities.R'
+    'calc_gsw_change.R'
+    'calc_gsw_occurrence.R'
+    'calc_gsw_recurrence.R'
+    'calc_gsw_seasonality.R'
+    'calc_gsw_transitions.R'
+    'buildings.R'
     'calc_active_fire_counts.R'
     'calc_active_fire_properties.R'
     'calc_biome.R'
@@ -65,7 +80,9 @@ Collate:
     'calc_treecover_area_and_emissions.R'
     'calc_treecoverloss_emissions.R'
     'calc_tri.R'
+    'cci.R'
     'engines.R'
+    'gdal_config.R'
     'get_chirps.R'
     'get_esalandcover.R'
     'get_fritz_et_al.R'
@@ -86,4 +103,5 @@ Collate:
     'get_worldpop.R'
     'mapme.biodiversity-pkg.R'
     'portfolio.R'
+    'spatial-utils.R'
     'utils.R'

NAMESPACE

@@ -3,16 +3,22 @@
 export(available_indicators)
 export(available_resources)
 export(calc_indicators)
+export(check_available_years)
+export(download_or_skip)
 export(get_resources)
 export(init_portfolio)
+export(make_footprints)
 export(read_portfolio)
 export(register_indicator)
 export(register_resource)
+export(spds_exists)
+export(unzip_and_remove)
 export(write_portfolio)
 import(sf)
 import(terra)
 importFrom(dplyr,last_col)
 importFrom(dplyr,relocate)
+importFrom(httr,http_error)
 importFrom(magrittr,"%>%")
 importFrom(purrr,walk)
 importFrom(stringr,str_replace)

R/buildings.R

@@ -0,0 +1,58 @@
+#' @keywords internal
+#' @include register.R
+#' @noRd
+.get_buildings <- function(
+    x,
+    rundir = tempdir(),
+    outdir = tempdir(),
+    verbose = TRUE){
+
+  world <- geodata::world(path = tempdir(), quiet = TRUE)
+  world <- st_as_sf(world)
+  world <- st_make_valid(world)
+
+  codes <- unique(world$GID_0[unlist(st_intersects(x, world))])
+
+  base <- "/vsicurl/https://data.source.coop/vida/google-microsoft-open-buildings/flageobuf/by_country/country_iso=%s/%s.fgb"
+  urls <- sprintf(base, codes, codes)
+  fps <- make_footprints(urls, what = "vector")
+  fps[["filename"]] <- basename(urls)
+  fps
+}
+
+register_resource(
+  name = "buildings",
+  type = "vector",
+  source = "source.coop",
+  fun = .get_buildings,
+  arguments = list()
+)
+
+#' @keywords internal
+#' @include register.R
+#' @noRd
+.calc_building_count <- function(
+    x,
+    buildings,
+    verbose = TRUE,
+    ...){
+
+  buildings <- do.call(rbind, buildings)
+  buildings <- buildings[unlist(st_contains(x, buildings)), ]
+  if(nrow(buildings) == 0) return(tibble(count = 0, google = 0, microsoft = 0))
+  counts <- table(buildings$bf_source)
+  n <- nrow(buildings)
+  tibble(count = n,
+         google = ifelse("google" %in% names(counts), counts[["google"]], 0),
+         microsoft = ifelse("microsoft" %in% names(counts), counts[["microsoft"]], 0)
+         )
+}
+
+register_indicator(
+  name = "building_count",
+  resources = list(buildings = "vector"),
+  fun = .calc_building_count,
+  arguments = list(),
+  processing_mode = "asset"
+)
+

R/calc_indicators.R

@@ -65,10 +65,11 @@ calc_indicators <- function(x, indicators, ...) {
   avail_resources <- atts[["resources"]]
   req_resources <- selected_indicator[[indicator]][["resources"]]
 
-  processor <- switch(processing_mode,
-                      asset = .asset_processor,
-                      portfolio = .portfolio_processor,
-                      stop(sprintf("Processing mode '%s' is not supported.", processing_mode)))
+  processor <- switch(
+    processing_mode,
+    asset = .asset_processor,
+    portfolio = .portfolio_processor,
+    stop(sprintf("Processing mode '%s' is not supported.", processing_mode)))
 
   results <- processor(x, fun, avail_resources, req_resources, params)
   # bind the asset results
@@ -82,106 +83,25 @@ calc_indicators <- function(x, indicators, ...) {
   x
 }
 
-
-
-.prep_resources <- function(x, avail_resources, req_resources) {
-  if (any(!names(req_resources) %in% names(avail_resources))) {
-    stop("Some required resources are not available.")
-  }
-  purrr::imap(req_resources, function(resource_type, resource_name) {
-    reader <- switch(resource_type,
-                     raster = .read_raster,
-                     vector = .read_vector,
-                     stop(sprintf("Resource type '%s' currently not supported", resource_type)))
-    reader(x, avail_resources[[resource_name]])})
-}
-
-.read_vector <- function(x, vector_sources) {
-  vectors <- purrr::map(vector_sources, function(source) {
-    tmp <- read_sf(source, wkt_filter = st_as_text(st_as_sfc(st_bbox(x))))
-    st_make_valid(tmp)
-  })
-  names(vectors) <- basename(vector_sources)
-  vectors
-}
-
-.read_raster <- function(x, tindex) {
-
-  if (st_crs(x) != st_crs(tindex)) {
-    x <- st_transform(x, st_crs(tindex))
-  }
-
-  geoms <- tindex[["geom"]]
-  unique_geoms <- unique(geoms)
-  grouped_geoms <- match(geoms, unique_geoms)
-  names(grouped_geoms) <- tindex[["location"]]
-  grouped_geoms <- sort(grouped_geoms)
-
-  n_tiles <- length(unique(grouped_geoms))
-  n_timesteps <- unique(table(grouped_geoms))
-
-  if (length(n_timesteps) > 1) {
-    stop("Did not find equal number of tiles per timestep.")
-  }
-
-  out <- lapply(1:n_timesteps, function(i){
-    index <- rep(FALSE, n_timesteps)
-    index[i] <- TRUE
-    filenames <- names(grouped_geoms[index])
-    layer_name <- tools::file_path_sans_ext(basename(filenames[1]))
-    vrt_name <- tempfile(pattern = sprintf("vrt_%s", layer_name), fileext = ".vrt")
-    tmp <- terra::vrt(filenames, filename = vrt_name)
-    names(tmp) <- layer_name
-    tmp
-  })
-  out <- do.call(c, out)
-
-  # crop the source to the extent of the current polygon
-  cropped <- try(terra::crop(out, terra::vect(x), snap = "out"))
-  if (inherits(cropped, "try-error")) {
-    warning(as.character(cropped))
-    return(NULL)
-  }
-  cropped
-}
-
 .asset_processor <- function(
     x,
     fun,
     avail_resources,
     req_resources,
     params){
 
-  p <- progressr::progressor(steps = nrow(x))
-  furrr::future_map(1:nrow(x), function(i) {
+
+  n <- nrow(x)
+  p <- progressr::progressor(steps = n)
+
+  furrr::future_map(seq_len(n), function(i) {
     p()
     resources <- .prep_resources(x[i, ], avail_resources, req_resources)
     result <- .compute(x[i, ], resources, fun, params)
     .check_single_asset(result, i)
   }, .options = furrr::furrr_options(seed = TRUE))
 }
 
-#' @noRd
-#' @importFrom utils str
-.check_single_asset <- function(obj, i){
-
-  if (inherits(obj, "try-error")) {
-    warning(sprintf("At asset %s an error occured. Returning NA.\n", i), obj)
-    return(NA)
-  }
-
-  if (!inherits(obj, "tbl_df")) {
-    warning(sprintf("At asset %s a non-tibble object was returned. Returning NA.\n", i), str(obj))
-    return(NA)
-  }
-
-  if (nrow(obj) == 0) {
-    warning(sprintf("At asset %s a 0-length tibble was returned. Returning NA.", i))
-    return(NA)
-  }
-  obj
-}
-
 .portfolio_processor <- function(
     x,
     fun,
@@ -204,6 +124,26 @@ calc_indicators <- function(x, indicators, ...) {
   try(do.call(what = fun, args = args), silent = TRUE)
 }
 
+#' @importFrom utils str
+.check_single_asset <- function(obj, i){
+
+  if (inherits(obj, "try-error")) {
+    warning(sprintf("At asset %s an error occured. Returning NA.\n", i), obj)
+    return(NA)
+  }
+
+  if (!inherits(obj, "tbl_df")) {
+    warning(sprintf("At asset %s a non-tibble object was returned. Returning NA.\n", i), str(obj))
+    return(NA)
+  }
+
+  if (nrow(obj) == 0) {
+    warning(sprintf("At asset %s a 0-length tibble was returned. Returning NA.", i))
+    return(NA)
+  }
+  obj
+}
+
 .bind_assets <- function(results) {
   # bind results to data.frame
   index_tbl <- purrr::map_lgl(results, function(x) inherits(x, c("tbl_df", "data.frame")))

R/calc_treecover_area_and_emissions.R

@@ -88,6 +88,7 @@ NULL
   # check additional arguments
   .gfw_check_min_cover(min_cover, "treecover_area")
   .gfw_check_min_size(min_size, "treecover_area")
+
   # handling of return value if resources are missing, e.g. no overlap
   if (any(is.null(gfw_treecover), is.null(gfw_lossyear), is.null(gfw_emissions))) {
     return(NA)
@@ -145,8 +146,6 @@ NULL
   tibble::as_tibble(gfw_stats)
 }
 
-
-
 register_indicator(
   name = "treecover_area_and_emissions",
   resources = list(

R/calc_treecoverloss_emissions.R

@@ -81,6 +81,7 @@ NULL
   # check additional arguments
   .gfw_check_min_cover(min_cover, "treecover_area")
   .gfw_check_min_size(min_size, "treecover_area")
+
   # handling of return value if resources are missing, e.g. no overlap
   if (any(is.null(gfw_treecover), is.null(gfw_lossyear), is.null(gfw_emissions))) {
     return(NA)