Merge pull request #1488 from OldLipe/feat/reclassify-tile

Restrict support to irregular cubes in `sits_merge` and update world cover STAC

Author: gilbertocamara

DESCRIPTION

@@ -112,7 +112,6 @@ Config/testthat/start-first: cube, raster, regularize, data, ml
 LinkingTo:
     Rcpp,
     RcppArmadillo
-RoxygenNote: 7.3.3
 Collate: 
     'api_accessors.R'
     'api_accuracy.R'
@@ -296,3 +295,4 @@ Collate:
     'sits_variance.R'
     'sits_xlsx.R'
     'zzz.R'
+Config/roxygen2/version: 8.0.0

NAMESPACE

@@ -469,7 +469,6 @@ S3method(sits_reclassify,probs_cube)
 S3method(sits_reclassify,probs_vector_cube)
 S3method(sits_reduce,raster_cube)
 S3method(sits_reduce,sits)
-S3method(sits_regularize,combined_cube)
 S3method(sits_regularize,default)
 S3method(sits_regularize,dem_cube)
 S3method(sits_regularize,derived_cube)

R/api_merge.R

@@ -174,53 +174,22 @@
 .merge_cube_compactify <- function(data1, data2) {
     # extract tiles
     tiles <- .merge_get_common_tiles(data1, data2)
-    if (.has(tiles)) {
-        # align timeline tile by tile.
-        merged_cube <- .map_dfr(tiles, function(tile) {
-            # get tiles
-            tile1 <- .cube_filter_tiles(data1, tile)
-            tile2 <- .cube_filter_tiles(data2, tile)
-            # get tile timelines
-            ts1 <- .tile_timeline(tile1)
-            ts2 <- .tile_timeline(tile2)
-            # adjust timeline using zipper strategy
-            ts_overlap <- .merge_zipper_strategy(ts1, ts2)
-            # filter cubes in the overlapping dates
-            tile1 <- .cube_filter_dates(tile1, ts_overlap)
-            tile2 <- .cube_filter_dates(tile2, ts_overlap)
-            # merge by file
-            .merge_strategy_file(tile1, tile2)
-        })
-    } else {
-        # It is not possible to merge non-common tiles with multiple bands using
-        # the same sensor
-        .check_that(
-            .cube_sensor(data1) != .cube_sensor(data2),
-            msg = .conf("messages", ".merge_irregular_bands")
-        )
-        # if no common tiles are available, use a global reference timeline.
-        # in this case, this timeline is generated by the merge of all timelines
-        # in the reference cube (cube 1)
-        reference_timeline <- as.Date(unlist(.cube_timeline(data1)))
-        # based on the global timeline, cut the timeline of all tiles in cube 2
-        merged_cube <- .cube_foreach_tile(data2, function(row) {
-            # get row timeline
-            row_timeline <- .tile_timeline(row)
-            # search overlaps between the reference timeline and row timeline
-            t_overlap <- .merge_zipper_strategy(
-                t1 = reference_timeline,
-                t2 = row_timeline
-            )
-            # cut the timeline
-            .cube_filter_dates(row, t_overlap)
-        })
-        # as there is no tile reference, merge using `bind` strategy (cube row)
-        merged_cube <- .merge_strategy_bind(data1, merged_cube)
-        # assign `combined cube` class, meaning the cube is a combination of
-        # cubes that contains different timelines in different tiles
-        class(merged_cube) <- c("combined_cube", class(data1))
-        merged_cube
-    }
+    # align timeline tile by tile.
+    merged_cube <- .map_dfr(tiles, function(tile) {
+        # get tiles
+        tile1 <- .cube_filter_tiles(data1, tile)
+        tile2 <- .cube_filter_tiles(data2, tile)
+        # get tile timelines
+        ts1 <- .tile_timeline(tile1)
+        ts2 <- .tile_timeline(tile2)
+        # adjust timeline using zipper strategy
+        ts_overlap <- .merge_zipper_strategy(ts1, ts2)
+        # filter cubes in the overlapping dates
+        tile1 <- .cube_filter_dates(tile1, ts_overlap)
+        tile2 <- .cube_filter_dates(tile2, ts_overlap)
+        # merge by file
+        .merge_strategy_file(tile1, tile2)
+    })
 }
 #' @title  Define merge strategy based on intersecting the timeline
 #' @name   .merge_strategy_intersects
