merge support for CDSE

Author: gilbertocamara

DESCRIPTION

@@ -64,6 +64,7 @@ Imports:
     torch (>= 0.11.0),
     utils
 Suggests:
+    aws.s3,
     caret,
     cli,
     covr,
@@ -130,6 +131,7 @@ Collate:
     'api_data.R'
     'api_debug.R'
     'api_download.R'
+    'api_environment.R'
     'api_factory.R'
     'api_file_info.R'
     'api_file.R'
@@ -167,6 +169,7 @@ Collate:
     'api_source.R'
     'api_source_aws.R'
     'api_source_bdc.R'
+    'api_source_cdse.R'
     'api_source_deafrica.R'
     'api_source_hls.R'
     'api_source_local.R'

NAMESPACE

@@ -126,20 +126,26 @@ S3method(.reg_s2tile_convert,grd_cube)
 S3method(.reg_s2tile_convert,rtc_cube)
 S3method(.slice_dfr,numeric)
 S3method(.source_collection_access_test,"mpc_cube_sentinel-1-grd")
+S3method(.source_collection_access_test,cdse_cube)
 S3method(.source_collection_access_test,mpc_cube)
 S3method(.source_collection_access_test,stac_cube)
 S3method(.source_collection_access_test,usgs_cube)
 S3method(.source_cube,stac_cube)
+S3method(.source_filter_tiles,"cdse_cube_sentinel-1-rtc")
 S3method(.source_filter_tiles,"mpc_cube_sentinel-1-grd")
 S3method(.source_filter_tiles,stac_cube)
 S3method(.source_item_get_bands,stac_cube)
+S3method(.source_item_get_cloud_cover,cdse_cube)
 S3method(.source_item_get_cloud_cover,sdc_cube)
 S3method(.source_item_get_cloud_cover,stac_cube)
+S3method(.source_item_get_date,cdse_cube)
+S3method(.source_item_get_date,deafrica_cube)
 S3method(.source_item_get_date,stac_cube)
 S3method(.source_item_get_hrefs,bdc_cube)
 S3method(.source_item_get_hrefs,sdc_cube)
 S3method(.source_item_get_hrefs,stac_cube)
 S3method(.source_item_get_hrefs,usgs_cube)
+S3method(.source_items_bands_select,cdse_cube)
 S3method(.source_items_bands_select,stac_cube)
 S3method(.source_items_cube,stac_cube)
 S3method(.source_items_fid,stac_cube)
@@ -150,25 +156,31 @@ S3method(.source_items_new,"mpc_cube_sentinel-1-rtc")
 S3method(.source_items_new,"mpc_cube_sentinel-2-l2a")
 S3method(.source_items_new,aws_cube)
 S3method(.source_items_new,bdc_cube)
+S3method(.source_items_new,cdse_cube)
 S3method(.source_items_new,deafrica_cube)
 S3method(.source_items_new,deafrica_cube_s2_l2a)
 S3method(.source_items_new,hls_cube)
 S3method(.source_items_new,sdc_cube)
 S3method(.source_items_new,usgs_cube)
 S3method(.source_items_tile,"aws_cube_landsat-c2-l2")
+S3method(.source_items_tile,"cdse_cube_sentinel-1-rtc")
 S3method(.source_items_tile,"mpc_cube_landsat-c2-l2")
 S3method(.source_items_tile,"mpc_cube_sentinel-1-grd")
 S3method(.source_items_tile,"mpc_cube_sentinel-1-rtc")
 S3method(.source_items_tile,"mpc_cube_sentinel-2-l2a")
 S3method(.source_items_tile,aws_cube)
 S3method(.source_items_tile,bdc_cube)
+S3method(.source_items_tile,cdse_cube)
 S3method(.source_items_tile,deafrica_cube)
+S3method(.source_items_tile,deafrica_cube_rainfall_chirps_daily)
+S3method(.source_items_tile,deafrica_cube_rainfall_chirps_monthly)
 S3method(.source_items_tile,hls_cube)
 S3method(.source_items_tile,sdc_cube)
 S3method(.source_items_tile,usgs_cube)
 S3method(.source_roi_tiles,"mpc_cube_landsat-c2-l2")
 S3method(.source_roi_tiles,sdc_cube)
 S3method(.source_roi_tiles,stac_cube)
+S3method(.source_tile_get_bbox,"cdse_cube_sentinel-1-rtc")
 S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-grd")
 S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-rtc")
 S3method(.source_tile_get_bbox,stac_cube)
