support for training rfor and xgboost with DEM base cubes

Author: gilbertocamara

NAMESPACE

@@ -136,6 +136,8 @@ S3method(.samples_alloc_strata,class_cube)
 S3method(.samples_alloc_strata,class_vector_cube)
 S3method(.samples_bands,sits)
 S3method(.samples_bands,sits_base)
+S3method(.samples_select_bands,sits)
+S3method(.samples_select_bands,sits_base)
 S3method(.slice_dfr,numeric)
 S3method(.source_collection_access_test,"mpc_cube_sentinel-1-grd")
 S3method(.source_collection_access_test,cdse_cube)
@@ -213,6 +215,7 @@ S3method(.tile_as_sf,raster_cube)
 S3method(.tile_band_conf,default)
 S3method(.tile_band_conf,derived_cube)
 S3method(.tile_band_conf,eo_cube)
+S3method(.tile_bands,base_raster_cube)
 S3method(.tile_bands,default)
 S3method(.tile_bands,raster_cube)
 S3method(.tile_bbox,default)

R/api_check.R

@@ -1297,7 +1297,7 @@
         len_min = 1,
         len_max = 1
     )
-    output_dir <- .file_normalize(output_dir)
+    output_dir <- .file_path_expand(output_dir)
     .check_file(output_dir)
     return(invisible(output_dir))
 }

R/api_download.R

