Merge pull request #1170 from M3nin0/feat/deaustralia

Author: gilbertocamara

DESCRIPTION

@@ -181,11 +181,13 @@ Collate:
     'api_source_bdc.R'
     'api_source_cdse.R'
     'api_source_deafrica.R'
+    'api_source_deaustralia.R'
     'api_source_hls.R'
     'api_source_local.R'
     'api_source_mpc.R'
     'api_source_sdc.R'
     'api_source_stac.R'
+    'api_source_terrascope.R'
     'api_source_usgs.R'
     'api_space_time_operations.R'
     'api_stac.R'

NAMESPACE

@@ -175,15 +175,19 @@ S3method(.source_items_fid,stac_cube)
 S3method(.source_items_new,"aws_cube_landsat-c2-l2")
 S3method(.source_items_new,"deafrica_cube_sentinel-1-rtc")
 S3method(.source_items_new,"deafrica_cube_sentinel-2-l2a")
+S3method(.source_items_new,"deaustralia_cube_sentinel-2a")
+S3method(.source_items_new,"deaustralia_cube_sentinel-2b")
 S3method(.source_items_new,"mpc_cube_cop-dem-glo-30")
 S3method(.source_items_new,"mpc_cube_landsat-c2-l2")
 S3method(.source_items_new,"mpc_cube_sentinel-1-grd")
 S3method(.source_items_new,"mpc_cube_sentinel-1-rtc")
 S3method(.source_items_new,"mpc_cube_sentinel-2-l2a")
+S3method(.source_items_new,"terrascope_cube_world-cover-2021")
 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,deaustralia_cube)
 S3method(.source_items_new,hls_cube)
 S3method(.source_items_new,mpc_cube)
 S3method(.source_items_new,sdc_cube)
@@ -200,10 +204,12 @@ S3method(.source_items_tile,"mpc_cube_mod13q1-6.1")
 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,"terrascope_cube_world-cover-2021")
 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,deaustralia_cube)
 S3method(.source_items_tile,hls_cube)
 S3method(.source_items_tile,sdc_cube)
 S3method(.source_items_tile,usgs_cube)

R/api_check.R

@@ -1859,7 +1859,7 @@
     })
     classes_num <- unique(unlist(classes_list))
     classes_num <- classes_num[!is.na(classes_num)]
-    labels_num <- names(.cube_labels(cube))
+    labels_num <- names(unlist(.cube_labels(cube, dissolve = FALSE)))
     # do the labels and raster numbers match?
     .check_that(all(classes_num %in% labels_num))
     return(invisible(cube))

R/api_conf.R

@@ -707,53 +707,41 @@
             msg = .conf("messages", ".conf_new_collection_metadata")
         )
     }
-    # bands names is upper case
-    names(bands) <- toupper(names(bands))
-    # separate cloud and non-cloud bands
-    non_cloud_bands <- bands[!names(bands) %in% .source_cloud()]
-    cloud_band <- bands[names(bands) %in% .source_cloud()]
-
-    non_cloud_bands <- lapply(non_cloud_bands, function(band) {
-        # pre-condition
-        .check_lst(bands,
-            len_min = 1,
-            msg = .conf("messages", ".conf_new_collection_bands")
-        )
-        # bands' members are lower case
-        names(band) <- tolower(names(band))
-        band <- .check_error(
-            {
-                do.call(.conf_new_band, args = band)
-            },
-            msg = .conf("messages", ".conf_new_collection_bands")
-        )
-        return(band)
-    })
-
-    cloud_band <- lapply(cloud_band, function(cloud_band) {
-        # pre-condition
-        .check_lst(bands,
-            len_min = 1,
-            msg = .conf("messages", ".conf_new_collection_bands")
-        )
-        # bands' members are lower case
-        names(cloud_band) <- tolower(names(cloud_band))
-        cloud_band <- .check_error(
-            {
-                do.call(.conf_new_cloud_band, args = cloud_band)
-            },
-            msg = .conf("messages", ".conf_new_collection_bands")
-        )
-        return(cloud_band)
-    })
-
-    # extra parameters
+    # check extra parameters
     dots <- list(...)
     .check_lst(dots,
                msg = .conf("messages", ".conf_new_collection_metadata_args")
     )
