Merge branch 'dev' of https://github.com/e-sensing/sits into dev

Author: M3nin0

NAMESPACE

@@ -58,6 +58,7 @@ S3method(.cube_is_local,raster_cube)
 S3method(.cube_is_token_expired,default)
 S3method(.cube_is_token_expired,mpc_cube)
 S3method(.cube_labels,default)
+S3method(.cube_labels,derived_cube)
 S3method(.cube_labels,raster_cube)
 S3method(.cube_labels,tbl_df)
 S3method(.cube_merge_tiles,default)
@@ -316,6 +317,7 @@ S3method(sits_apply,raster_cube)
 S3method(sits_apply,sits)
 S3method(sits_as_sf,raster_cube)
 S3method(sits_as_sf,sits)
+S3method(sits_bands,base_raster_cube)
 S3method(sits_bands,default)
 S3method(sits_bands,patterns)
 S3method(sits_bands,raster_cube)

R/api_apply.R

@@ -197,7 +197,7 @@
     result <-
         .apply(data, col = "time_series", fn = function(x, ...) {
             dplyr::mutate(x, dplyr::across(
-                dplyr::matches(sits_bands(data)),
+                dplyr::matches(.samples_bands(data)),
                 fn, ...
             ))
         }, ...)

R/api_band.R

@@ -15,7 +15,7 @@
 #' @return Updated sits object
 #' @export
 .band_rename.sits <- function(x, bands) {
-    data_bands <- sits_bands(x)
+    data_bands <- .samples_bands(x)
     # pre-condition
     .check_chr(
         bands,
@@ -42,7 +42,7 @@
 #' @return updated sits object
 #' @export
 .band_rename.raster_cube <- function(x, bands) {
-    data_bands <- sits_bands(x)
+    data_bands <- .cube_bands(x)
     # pre-condition
     .check_chr(
         bands,

R/api_check.R

@@ -1697,17 +1697,17 @@
     samples_validation <- .check_samples(samples_validation)
     # check if the labels matches with train data
     .check_that(
-        all(sits_labels(samples_validation) %in% labels) &&
-            all(labels %in% sits_labels(samples_validation))
+        all(.samples_labels(samples_validation) %in% labels) &&
+            all(labels %in% .samples_labels(samples_validation))
     )
     # check if the timeline matches with train data
     .check_that(
-        length(sits_timeline(samples_validation)) == length(timeline)
+        length(.samples_timeline(samples_validation)) == length(timeline)
     )
     # check if the bands matches with train data
     .check_that(
-        all(sits_bands(samples_validation) %in% bands) &&
-            all(bands %in% sits_bands(samples_validation))
+        all(.samples_bands(samples_validation) %in% bands) &&
+            all(bands %in% .samples_bands(samples_validation))
     )
     return(invisible(samples_validation))
 }
@@ -1763,8 +1763,8 @@
     cols <- .pred_cols # From predictors API
     .check_that(cols %in% colnames(pred))
     .check_that(nrow(pred) > 0)
-    n_bands <- length(sits_bands(samples))
-    n_times <- length(sits_timeline(samples))
+    n_bands <- length(.samples_bands(samples))
+    n_times <- length(.samples_timeline(samples))
     .check_that(ncol(pred) == 2 + n_bands * n_times)
     return(invisible(pred))
 }
@@ -1802,8 +1802,8 @@
 .check_samples_tile_match_timeline <- function(samples, tile) {
     .check_set_caller(".check_samples_tile_match_timeline")
     # do they have the same timelines?
-    samples_timeline_length <- length(sits_timeline(samples))
-    tiles_timeline_length <- length(sits_timeline(tile))
+    samples_timeline_length <- length(.samples_timeline(samples))
+    tiles_timeline_length <- length(.tile_timeline(tile))
     .check_that(samples_timeline_length == tiles_timeline_length)
     return(invisible(samples))
 }
@@ -1817,8 +1817,8 @@
 .check_samples_tile_match_bands <- function(samples, tile) {
     .check_set_caller(".check_samples_tile_match_bands")
     # do they have the same bands?
-    tile_bands <- sits_bands(tile)
-    bands <- sits_bands(samples)
+    tile_bands <- .tile_bands(tile)
+    bands <- .samples_bands(samples)
     .check_that(all(bands %in% tile_bands))
     return(invisible(samples))
 }
@@ -1855,7 +1855,7 @@
     })
     classes_num <- unique(unlist(classes_list))
     classes_num <- classes_num[!is.na(classes_num)]