@@ -396,28 +365,6 @@
     # Return merged cube
     merged_cube
 }
-#' @title  Merge strategy for irregular cubes
-#' @name   .merge.irregular_case
-#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br}
-#' @author Felipe Carlos,   \email{efelipecarlos@@gmail.com}
-#' @noRd
-#' @param  data1     Data cube
-#' @param  data2     Data cube
-#' @return           Merged data cube
-.merge.irregular_case <- function(data1, data2) {
-    # verify if cube has the same bands
-    has_same_bands <- .merge_has_equal_bands(data1, data2)
-    # rule 1: if the bands are the same, combine cubes (`densify`)
-    if (has_same_bands) {
-        # merge!
-        .merge_cube_densify(data1, data2)
-    } else {
-        # rule 2: if the bands are different and their timelines are
-        # compatible, the bands are joined. The resulting timeline is the one
-        # from the first cube.
-        .merge_cube_compactify(data1, data2)
-    }
-}
 
 #' @title  Merges cubes based on adequate strategy
 #' @name   .merge
@@ -434,40 +381,19 @@
     if (.merge_type_hls(data1, data2)) {
         return("hls_case")
     }
-    if (.merge_type_deaustralia_s2(data1, data2)) {
-        return("irregular_case")
-    }
     if (.merge_type_regular(data1, data2)) {
         return("regular_case")
     }
-    if (.merge_type_irregular(data1, data2)) {
-        return("irregular_case")
-    }
     # find no alternative? error messages
     stop(.conf("messages", ".merge_type"), toString(class(data1)))
 }
 .merge_type_regular <- function(data1, data2) {
     .cube_is_regular(data1) &&
-        .cube_is_regular(data2) &&
-        .cube_has_unique_period(data1) &&
-        .cube_has_unique_period(data2)
+        .cube_is_regular(data2)
 }
 .merge_type_dem <- function(data1, data2) {
     any(inherits(data1, "dem_cube"), inherits(data2, "dem_cube"))
 }
 .merge_type_hls <- function(data1, data2) {
     all(inherits(data1, "hls_cube"), inherits(data2, "hls_cube"))
 }
-.merge_type_deaustralia_s2 <- function(data1, data2) {
-    all(
-        inherits(data1, "deaustralia_cube_ga_s2am_ard_3"),
-        inherits(data2, "deaustralia_cube_ga_s2am_ard_3")
-    ) ||
-        all(
-            inherits(data1, "deaustralia_cube_ga_s2bm_ard_3"),
-            inherits(data2, "deaustralia_cube_ga_s2bm_ard_3")
-        )
-}
-.merge_type_irregular <- function(data1, data2) {
-    !(.merge_type_regular(data1, data2))
-}

R/api_source_terrascope.R

