review sits_merge implementation and remove gdalUtilities

DESCRIPTION

@@ -49,7 +49,6 @@ LazyData: true
 Imports:
     yaml,
     dplyr (>= 1.0.0),
-    gdalUtilities,
     grDevices,
     graphics,
     lubridate,

NAMESPACE

@@ -455,7 +455,6 @@ S3method(sits_labels,sits_model)
 S3method(sits_labels_summary,sits)
 S3method(sits_merge,default)
 S3method(sits_merge,raster_cube)
-S3method(sits_merge,sar_cube)
 S3method(sits_merge,sits)
 S3method(sits_mixture_model,default)
 S3method(sits_mixture_model,derived_cube)

R/api_check.R

@@ -1923,6 +1923,18 @@
     .check_that(all(bands %in% cube_bands))
     return(invisible(cube))
 }
+#' @title Check if all rows in a cube has the same bands
+#' @name .check_cube_row_same_bands
+#' @param cube          Data cube
+#' @return Called for side effects.
+#' @keywords internal
+#' @noRd
+.check_cube_row_same_bands <- function(cube) {
+    bands <- purrr::map(.compact(slider::slide(cube, .tile_bands)), length)
+    bands <- .dissolve(bands)
+
+    .check_that(length(unique(bands)) == 1)
+}
 #' @title Check if  cubes have the same bbox
 #' @name .check_cubes_same_bbox
 #' @keywords internal

R/api_cube.R

@@ -1596,3 +1596,11 @@ NULL
 .cube_has_base_info <- function(cube) {
     return(.has(cube[["base_info"]]))
 }
+
+.cube_sensor <- function(cube) {
+    .dissolve(slider::slide(cube, .tile_sensor))
+}
+
+.cube_satellite <- function(cube) {
+    .dissolve(slider::slide(cube, .tile_satellite))
+}

R/api_merge.R