-    labels_num <- names(sits_labels(cube))
+    labels_num <- names(.cube_labels(cube))
     # do the labels and raster numbers match?
     .check_that(all(classes_num %in% labels_num))
     return(invisible(cube))
@@ -1964,8 +1964,8 @@
 .check_cubes_same_labels <- function(cube1, cube2) {
     .check_set_caller(".check_cubes_same_labels")
     .check_that(
-        all(sits_labels(cube1) %in% sits_labels(cube2)) &&
-            all(sits_labels(cube2) %in% sits_labels(cube1))
+        all(.cube_labels(cube1) %in% .cube_labels(cube2)) &&
+            all(.cube_labels(cube2) %in% .cube_labels(cube1))
     )
     return(invisible(cube1))
 }
@@ -1978,7 +1978,7 @@
 #' @return Called for side effects.
 .check_cubes_same_timeline <- function(cube1, cube2) {
     .check_set_caller(".check_cubes_same_timeline")
-    .check_that(all(sits_timeline(cube1) == sits_timeline(cube2)))
+    .check_that(all(.cube_timeline(cube1)[[1]] == .cube_timeline(cube2)[[1]]))
     return(invisible(cube1))
 }
 #' @title Check if two cubes have the same organization

R/api_combine_predictions.R

@@ -35,7 +35,7 @@
     job_memsize <- .jobs_memsize(
         job_size = .block_size(block = block_size),
         npaths = length(probs_cubes) * nrow(base_cube) *
-            length(sits_labels(base_cube)),
+            length(.cube_labels(base_cube)),
         nbytes = 8,
         proc_bloat = .conf("processing_bloat_cpu")
     )
@@ -223,7 +223,7 @@
         # Combine by average
         values <- weighted_probs(values, weights)
         # get the number of labels
-        n_labels <- length(sits_labels(cubes[[1]]))
+        n_labels <- length(.cube_labels(cubes[[1]]))
         # Are the results consistent with the data input?
         .check_processed_values(values, input_pixels)
         .check_processed_labels(values, n_labels)
@@ -248,7 +248,7 @@
         # Combine by average
         values <- weighted_uncert_probs(values, uncert_values)
         # get the number of labels
-        n_labels <- length(sits_labels(cubes[[1]]))
+        n_labels <- length(.cube_labels(cubes[[1]]))
         # Are the results consistent with the data input?
         .check_processed_values(values, input_pixels)
         .check_processed_labels(values, n_labels)

R/api_cube.R

@@ -51,13 +51,13 @@ NULL
     } else {
         stop(.conf("messages", ".cube_find_class"))
     }
-    if (all(sits_bands(cube) %in% .conf("sits_probs_bands"))) {
+    if (all(.cube_bands(cube) %in% .conf("sits_probs_bands"))) {
         class(cube) <- c("probs_cube", "derived_cube", class(cube))
-    } else if (all(sits_bands(cube) == "class")) {
+    } else if (all(.cube_bands(cube) == "class")) {
         class(cube) <- c("class_cube", "derived_cube", class(cube))
-    } else if (all(sits_bands(cube) == "variance")) {
+    } else if (all(.cube_bands(cube) == "variance")) {
         class(cube) <- c("variance_cube", "derived_cube", class(cube))
-    } else if (all(sits_bands(cube) %in% .conf("sits_uncert_bands"))) {
+    } else if (all(.cube_bands(cube) %in% .conf("sits_uncert_bands"))) {
         class(cube) <- c("uncert_cube", "derived_cube", class(cube))
     } else {
         class(cube) <- c("eo_cube", class(cube))
@@ -219,6 +219,10 @@ NULL
     UseMethod(".cube_labels", cube)
 }
 #' @export
+.cube_labels.derived_cube <- function(cube, dissolve = FALSE) {
+    return(cube[["labels"]][[1]])
+}
+#' @export
 .cube_labels.raster_cube <- function(cube, dissolve = TRUE) {
     labels <- .compact(slider::slide(cube, .tile_labels))
     if (dissolve) {
@@ -1268,3 +1272,16 @@ NULL
     })
     return(unlist(cube_chunks, recursive = FALSE))
 }