@@ -398,7 +410,6 @@ S3method(summary,sits_area_accuracy)
 export("sits_bands<-")
 export("sits_labels<-")
 export(.mpc_clean_token_cache)
-export(.plot_false_color)
 export(impute_linear)
 export(sits_accuracy)
 export(sits_accuracy_summary)

R/api_apply.R

@@ -82,10 +82,9 @@
     # Get band configuration
     band_conf <- .tile_band_conf(tile = feature, band = out_band)
     if (.has_not(band_conf)) {
+        band_conf <- .conf("default_values", "FLT4S")
         if (normalized)
             band_conf <- .conf("default_values", "INT2S")
-        else
-            band_conf <- .conf("default_values", "FLT4S")
     }
     # Process jobs sequentially
     block_files <- .jobs_map_sequential(chunks, function(chunk) {
@@ -142,6 +141,8 @@
         # Returned block files for each fraction
         block_files
     })
+    # Remove NULL values from block files list
+    block_files <- Filter(function(x) !is.null(x), block_files)
     # Merge blocks into a new eo_cube tile
     band_tile <- .tile_eo_merge_blocks(
         files = out_file,

R/api_conf.R

@@ -132,7 +132,6 @@
 
     return(yml_file)
 }
-
 #' @title Return the internal configuration file (only for developers)
 #' @name .conf_internals_file
 #' @keywords internal
@@ -146,6 +145,57 @@
     .check_that(file.exists(yml_file))
     return(yml_file)
 }
+#' @title Return the message configuration files (only for developers)
+#' @name .conf_sources_files
+#' @keywords internal
+#' @noRd
+#' @return internal sources configuration
+.conf_sources_files <- function() {
+    .check_set_caller(".conf_sources_files")
+    # list the source files configurations
+    package_files <- system.file("extdata", "sources", package = "sits")
+    yml_files <- list.files(
+        path = package_files,
+        pattern = "config_source_*",
+        full.names = TRUE
+    )
+    # check that the file name is valid
+    purrr::map(yml_files, .check_file)
+    return(yml_files)
+}
+#' @name .conf_load_sources
+#' @description Loads sources configurations
+#' @keywords internal
+#' @noRd
+#' @return NULL, called for side effects
+.conf_load_sources <- function() {
+    # get file paths
+    source_yml_files <- .conf_sources_files()
+    # load files
+    source_configs <- purrr::map(source_yml_files, function(file) {
+        yaml::yaml.load_file(
+            input = file,
+            merge.precedence = "override"
+        )
+    })
+    # prepare sources object
+    source_obj <- purrr::map(source_configs, "sources")
+    source_obj <- purrr::flatten(source_obj)
+    # prepare extras objects (e.g., token, url config)
+    extras_obj <- purrr::map(source_configs, function(source_config) {
+        source_config[["sources"]] <- NULL
+        source_config
+    })
+    extras_obj <- purrr::flatten(extras_obj)
+    # merge objects
+    config_obj <- utils::modifyList(extras_obj, list(
+        sources = source_obj
+    ))
+    # set configurations
+    do.call(.conf_set_options, args = config_obj)
+    # done
+    return(invisible(NULL))
+}
 #' @title Return the message configuration file (only for developers)
 #' @name .conf_messages_file
 #' @keywords internal

R/api_environment.R