@@ -20,14 +20,16 @@
                                                                  platform = NULL) {
     # set caller to show in errors
     .check_set_caller(".source_items_new_terrascope_cube")
+    # force token generation
+    .source_terrascope_persist_token()
     # convert roi to bbox
     roi <- .stac_intersects_as_bbox(stac_query)
     # update stac query with the new spatial reference
     stac_query[["params"]][["intersects"]] <- NULL
     stac_query[["params"]][["bbox"]] <- roi[["bbox"]]
     # world cover product has all data available for a single date. So, fix the
     # temporal interval from the query
-    stac_query[["params"]][["datetime"]] <- "2022-06-01T00:00:00Z"
+    stac_query[["params"]][["datetime"]] <- "2021-01-01T00:00:00Z"
     # making the request
     items_info <- rstac::post_request(q = stac_query, ...)
     .check_stac_items(items_info)

R/sits_regularize.R

@@ -274,8 +274,6 @@ sits_regularize.sar_cube <- function(cube, ...,
     }
     # deal with ROI and tiles
     .check_roi_tiles(roi, tiles)
-    #
-    #
     if (.has(roi)) {
         roi <- .roi_as_sf(roi, default_crs = crs)
     }
@@ -313,63 +311,6 @@ sits_regularize.sar_cube <- function(cube, ...,
 }
 #' @rdname sits_regularize
 #' @export
-sits_regularize.combined_cube <- function(cube, ...,
-                                          period,
-                                          res,
-                                          output_dir,
-                                          grid_system = NULL,
-                                          roi = NULL,
-                                          crs = NULL,
-                                          tiles = NULL,
-                                          multicores = 2L,
-                                          progress = TRUE) {
-    # Preconditions
-    .check_raster_cube_files(cube)
-    .check_period(period)
-    .check_num_parameter(res, exclusive_min = 0.0)
-    output_dir <- .file_path_expand(output_dir)
-    .check_output_dir(output_dir)
-    .check_num_parameter(multicores, min = 1L, max = 2048L)
-    progress <- .message_progress(progress)
-    # check for ROI and tiles
-    .check_roi_tiles(roi, tiles)
-    if (.has(grid_system)) {
-        .check_grid_system(grid_system)
-    } else if (any("NoTilingSystem" %in% .cube_tiles(cube))) {
-        grid_system <- "MGRS"
-    }
-    # Get a global timeline
-    timeline <- .gc_get_valid_timeline(
-        cube = cube, period = period
-    )
-    # Grouping by unique values for each type of cube: sar, optical, etc..
-    cubes <- dplyr::group_by(
-        cube, .data[["source"]], .data[["collection"]], .data[["satellite"]]
-    ) |> dplyr::group_map(~ {
-        class(.x) <- .cube_s3class(.x)
-        .x
-    }, .keep = TRUE)
-    # Regularizing each cube
-    reg_cubes <- purrr::map(cubes, function(cube) {
-        sits_regularize(
-            cube = cube,
-            timeline = timeline,
-            period = period,
-            res = res,
-            roi = roi,
-            crs = crs,
-            tiles = tiles,
-            output_dir = output_dir,
-            grid_system = grid_system,
-            multicores = multicores,
-            progress = progress
-        )
-    })
-    # In case where more than two cubes need to be merged
-    purrr::reduce(reg_cubes, sits_merge)
-}
-#' @rdname sits_regularize
-#' @export
 sits_regularize.rainfall_cube <- function(cube, ...,
                                           period,
                                           res,

man/sits-package.Rd

@@ -10,7 +10,8 @@ test_that("Creating WORLD-COVER-2021 cubes from TERRASCOPE", {
                     lat_min = -33.85777,
                     lat_max = -32.56690
                 ),
-                progress = FALSE
+                progress = FALSE,
+                crs = "EPSG:4326"
             )
         },
         .default = NULL
@@ -41,9 +42,10 @@ test_that("Creating WORLD-CEREAL-2021 cubes from TERRASCOPE",{
         {
             sits_cube(
                 source = "TERRASCOPE",
-                collection = "WORLD-COVER-2021",
+                collection = "WORLD-CEREAL-2021",
                 roi = bbox_22LBL,
-                progress = FALSE
+                progress = FALSE,
+                crs = "EPSG:4326"
             )
         },
         .default = NULL
@@ -56,12 +58,16 @@ test_that("Creating WORLD-CEREAL-2021 cubes from TERRASCOPE",{
         cube = world_cereal_2021,
         roi = bbox_22LBL,
         multicores = 6,
-        output_dir = tempdir()
+        output_dir = tempdir(),
+        crs = "EPSG:4326"
     )
+
     roi_wc <- sits_bbox(world_cereal_2021_20LBL)[,1:4]
-    roi_20LBL <- .bbox(bbox_22LBL, as_crs = "EPSG:4326")[,1:4]
+    roi_20LBL <- .bbox(bbox_22LBL, as_crs = "EPSG:4326", default_crs = "EPSG:4326")[,1:4]
+
     expect_equal(roi_wc[["xmin"]], roi_20LBL[["xmin"]], tolerance = 0.001)
-    sumwc <- summary(world_cereal_2021_20LBL)
+    sumwc <- suppressWarnings(summary(world_cereal_2021_20LBL))
+
     expect_true(all(sumwc[["class"]] %in% c("Non_Cropland", "Cropland")))
     expect_true(all(sumwc[["value"]] %in% c("0", "100")))
 })