-
-    res <- c(list(bands = c(non_cloud_bands, cloud_band)),
+    # bands names is upper case
+    names(bands) <- toupper(names(bands))
+    # pre-condition
+    .check_lst(bands,
+               len_min = 1,
+               msg = .conf("messages", ".conf_new_collection_bands")
+    )
+    # define collection bands
+    collection_bands <- c()
+    # handle class bands
+    is_class_cube <- dots[["class_cube"]]
+    is_class_cube <- all(!is.null(is_class_cube))
+    if (is_class_cube) {
+        # configure class bands (assuming there is no cloud band in class cubes)
+        class_bands <- .conf_new_bands(bands, .conf_new_class_band)
+        # save band configuration object
+        collection_bands <- c(class_bands)
+    } else {
+        # handle cloud and non-cloud bands
+        cloud_band <- bands[names(bands) %in% .source_cloud()]
+        non_cloud_bands <- bands[!names(bands) %in% .source_cloud()]
+        # cloud bands
+        cloud_band <- .conf_new_bands(cloud_band, .conf_new_cloud_band)
+        # non-cloud bands
+        non_cloud_bands <- .conf_new_bands(non_cloud_bands, .conf_new_band)
+        # save bands configuration object
+        collection_bands <- c(non_cloud_bands, cloud_band)
+    }
+    # merge metadata properties
+    res <- c(list(bands = collection_bands),
         "satellite" = satellite,
         "sensor" = sensor,
         "metadata_search" = metadata_search, dots
@@ -896,6 +884,66 @@
     # return a cloud band object
     return(cloud_band_params)
 }
+#' @title Include a new class band in the configuration
+#' @name .conf_new_class_band
+#' @description creates a description associated to a new cloud band
+#' @param bit_mask       bit mask to describe clouds (if applicable)
+#' @param values         values of the class band
+#' @param resolution     spatial resolution (in meters)
+#' @param band_name      name of the band
+#' @param ...            other relevant parameters
+#' @keywords internal
+#' @noRd
+#' @return   list with the configuration associated to the new class band
+.conf_new_class_band <- function(bit_mask, values, resolution, band_name, ...) {
+    # set caller to show in errors
+    .check_set_caller(".conf_new_class_band")
+    # pre-condition
+    .check_lgl_parameter(bit_mask)
+    .check_lst_parameter(values, fn_check = .check_chr)
+    .check_chr_parameter(band_name, len_min = 1, len_max = 1)
+
+    # check extra parameters
+    dots <- list(...)
+    .check_lst(dots, msg = .conf("messages",
+                                 ".check_new_class_band_dots"))
+
+    # build band
+    class_band_params <- c(list(
+        bit_mask = bit_mask,
+        values = values,
+        resolution = resolution,
+        band_name = band_name
+    ), dots)
+
+    # post-condition
+    .check_lst_parameter(class_band_params, len_min = 4)
+
+    # return a class band object
+    return(class_band_params)
+}
+#' @title Configure bands
+#' @name .conf_new_bands
+#' @description creates a description of multiple bands based on a user-defined
+#' strategy.
+#' @param bands       bands to be configured
+#' @param config_fnc  band configuration strategy function
+#' @keywords internal
+#' @noRd
+#' @return   list of configurations associated with the given bands
+.conf_new_bands <- function(bands, config_fnc) {
+    lapply(bands, function(band) {
+        # lower case bands
+        names(band) <- tolower(names(band))
+        # configure band
+        .check_error(
+            {
+                do.call(config_fnc, args = band)
+            },
+            msg = .conf("messages", ".conf_new_collection_bands")
+        )
+    })
+}
 #' @title Retrieve the rstac pagination limit
 #' @name .conf_rstac_limit
 #' @keywords internal