@@ -0,0 +1,121 @@
+
+# ---- Environment operations ----
+#' @title Function to patch environment variables (Developer only).
+#' @keywords internal
+#' @noRd
+#'
+#' @description
+#'  This function patches environment variables, swapping them from a `source`
+#'  to a `target` variable. You can rollback the swap operation using the
+#'  `.environment_rollback.`
+#'
+#' @note
+#'  This function is suitable only for internal `sits` tests and should not be
+#'  used for any other purpose.
+#' @param env_config List with the configuration of the environment.
+#' @return           Called for side effects.
+.environment_patch <- function(env_config) {
+    env_prefix <- env_config[["name"]]
+    env_variables <- env_config[["variables"]]
+
+    purrr::map(1:length(env_variables), function(var_idx) {
+        var_source <- names(env_variables)[[var_idx]]
+        var_target <- unname(env_variables)[[var_idx]]
+        # Get current value of the target variable
+        var_target_value <- Sys.getenv(var_target)
+        # Save current value of the target variable in the "swap area"
+        var_target_swap <- paste(env_prefix, var_target, sep = "_SWAP_")
+        var_target_swap_value <- list(tmp = var_target_value)
+        var_target_swap_value <- stats::setNames(
+            var_target_swap_value,
+            var_target_swap
+        )
+        # Save variable
+        do.call(Sys.setenv, var_target_swap_value)
+        # Get the new value of the target variable
+        var_source_value <- Sys.getenv(var_source)
+        # Save new value in the target variable
+        var_target_new_value <- list(tmp = var_source_value)
+        var_target_new_value <- stats::setNames(
+            var_target_new_value,
+            var_target
+        )
+        # Save variable
+        do.call(Sys.setenv, var_target_new_value)
+    })
+    return(invisible(NULL))
+}
+
+#' @title Function to rollback patch in environment variables (Developer only).
+#' @keywords internal
+#' @noRd
+#'
+#' @description
+#'  This function rollback patches in environment variables created with the
+#'  function `.environment_patch`.
+#' @note
+#'  This function is suitable only for internal `sits` tests and should not be
+#'  used for any other purpose.
+#' @param env_config List with the configuration of the environment.
+#' @return           Called for side effects.
+.environment_rollback <- function(env_config) {
+    env_prefix <- env_config[["name"]]
+    env_variables <- env_config[["variables"]]
+
+    purrr::map(1:length(env_variables), function(var_idx) {
+        var_source <- names(env_variables)[[var_idx]]
+        var_target <- unname(env_variables)[[var_idx]]
+        # Get current value of the target variable
+        var_target_value <- Sys.getenv(var_target)
+        # Save current value in the source variable
+        var_source_new_value <- list(tmp = var_target_value)
+        var_source_new_value <- stats::setNames(
+            var_source_new_value,
+            var_source
+        )
+        do.call(Sys.setenv, var_source_new_value)
+        # Get current value of the target variable in the "swap area"
+        var_target_swap <- paste(env_prefix, var_target, sep = "_SWAP_")
+        var_target_swap_value <- Sys.getenv(var_target_swap)
+        # Prepare current target
+        var_target_swap_value <- list(tmp = var_target_swap_value)
+        var_target_swap_value <- stats::setNames(
+            var_target_swap_value,
+            var_target
+        )
+        do.call(Sys.setenv, var_target_swap_value)
+    })
+    return(invisible(NULL))
+}
+
+# ---- Environment configurations ----
+#' @title Function to create patch configuration for the CDSE source.
+#' @keywords internal
+#' @noRd
+#'
+#' @description
+#'  This function creates a configuration for the `patch` and `rollback`
+#'  specialized for the CDSE requirements.
+#' @note
+#'  This function is suitable only for internal `sits` tests and should not be
+#'  used for any other purpose.
+#' @return           List with the configuration of the CDSE environment.
+.environment_cdse <- function() {
+    # Define environment name. This name is used as a prefix for the
+    # "swap area" which is used to keep values saved
+    env_name <- "CDSE"
+    # Create the environment variables
+    env_variables <- list(
+        "CDSE_ACCESS_KEY_ID"     = "AWS_ACCESS_KEY_ID",
+        "CDSE_SECRET_ACCESS_KEY" = "AWS_SECRET_ACCESS_KEY",
+        "CDSE_S3_ENDPOINT"       = "AWS_S3_ENDPOINT",
+        "CDSE_VIRTUAL_HOSTING"   = "AWS_VIRTUAL_HOSTING"
+    )
+    # Create a base environment definition
+    env_definition <-
+        list(name = env_name, variables = env_variables)
+    # Define a class, based on the name
+    class(env_definition) <- c(env_name, "list")
+    # Done!
+    env_definition
+}

R/api_plot_raster.R

@@ -19,8 +19,6 @@
 #' @param  scale         Scale to plot map (0.4 to 1.0)
 #'
 #' @return               A plot object
-#' @export
-#'
 .plot_false_color <- function(tile,
                               band,
                               date,
@@ -103,7 +101,8 @@
                 n = n_colors,
                 palette = palette,
                 title = band,
-                midpoint = NA
+                midpoint = NA,
+                style.args = list(na.rm = TRUE)
             ) +
             tmap::tm_graticules(
                 labels.size = labels_size

R/api_regularize.R

@@ -199,8 +199,11 @@
     cube <- tiles_mgrs |>
         dplyr::rowwise() |>
         dplyr::group_map(~{
-            # prepare a sf object with the bbox of each image in file_info
+            # prepare a sf object representing the bbox of each image in file_info
             cube_crs <- dplyr::filter(cube, .data[["crs"]] == .x[["crs"]])
+            if (nrow(cube_crs) == 0) {
+                cube_crs <- cube
+            }
             fi_bbox <- .bbox_as_sf(.bbox(
                 x = .fi(cube_crs),
                 default_crs = .crs(cube_crs),