@@ -10,7 +10,7 @@
 .download_asset <- function(asset, res, sf_roi, n_tries, output_dir,
                             progress, ...) {
     # Get all paths and expand
-    file <- .file_normalize(.tile_path(asset))
+    file <- .file_path_expand(.tile_path(asset))
     # Create a list of user parameters as gdal format
     gdal_params <- .gdal_format_params(
         asset = asset,

R/api_file.R

@@ -31,7 +31,7 @@
 #' @noRd
 #' @param file     File name
 #' @returns        File base name with path expanded
-.file_normalize <- function(file) {
+.file_path_expand <- function(file) {
     path.expand(file)
 }
 #' @title Build a file path
@@ -52,7 +52,7 @@
     }
     if (.has(output_dir)) {
         output_dir <- gsub("[/]*$", "", output_dir)
-        output_dir <- .file_normalize(output_dir)
+        output_dir <- .file_path_expand(output_dir)
         if (!dir.exists(output_dir) && create_dir) {
             dir.create(output_dir, recursive = TRUE)
         }

R/api_file_info.R

@@ -90,7 +90,7 @@ NULL
     .check_set_caller(".fi_eo_from_files")
     # precondition
     .check_that(length(files) == length(bands))
-    files <- .file_normalize(files)
+    files <- .file_path_expand(files)
     r_obj <- .raster_open_rast(files)
     .fi_eo(
         fid = fid[[1]],
@@ -148,7 +148,7 @@ NULL
 #' @param start_date start date of the image
 #' @param end_date end date of the image
 .fi_derived_from_file <- function(file, band, start_date, end_date) {
-    file <- .file_normalize(file)
+    file <- .file_path_expand(file)
     r_obj <- .raster_open_rast(file)
     .fi_derived(
         band = band,

R/api_raster.R

@@ -765,8 +765,8 @@
                              missing_value) {
     # Create an empty image template
     gdalUtilities::gdal_translate(
-        src_dataset = .file_normalize(base_file),
-        dst_dataset = .file_normalize(out_file),
+        src_dataset = .file_path_expand(base_file),
+        dst_dataset = .file_path_expand(out_file),
         ot = .raster_gdal_datatype(data_type),
         of = "GTiff",
         b = rep(1, nlayers),
@@ -815,13 +815,13 @@
     # for each file merge blocks
     for (i in seq_along(out_files)) {
         # Expand paths for out_file
-        out_file <- .file_normalize(out_files[[i]])
+        out_file <- .file_path_expand(out_files[[i]])
         # Check if out_file does not exist
         .check_that(!file.exists(out_file))
         # Get file paths
         merge_files <- purrr::map_chr(block_files, `[[`, i)
         # Expand paths for block_files
-        merge_files <- .file_normalize(merge_files)
+        merge_files <- .file_path_expand(merge_files)
         # check if block_files length is at least one
         .check_file(
             x = merge_files,

R/api_raster_terra.R

@@ -95,7 +95,7 @@
 #' @export
 .raster_open_rast.terra <- function(file, ...) {
     r_obj <- suppressWarnings(
-        terra::rast(x = .file_normalize(file), ...)
+        terra::rast(x = .file_path_expand(file), ...)
     )
     .check_null_parameter(r_obj)
     # remove gain and offset applied by terra

R/api_samples.R

@@ -96,14 +96,16 @@
 #' @export
 .samples_bands.sits <- function(samples) {
     # Bands of the first sample governs whole samples data
-    setdiff(names(.samples_ts(samples)), "Index")
+    bands <- setdiff(names(.samples_ts(samples)), "Index")
+    return(bands)
 }
 #' @export
 .samples_bands.sits_base <- function(samples) {
     # Bands of the first sample governs whole samples data
     ts_bands <- .samples_bands.sits(samples)
     base_bands <- .samples_bands_base(samples)
     bands <- c(ts_bands, base_bands)
+    return(bands)
 }
 #' @title Get bands of base data for samples
 #' @noRd
@@ -128,8 +130,23 @@
 #' @param bands   Bands to be selected
 #' @return Time series samples with the selected bands
 .samples_select_bands <- function(samples, bands) {
+    UseMethod(".samples_select_bands", samples)
+}
+#' @export
+.samples_select_bands.sits <- function(samples, bands) {
     # Filter samples
-    .ts(samples) <- .ts_select_bands(ts = .ts(samples), bands = bands)
+    .ts(samples) <- .ts_select_bands(ts = .ts(samples),
+                                     bands = bands)
+    # Return samples
+    samples
+}
+#' @export
+.samples_select_bands.sits_base <- function(samples, bands) {
+    ts_bands <- .samples_bands.sits(samples)
+    ts_select_bands <- bands[bands %in% ts_bands]
+    # Filter time series samples
+    .ts(samples) <- .ts_select_bands(ts = .ts(samples),
+                                     bands = ts_select_bands)
     # Return samples
     samples
 }
@@ -192,7 +209,7 @@
     # Get all time series
     preds <- .samples_ts(samples)
     # Select attributes
-    preds <- preds[.samples_bands(samples)]
+    preds <- preds[.samples_bands.sits(samples)]
     # Compute stats
     q02 <- apply(preds, 2, stats::quantile, probs = 0.02, na.rm = TRUE)
     q98 <- apply(preds, 2, stats::quantile, probs = 0.98, na.rm = TRUE)

R/api_vector_info.R

@@ -45,7 +45,7 @@ NULL
 }
 
 .vi_segment_from_file <- function(file, base_tile, band, start_date, end_date) {
-    file <- .file_normalize(file)
+    file <- .file_path_expand(file)
     v_obj <- .vector_read_vec(file_path = file)
     bbox <- .vector_bbox(v_obj)
     .vi_derived(

R/sits_lighttae.R

@@ -117,6 +117,9 @@ sits_lighttae <- function(samples = NULL,
     .check_set_caller("sits_lighttae")
     # Function that trains a torch model based on samples
     train_fun <- function(samples) {
+        # does not support working with DEM or other base data
+        if (inherits(samples, "sits_base"))
+            stop(.conf("messages", "sits_train_base_data"), call. = FALSE)
         # Avoid add a global variable for 'self'
         self <- NULL
         # Verifies if 'torch' and 'luz' packages is installed

R/sits_machine_learning.R

@@ -165,6 +165,9 @@ sits_svm <- function(samples = NULL, formula = sits_formula_linear(),
     .check_set_caller("sits_svm")
     # Function that trains a support vector machine model
     train_fun <- function(samples) {
+        # does not support working with DEM or other base data
+        if (inherits(samples, "sits_base"))
+            stop(.conf("messages", "sits_train_base_data"), call. = FALSE)
         # Verifies if e1071 package is installed
         .check_require_packages("e1071")
         # Get labels (used later to ensure column order in result matrix)

R/sits_mlp.R

@@ -108,6 +108,9 @@ sits_mlp <- function(samples = NULL,
     .check_set_caller("sits_mlp")
     # Function that trains a torch model based on samples
     train_fun <- function(samples) {
+        # does not support working with DEM or other base data
+        if (inherits(samples, "sits_base"))
+            stop(.conf("messages", "sits_train_base_data"), call. = FALSE)
         # Avoid add a global variable for 'self'
         self <- NULL
         # Verifies if 'torch' and 'luz' packages is installed

R/sits_regularize.R

@@ -120,7 +120,7 @@ sits_regularize.raster_cube <- function(cube, ...,
     .check_raster_cube_files(cube)
     .check_period(period)
     .check_num_parameter(res, exclusive_min = 0)
-    output_dir <- .file_normalize(output_dir)
+    output_dir <- .file_path_expand(output_dir)
     .check_output_dir(output_dir)
     .check_num_parameter(multicores, min = 1, max = 2048)
     .check_progress(progress)
@@ -175,7 +175,7 @@ sits_regularize.sar_cube <- function(cube, ...,
     .check_raster_cube_files(cube)
     .check_period(period)
     .check_num_parameter(res, exclusive_min = 0)
-    output_dir <- .file_normalize(output_dir)
+    output_dir <- .file_path_expand(output_dir)
     .check_output_dir(output_dir)
     .check_num_parameter(multicores, min = 1, max = 2048)
     .check_progress(progress)
@@ -218,7 +218,7 @@ sits_regularize.dem_cube <- function(cube, ...,
     # Preconditions
     .check_raster_cube_files(cube)
     .check_num_parameter(res, exclusive_min = 0)
-    output_dir <- .file_normalize(output_dir)
+    output_dir <- .file_path_expand(output_dir)
     .check_output_dir(output_dir)
     .check_num_parameter(multicores, min = 1, max = 2048)
     .check_progress(progress)

R/sits_resnet.R

@@ -126,6 +126,9 @@ sits_resnet <- function(samples = NULL,
     .check_set_caller("sits_resnet")
     # Function that trains a torch model based on samples
     train_fun <- function(samples) {
+        # does not support working with DEM or other base data
+        if (inherits(samples, "sits_base"))
+            stop(.conf("messages", "sits_train_base_data"), call. = FALSE)
         # Avoid add a global variable for 'self'
         self <- NULL
         # Verifies if 'torch' and 'luz' packages is installed

R/sits_tae.R

@@ -107,6 +107,9 @@ sits_tae <- function(samples = NULL,
     .check_set_caller("sits_tae")
     # Function that trains a torch model based on samples
     train_fun <- function(samples) {
+        # does not support working with DEM or other base data
+        if (inherits(samples, "sits_base"))
+            stop(.conf("messages", "sits_train_base_data"), call. = FALSE)
         # Avoid add a global variable for 'self'
         self <- NULL
         # Verifies if 'torch' and 'luz' packages is installed

R/sits_tempcnn.R

@@ -114,6 +114,9 @@ sits_tempcnn <- function(samples = NULL,
     .check_set_caller("sits_tempcnn")
     # Function that trains a torch model based on samples
     train_fun <- function(samples) {
+        # does not support working with DEM or other base data
+        if (inherits(samples, "sits_base"))
+            stop(.conf("messages", "sits_train_base_data"), call. = FALSE)
         # Avoid add a global variable for 'self'
         self <- NULL
         # Verifies if 'torch' and 'luz' packages is installed

inst/extdata/config_messages.yml

@@ -430,6 +430,7 @@ sits_stratified_sampling_shp_save: "saved allocation in shapefile"
 sits_svm: "wrong input parameters - see example in documentation"
 sits_tae: "wrong input parameters - see example in documentation"
 sits_tempcnn: "wrong input parameters - see example in documentation"
+sits_train_base_data: "training samples with DEM or other base data is only supported by random forest and xgboost methods"
 sits_timeline_raster_cube: "cube is not regular, returning all timelines"
 sits_timeline_default: "input should be a set of training samples or a data cube"
 sits_to_csv: "invalid CSV file to be written to"