+#' @title  Return base info
+#' @name .cube_has_base_info
+#' @keywords internal
+#' @noRd
+#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
+#'
+#' @param  cube       Raster cube
+#' @return            TRUE/FALSE
+#'
+#'
+.cube_has_base_info <- function(cube) {
+    return(.has(cube[["base_info"]]))
+}

R/api_data.R

@@ -54,8 +54,9 @@
     rast <- .raster_open_rast(.tile_path(cube))
     block <- .raster_file_blocksize(rast)
     # 1st case - split samples by tiles
-    if (.raster_nrows(rast) == block[["nrows"]] &&
-            .raster_ncols(rast) == block[["ncols"]]) {
+    if ((.raster_nrows(rast) == block[["nrows"]] &&
+        .raster_ncols(rast) == block[["ncols"]]) ||
+        inherits(cube, "dem_cube")) {
         # split samples by bands and tile
         ts_tbl <- .data_by_tile(
             cube = cube,
@@ -78,6 +79,18 @@
             progress = progress
         )
     }
+    if (.has(cube[["base_info"]])) {
+        cube_base <- cube[["base_info"]][[1]]
+        bands_base <- .cube_bands(cube_base)
+        base_tbl <- .data_get_ts(
+            cube = cube_base,
+            samples = samples,
+            bands = bands_base,
+            impute_fn = impute_fn,
+            multicores = multicores,
+            progress = progress
+        )
+    }
     return(ts_tbl)
 }
 
@@ -102,7 +115,7 @@
     }
     .check_cube_bands(cube, bands = bands)
     # get cubes timeline
-    tl <- sits_timeline(cube)
+    tl <- .cube_timeline(cube)[[1]]
     # create tile-band pairs for parallelization
     tiles_bands <- tidyr::expand_grid(
         tile = .cube_tiles(cube),
@@ -126,7 +139,7 @@
             # select tile and band
             tile_id <- tile_band[[1]]
             band <- tile_band[[2]]
-            tile <- sits_select(cube, bands = band, tiles = tile_id)
+            tile <- .select_raster_cube(cube, bands = band, tiles = tile_id)
             # create a hash to store temporary samples file
             hash_bundle <- digest::digest(list(tile, samples), algo = "md5")
             filename <- .file_path(
@@ -252,7 +265,7 @@
     hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) {
         tile_id <- tile_band[[1]]
         band <- tile_band[[2]]
-        tile <- sits_select(cube, bands = band, tiles = tile_id)
+        tile <- .select_raster_cube(cube, bands = band, tiles = tile_id)
         digest::digest(list(tile, samples), algo = "md5")
     })
     # recreate file names to delete them