@@ -1,111 +1,212 @@
-.merge_diff_timelines <- function(t1, t2) {
-    abs(as.Date(t1) - as.Date(t2))
+# ---- General utilities ----
+.merge_has_equal_bands <- function(data1, data2) {
+    # get cube bands
+    data1_bands <- .cube_bands(data1)
+    data2_bands <- .cube_bands(data2)
+    # verify if both cubes have the same bands
+    has_same_bands <- all(data1_bands %in% data2_bands)
+    # if has the same bands, do check for consistency
+    if (has_same_bands) {
+        # get bands intersects
+        bands_intersects <- setdiff(data1_bands, data2_bands)
+        # no extra bands are allowed when the same bands are defined
+        .check_that(length(bands_intersects) == 0)
+        # same sensor is required when bands with the same names are defined
+        .check_that(all(.cube_sensor(data1) %in% .cube_sensor(data2)))
+    }
+    # return
+    has_same_bands
+}
+
+.merge_get_common_tiles <- function(data1, data2) {
+    # Extract common tiles
+    d1_tiles <- .cube_tiles(data1)
+    d2_tiles <- .cube_tiles(data2)
+    # Extract overlaps
+    intersect(d1_tiles, d2_tiles)
 }
 
-.cube_merge <- function(data1, data2) {
-    data1 <- slider::slide2_dfr(data1, data2, function(x, y) {
-        .fi(x) <- dplyr::arrange(
-            dplyr::bind_rows(.fi(x), .fi(y)),
-            .data[["date"]],
-            .data[["band"]],
-            .data[["fid"]]
-        )
-        # remove duplicates
-        .fi(x) <- dplyr::distinct(
-            .fi(x),
-            .data[["band"]],
-            .data[["date"]],
-            .keep_all = TRUE
-        )
+# ---- Adjust timeline strategies strategies ----
+.merge_adjust_timeline_strategy_zipper <- function(t1, t2) {
+    # define vector to store overlapping dates
+    t_overlap <- c()
+    # define the size of the `for` - size of the reference time-series
+    ts_reference_len <- length(t1) - 1
+    # search the overlapping dates
+    for (idx in seq_len(ts_reference_len)) {
+        # reference interval (`t1`)
+        reference_interval <- t1[idx: (idx + 1)]
+        # verify which dates are in the reference interval
+        t2_in_interval <- t2 >= t1[idx] & t2 <= t1[idx + 1]
+        # get the interval dates
+        t2_interval_dates <- t2[t2_in_interval]
+        # if have interval, process them
+        if (.has(t2_interval_dates)) {
+            # if all t2 dates are in the interval, just save them
+            if (all(reference_interval %in% t2_interval_dates)) {
+                t_overlap <- c(t_overlap, t2_interval_dates)
+            } else {
+                # if not, save the reference interval and the min value of
+                # the t2 interval dates.
+                # this ensures there are not two dates in the same interval
+                t_overlap <- c(
+                    t_overlap, # dates storage
+                    reference_interval,  # current interval
+                    min(t2_interval_dates) # min t2 interval date
+                )
+            }
+        }
+    }
+    # sort and remove duplicated values
+    sort(unique(as.Date(t_overlap)))
+}
 
-        return(x)
+# ---- Merge strategies ----
+.merge_strategy_file <- function(data1, data2) {
+    # extract tiles
+    tiles <- .merge_get_common_tiles(data1, data2)
+    # merge cubes
+    .map_dfr(tiles, function(tile) {
+        # select data in the selected tile
+        data1_in_tile <- .select_raster_tiles(data1, tile)
+        data2_in_tile <- .select_raster_tiles(data2, tile)
+        # change file name to match reference timeline
+        slider::slide2_dfr(data1_in_tile, data2_in_tile, function(x, y) {
+            # arrange by `date`, `band` and `fid`
+            .fi(x) <- dplyr::arrange(
+                dplyr::bind_rows(.fi(x), .fi(y)),
+                .data[["date"]],
+                .data[["band"]],
+                .data[["fid"]]
+            )
+            # remove duplicates
+            .fi(x) <- dplyr::distinct(
+                .fi(x),
+                .data[["band"]],
+                .data[["date"]],
+                .keep_all = TRUE
+            )
+            # return
+            return(x)
+        })
     })
-    return(data1)
 }
 
-.merge_irregular_cube <- function(data1, data2) {
-    merged_cube <- dplyr::bind_rows(data1, data2)
-    class(merged_cube) <- c("combined_cube", class(data1))
-    return(merged_cube)
+.merge_strategy_bind <- function(data1, data2) {
+    # Merge
+    dplyr::bind_rows(data1, data2)
 }
 
-.merge_equal_cube <- function(data1, data2) {
-    if (inherits(data1, "hls_cube") && inherits(data2, "hls_cube") &&
-        (.cube_collection(data1) == "HLSS30" ||
-         .cube_collection(data2) == "HLSS30")) {
-        data1[["collection"]] <- "HLSS30"
+# ---- Merge operations - Densify cube ----
+.merge_cube_densify <- function(data1, data2) {
+    # get tile overlaps
+    common_tiles <- .merge_get_common_tiles(data1, data2)
+    # define the strategy (default - merge tiles)
+    merge_strategy <- NULL
+    # case 1: same tiles, merge file info
+    if (.has(common_tiles)) {
+        merge_strategy <- .merge_strategy_file
+    } else {
+    # case 2: different tiles, merge cube rows
+        merge_strategy <- .merge_strategy_bind
     }
-
-    data1 <- .cube_merge(data1, data2)
-    return(data1)
+    # merge
+    merged_cube <- merge_strategy(data1, data2)
+    # include `combined` in cubes merged with bind
+    if (!.has(common_tiles)) {
+        class(merged_cube) <- c("combined_cube", class(data1))
+    }
+    # return
+    merged_cube
 }
 
-.merge_distinct_cube <- function(data1, data2) {
-    # Get cubes timeline
-    d1_tl <- unique(as.Date(.cube_timeline(data1)[[1]]))
-    d2_tl <- unique(as.Date(.cube_timeline(data2)[[1]]))
-
-    # get intervals
-    d1_period <- as.integer(
-        lubridate::as.period(lubridate::int_diff(d1_tl)), "days"
-    )
-    d2_period <- as.integer(
-        lubridate::as.period(lubridate::int_diff(d2_tl)), "days"
-    )
-    # pre-condition - are periods regular?
-    .check_that(
-        length(unique(d1_period)) == 1 && length(unique(d2_period)) == 1
-    )
-    # pre-condition - Do cubes have the same periods?
-    .check_that(
-        unique(d1_period) == unique(d2_period)
-    )
-    # pre-condition - are the cubes start date less than period timeline?
-    .check_that(
-        abs(d1_period[[1]] - d2_period[[2]]) <= unique(d2_period)
-    )
-
-    # Change file name to match reference timeline
-    data2 <- slider::slide_dfr(data2, function(y) {
-        fi_list <- purrr::map(.tile_bands(y), function(band) {
-            fi_band <- .fi_filter_bands(.fi(y), bands = band)
-            fi_band[["date"]] <- d1_tl
-            return(fi_band)
+# ---- Merge operations - Temporal overlaps ----
+.merge_cube_compactify <- function(data1, data2) {
+    # extract tiles
+    tiles <- .merge_get_common_tiles(data1, data2)
+    if (!.has(tiles)) {
+        # 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_adjust_timeline_strategy_zipper(
+                t1 = reference_timeline,
+                t2 = row_timeline
+            )
+            # cut the timeline
+            .cube_filter_dates(row, t_overlap)
         })
-        tile_fi <- dplyr::bind_rows(fi_list)
-        tile_fi <- dplyr::arrange(
-            tile_fi,
-            .data[["date"]],
-            .data[["band"]],
-            .data[["fid"]]
-        )
-        y[["file_info"]] <- list(tile_fi)
-        y
-    })
-    # Merge the cubes
-    data1 <- .cube_merge(data1, data2)
-    # Return cubes merged
-    return(data1)
+        # 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))
+    } else {
+        # 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_adjust_timeline_strategy_zipper(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)
+        })
+    }
+    # return
+    merged_cube
 }
 
-.merge_single_timeline <- function(data1, data2) {
-    tiles <- .cube_tiles(data1)
-    # update the timeline of the cube with single time step (`data2`)
-    data2 <- .map_dfr(tiles, function(tile_name) {
-        tile_data1 <- .cube_filter_tiles(data1, tile_name)
-        tile_data2 <- .cube_filter_tiles(data2, tile_name)
+# ---- Merge operation: Special case - DEM Cube ----
+.merge_dem_cube <- function(data1, data2) {
+    # define cubes
+    dem_cube <- data1
+    other_cube <- data2
+    # check which cube is the DEM
+    if (inherits(data2, "dem_cube")) {
+        # move DEM cube (de)
+        dem_cube <- data2
+        other_cube <- data1
+    }
+    tiles <- .cube_tiles(other_cube)
+    # update the timeline of the cube with single time step
+    dem_cube <- .map_dfr(tiles, function(tile_name) {
+        tile_other <- .cube_filter_tiles(other_cube, tile_name)
+        tile_dem <- .cube_filter_tiles(dem_cube, tile_name)
         # Get data1 timeline.
-        d1_tl <- unique(as.Date(.cube_timeline(tile_data1)[[1]]))
+        d1_tl <- unique(as.Date(.cube_timeline(tile_other)[[1]]))
         # Create new `file_info` using dates from `data1` timeline.
-        fi_new <- purrr::map(.tile_timeline(tile_data1), function(date_row) {
-            fi <- .fi(tile_data2)
+        fi_new <- purrr::map(.tile_timeline(tile_other), function(date_row) {
+            fi <- .fi(tile_dem)
             fi[["date"]] <- as.Date(date_row)
             fi
         })
         # Assign the new `file_into` into `data2`
-        tile_data2[["file_info"]] <- list(dplyr::bind_rows(fi_new))
-        tile_data2
+        tile_dem[["file_info"]] <- list(dplyr::bind_rows(fi_new))
+        tile_dem
     })
-    # Merge cubes and return
-    .cube_merge(data1, data2)
+    # merge cubes and return
+    .merge_strategy_file(other_cube, dem_cube)
+}
+
+# ---- Merge operation: Special case - HLS Cube ----
+.merge_hls_cube <- function(data1, data2) {
+    if ((.cube_collection(data1) == "HLSS30" ||
+         .cube_collection(data2) == "HLSS30")) {
+        data1[["collection"]] <- "HLSS30"
+    }
+
+    # merge cubes and return
+    .merge_strategy_file(data1, data2)
 }

R/api_mosaic.R

@@ -225,7 +225,7 @@
             quiet = TRUE
         )
         # Delete temporary roi file
-        on.exit(.mosaic_del_roi(roi))
+        on.exit(.roi_delete(roi))
     }
     # Crop and reproject tile image
     out_file <- .gdal_crop_image(
@@ -252,7 +252,7 @@
 #' @noRd
 #' @param  roi          Region of interest
 #' @return              Called for side effects
-.mosaic_del_roi <- function(roi) {
+.roi_delete <- function(roi) {
     if (is.null(roi)) {
         return(roi)
     }