@@ -308,7 +321,7 @@
 #'
 #' @return A sits tibble with the average of all points by each polygon.
 .data_avg_polygon <- function(data) {
-    bands <- sits_bands(data)
+    bands <- .samples_bands(data)
     columns_to_avg <- c(bands, "latitude", "longitude")
     data_avg <- data |>
         tidyr::unnest(cols = "time_series") |>
@@ -351,7 +364,7 @@
                           progress) {
     .check_set_caller(".data_by_tile")
     # Get cube timeline
-    tl <- sits_timeline(cube)
+    tl <- .cube_timeline(cube)[[1]]
     # Get tile-band combination
     tiles_bands <- .cube_split_tiles_bands(cube = cube, bands = bands)
     # Set output_dir
@@ -371,7 +384,7 @@
         tile_id <- tile_band[[1]]
         band <- tile_band[[2]]
 
-        tile <- sits_select(
+        tile <- .select_raster_cube(
             data = cube,
             bands = c(band, cld_band),
             tiles = tile_id
@@ -508,7 +521,9 @@
     hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) {
         tile_id <- tile_band[[1]]
         band <- tile_band[[2]]
-        tile <- sits_select(cube, bands = c(band, cld_band), tiles = tile_id)
+        tile <- .select_raster_cube(cube, bands = c(band, cld_band),
+                                    tiles = tile_id
+                                    )
         digest::digest(list(tile, samples), algo = "md5")
     })
     # recreate file names to delete them
@@ -550,7 +565,7 @@
                             multicores,
                             progress) {
     # Get cube timeline
-    tl <- sits_timeline(cube)
+    tl <- .cube_timeline(cube)[[1]]
     # transform sits tibble to sf
     samples_sf <- sits_as_sf(samples)
     # Get chunks samples
@@ -571,7 +586,7 @@
     on.exit(.parallel_stop(), add = TRUE)
     # Get the samples in parallel using tile-band combination
     samples_tiles_bands <- .parallel_map(chunks_samples, function(chunk) {
-        tile <- sits_select(
+        tile <- .select_raster_cube(
             data = cube,
             bands = c(bands, cld_band),
             tiles = chunk[["tile"]]
@@ -666,7 +681,7 @@
     # bind rows to get a melted tibble of samples
     ts_tbl <- dplyr::bind_rows(samples_tiles_bands)
     if (!.has_ts(ts_tbl)) {
-        warning(.conf("messages", ".get_data_by_chunks"),
+        warning(.conf("messages", ".data_by_chunks"),
             immediate. = TRUE, call. = FALSE
         )
         return(.tibble())
@@ -705,7 +720,7 @@
         dplyr::ungroup()
     # recreate hash values
     hash_bundle <- purrr::map_chr(chunks_samples, function(chunk) {
-        tile <- sits_select(
+        tile <- .select_raster_cube(
             data = cube,
             bands = c(bands, cld_band),
             tiles = chunk[["tile"]]
@@ -733,3 +748,62 @@
     }
     return(ts_tbl)
 }
+#' @title get time series from base tiles
+#' @name .data_base_tiles
+#' @keywords internal
+#' @noRd
+#' @param cube            Data cube from where data is to be retrieved.
+#' @param samples         Samples to be retrieved.
+#' @param ts_time         Time series from multitemporal bands
+#'
+#' @return                Time series information with base tile data
+#'
+.data_base_tiles <- function(cube, samples) {
+    # retrieve values from samples
+    #
+    # read each tile
+    samples <- slider::slide_dfr(cube, function(tile){
+        # get XY
+        xy_tb <- .proj_from_latlong(
+            longitude = samples[["longitude"]],
+            latitude  = samples[["latitude"]],
+            crs       = .cube_crs(tile)
+        )
+        # join lat-long with XY values in a single tibble
+        samples <- dplyr::bind_cols(samples, xy_tb)
+        # filter the points inside the data cube space-time extent
+        samples <- dplyr::filter(
+            samples,
+            .data[["X"]] > tile[["xmin"]],
+            .data[["X"]] < tile[["xmax"]],
+            .data[["Y"]] > tile[["ymin"]],
+            .data[["Y"]] < tile[["ymax"]]
+        )
+
+        # are there points to be retrieved from the cube?
+        if (nrow(samples) == 0) {
+            return(NULL)
+        }
+        # create a matrix to extract the values
+        xy <- matrix(
+            c(samples[["X"]], samples[["Y"]]),
+            nrow = nrow(samples),
+            ncol = 2
+        )
+        colnames(xy) <- c("X", "Y")
+
+        # get the values of the time series as matrix
+        base_bands <- .tile_base_bands(tile)
+        samples <- purrr::map_dbl(base_bands, function(band){
+            values_base_band <- .tile_base_extract(
+                tile = tile,
+                band = band,
+                xy = xy
+            )
+            samples[[band]] <- values_base_band
+            return(samples)
+        })
+        return(samples)
+    })
+}
+