new error messages

Author: gilbertocamara

R/api_check.R

@@ -920,12 +920,9 @@
         )
     # check extension
     if (!is.null(extensions)) {
-        .check_chr_within(ext_file(x),
-                          within = extensions,
-                          case_sensitive = FALSE,
-                          local_msg = local_msg,
-                          msg = .conf("messages", ".check_file_extension")
-        )
+        extension <- ext_file(x)
+        .check_that(extension %in% extensions,
+                    local_msg = local_msg)
     }
     if (file_exists) {
         existing_files <- file.exists(x)
@@ -1166,7 +1163,7 @@
 #' @noRd
 .check_int_parameter <- function(x, min = -2^31 + 1, max = 2^31 - 1,
                                  len_min = 1, len_max = 2^31 - 1,
-                                 is_odd = FALSE,
+                                 is_odd = FALSE, is_named = FALSE,
                                  allow_null = FALSE, msg = NULL) {
     # check parameter name
     param <- deparse(substitute(x, environment()))
@@ -1181,6 +1178,7 @@
         len_min = len_min,
         len_max = len_max,
         is_integer = TRUE,
+        is_named = is_named,
         is_odd = is_odd,
         local_msg = local_msg,
         msg = msg
@@ -1785,30 +1783,6 @@
     .check_that(length(smoothness) == 1 || length(smoothness) == nlabels)
     return(invisible(smoothness))
 }
-#' @title Check that cube is regular
-#' @name .check_is_regular
-#' @keywords internal
-#' @noRd
-#' @param cube  datacube
-#' @return Called for side effects.
-.check_is_regular <- function(cube) {
-    .check_set_caller(".check_is_regular")
-    is_regular <- TRUE
-    if (!.cube_is_complete(cube)) {
-        is_regular <- FALSE
-    }
-    if (!.cube_has_unique_bbox(cube)) {
-        is_regular <- FALSE
-    }
-    if (!.cube_has_unique_tile_size(cube)) {
-        is_regular <- FALSE
-    }
-    if (length(.cube_timeline(cube)) > 1) {
-        is_regular <- FALSE
-    }
-    .check_that(is_regular)
-    return(invisible(cube))
-}
 #' @title Check if data contains predicted and reference values
 #' @name .check_pred_ref_match
 #' @param reference  vector with reference labels
@@ -1924,7 +1898,7 @@
     .check_set_caller(".check_cube_bands")
     # all bands are upper case
     bands <- toupper(bands)
-    cube_bands <- .cube_bands(cube = cube, add_cloud = add_cloud)
+    cube_bands <- toupper(.cube_bands(cube = cube, add_cloud = add_cloud))
     .check_that(all(bands %in% cube_bands))
     return(invisible(cube))
 }
@@ -2148,7 +2122,7 @@
 .check_endmembers_tbl <- function(em) {
     .check_set_caller(".check_endmembers_tbl")
     # Pre-condition
-    .check_that(any(is.na(em)))
+    .check_that(!any(is.na(em)))
     # Pre-condition
     .check_chr_contains(
         x = colnames(em),
@@ -2404,10 +2378,7 @@
 #' @noRd
 .check_filter_fn <- function(filter_fn){
     .check_set_caller(".check_filter_fn")
-    name <- deparse(substitute(filter_fn))
-
-    .check_that(grepl("whittaker", name) ||
-                grepl("sgolay"), name)
+    .check_that(is.function(filter_fn))
 }
 .check_dist_method <- function(dist_method){
     .check_set_caller(".check_dist_method")

R/api_cube.R

@@ -512,6 +512,29 @@ NULL
     is_complete <- .cube_is_complete(cube)
     return(is_complete)
 }
+#' @title Check that cube is regular
+#' @name .cube_is_regular
+#' @keywords internal
+#' @noRd
+#' @param cube  datacube
+#' @return Called for side effects.
+.cube_is_regular <- function(cube) {
+    .check_set_caller(".cube_is_regular")
+    is_regular <- TRUE
+    if (!.cube_is_complete(cube)) {
+        is_regular <- FALSE
+    }
+    if (!.cube_has_unique_bbox(cube)) {
+        is_regular <- FALSE
+    }
+    if (!.cube_has_unique_tile_size(cube)) {
+        is_regular <- FALSE
+    }
+    if (length(.cube_timeline(cube)) > 1) {
+        is_regular <- FALSE
+    }
+    return(is_regular)
+}
 #' @title Find out how many images are in cube during a period
 #' @noRd
 #' @param cube  A data cube.

R/api_download.R

@@ -123,8 +123,12 @@
         if (.file_is_local(file)) {
             file <- .file_path("file://", file, sep = "")
         }
-        httr::GET(
-            url = file, httr::write_disk(path = out_file, overwrite = TRUE)
+        # httr::GET(
+        #     url = file, httr::write_disk(path = out_file, overwrite = TRUE)
+        # )
+        download.file(
+            url = file, destfile = out_file,
+            quiet = FALSE
         )
         # Return file name
         out_file

R/api_shp.R

@@ -63,7 +63,7 @@
     # set caller to show in errors
     .check_set_caller(".shp_transform_to_sf")
     # precondition - does the shapefile exist?
-    .check_file(shp_file, extensions = ".shp")
+    .check_file(shp_file, extensions = "shp")
 
     # read the shapefile
     sf_shape <- sf::read_sf(shp_file)
@@ -78,7 +78,7 @@
     # postcondition - can the function deal with the geometry_type?
     .check_that(as.character(geom_type) %in%  .conf("sf_geom_types_supported"))
     # postcondition - is the shape attribute valid?
-    .check_shp_attribute(sf_shape)
+    .check_shp_attribute(sf_shape, shp_attr)
 
     return(sf_shape)
 }

R/api_source_local.R

@@ -370,7 +370,8 @@
         pattern = paste0("\\.(", paste0(file_ext, collapse = "|"), ")$")
     )
     # post-condition
-    .check_that(all(file.exists(gpkg_files)))
+    gpkg_files_path <- paste0(vector_dir,"/",gpkg_files)
+    .check_that(all(file.exists(gpkg_files_path)))
 
     # remove the extension
     gpkg_files_noext <- tools::file_path_sans_ext(gpkg_files)
@@ -385,10 +386,6 @@
     })
     # subset gkpg files
     gpkg_files_ok <- gpkg_files_lst[are_gpkg_files_ok]
-
-    # post condition
-    .check_that(all(file.exists(gpkg_files_ok)))
-
     # filter only valid files
     gpkg_files_filt <- gpkg_files[are_gpkg_files_ok]
     # bind rows

R/api_source_mpc.R

@@ -269,6 +269,8 @@
     if (!nzchar(access_key)) {
         access_key <- NULL
     }
+    # Clean old tokens cached in rstac
+    .mpc_clean_token_cache()
     items_info <- suppressWarnings(
         rstac::items_sign(
             items_info, sign_fn = rstac::sign_planetary_computer(
@@ -285,7 +287,7 @@
                                                         collection,
                                                         stac_query, ...,
                                                         tiles = NULL,
-                                                        orbit = "descending") {
+                                                          orbit = "descending") {
     `.source_items_new.mpc_cube_sentinel-1-grd`(
         source = source,
         collection = collection,
@@ -348,6 +350,8 @@
     if (!nzchar(access_key)) {
         access_key <- NULL
     }
+    # Clean old tokens cached in rstac
+    .mpc_clean_token_cache()
     items_info <- suppressWarnings(
         rstac::items_sign(
             items_info,
@@ -377,6 +381,8 @@
                                                        stac_query, ...,
                                                        tiles = NULL,
                                                        platform = NULL) {
+    .check_set_caller(".source_items_new_mpc_cube_landsat_c2_l2")
+    .check_that(is.null(tiles))
     if (.has(platform)) {
         platform <- .stac_format_platform(
             source = source,
@@ -399,6 +405,8 @@
     if (!nzchar(access_key)) {
         access_key <- NULL
     }
+    # Clean old tokens cached in rstac
+    .mpc_clean_token_cache()
     items <- suppressWarnings(
         rstac::items_sign(
             items,
@@ -506,3 +514,19 @@
     .check_that(.has_not(tiles))
     return(invisible(source))
 }
+#' @title Cleak MPC token cache
+#' @name .mpc_clean_token_cache
+#' @description
+#' Cleans the the token cache for MPC to reduce timeout effects
+#' @return Called for side effects.
+#' @keywords internal
+#' @noRd
+#' @export
+.mpc_clean_token_cache <- function() {
+    mpc_token <- get("ms_token", envir = asNamespace("rstac"), inherits = TRUE)
+    cached_tokens <- names(mpc_token)
+    lapply(cached_tokens, function(cached_token) {
+        assign(cached_token, NULL, envir = mpc_token)
+    })
+    return(invisible(NULL))
+}

R/sits_apply.R

@@ -126,7 +126,7 @@ sits_apply.raster_cube <- function(data, ...,
                                    progress = FALSE) {
     # Check cube
     .check_is_raster_cube(data)
-    .check_is_regular(data)
+    .check_that(.cube_is_regular(data))
     # Check window size
     .check_int_parameter(window_size, min = 3, is_odd = TRUE)
     # Check normalized index

R/sits_classify.R

@@ -216,7 +216,7 @@ sits_classify.raster_cube <- function(data,
     .check_set_caller("sits_classify_raster")
     # preconditions
     .check_is_raster_cube(data)
-    .check_is_regular(data)
+    .check_that(.cube_is_regular(data))
     .check_is_sits_model(ml_model)
     .check_int_parameter(memsize, min = 1, max = 16384)
     .check_int_parameter(multicores, min = 1, max = 2048)
@@ -249,7 +249,8 @@ sits_classify.raster_cube <- function(data,
             cube = data, start_date = start_date, end_date = end_date
         )
     }
-    .check_filter_fn(filter_fn)
+    if (.has(filter_fn))
+        .check_filter_fn(filter_fn)
     # Retrieve the samples from the model
     samples <- .ml_samples(ml_model)
     # Do the samples and tile match their timeline length?
@@ -405,7 +406,8 @@ sits_classify.segs_cube <- function(data,
             cube = data, start_date = start_date, end_date = end_date
         )
     }
-    .check_filter_fn(filter_fn)
+    if (.has(filter_fn))
+        .check_filter_fn(filter_fn)
     # Check memory and multicores
     # Get block size
     block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data)))

R/sits_cube_copy.R

@@ -62,7 +62,7 @@ sits_cube_copy <- function(cube,
     # Pre-conditions
     .check_is_raster_cube(cube)
     # Cupe copy does not work for SAR data
-    if ("sar_cube" %in% class(cube) && !.check_is_regular(cube)) {
+    if ("sar_cube" %in% class(cube) && !.cube_is_regular(cube)) {
         warning(.conf("messages"), "sits_cube_copy_sar_no_copy")
         return(cube)
     }

R/sits_filters.R

@@ -66,9 +66,6 @@ sits_filter <- function(data, filter = sits_whittaker()) {
 #' }
 #' @export
 sits_whittaker <- function(data = NULL, lambda = 0.5) {
-    .check_set_caller("sits_filter")
-    if (.has(data))
-        .check_that(inherits(data, "sits") || inherits(data, "raster_cube"))
     filter_fun <- function(data) {
         if (inherits(data, "matrix")) {
             return(smooth_whit_mtx(data, lambda = lambda, length = ncol(data)))
@@ -126,9 +123,6 @@ sits_whittaker <- function(data = NULL, lambda = 0.5) {
 #' }
 #' @export
 sits_sgolay <- function(data = NULL, order = 3, length = 5) {
-    .check_set_caller("sits_filter")
-    if (.has(data))
-        .check_that(inherits(data, "sits") || inherits(data, "raster_cube"))
     # compute filter coefficients once
     f_res <- .signal_sgolay_coef(p = order, n = length, ts = 1)
     # function to be applied

R/sits_get_data.R

@@ -116,7 +116,7 @@ sits_get_data <- function(cube,
     .check_set_caller("sits_get_data")
     # Pre-conditions
     .check_is_raster_cube(cube)
-    .check_is_regular(cube)
+    .check_that(.cube_is_regular(cube))
     .check_raster_cube_files(cube)
     .check_cube_bands(cube, bands = bands)
     .check_crs(crs)

R/sits_mixture_model.R

@@ -176,7 +176,7 @@ sits_mixture_model.raster_cube <- function(data, endmembers, ...,
     # is added as a band
     data <- .cube_filter_bands(cube = data, bands = bands)
     # Check if cube is regular
-    .check_is_regular(data)
+    .check_that(.cube_is_regular(data))
     # Pre-condition
     .check_endmembers_bands(
         em = em,

R/sits_reduce.R

@@ -141,7 +141,7 @@ sits_reduce.raster_cube <- function(data, ...,
 
     # Check cube
     .check_is_raster_cube(data)
-    .check_is_regular(data)
+    .check_that(.cube_is_regular(data))
     # Check memsize
     .check_num_parameter(memsize, min = 1, max = 16384)
     # Check multicores

R/sits_sample_functions.R

@@ -431,7 +431,7 @@ sits_stratified_sampling <- function(cube,
     # retrieve samples class
     samples_class <- unlist(sampling_design[,alloc])
     # check samples class
-    .check_int_parameter(samples_class,
+    .check_int_parameter(samples_class, is_named = TRUE,
             msg = .conf("messages", "sits_sampling_design_samples")
     )
     .check_int_parameter(multicores, min = 1, max = 2048)

R/sits_segmentation.R

@@ -92,7 +92,7 @@ sits_segment <- function(cube,
     .check_set_caller("sits_segment")
     # Preconditions
     .check_is_raster_cube(cube)
-    .check_is_regular(cube)
+    .check_that(.cube_is_regular(cube))
     .check_int_parameter(memsize, min = 1, max = 16384)
     .check_output_dir(output_dir)
     version <- .check_version(version)

R/sits_summary.R

@@ -161,7 +161,7 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) {
     cli::cli_li("Bands: {.field {sits_bands(object)}}")
     timeline <- unique(lubridate::as_date(unlist(.cube_timeline(object))))
     cli::cli_li("Timeline: {.field {timeline}}")
-    is_regular <- .check_is_regular(object)
+    is_regular <- .cube_is_complete(object)
     cli::cli_li("Regular cube: {.field {is_regular}}")
     # Display cube cloud coverage
     if ("CLOUD" %in% .cube_bands(object) &&

R/sits_view.R

@@ -246,7 +246,7 @@ sits_view.uncertainty_cube <- function(x, ...,
     cube <- .view_filter_tiles(x, tiles)
     # more than one tile? needs regular cube
     if (nrow(cube) > 1) {
-        .check_is_regular(cube)
+        .check_that(.cube_is_regular(data))
     }
     # check the view_max_mb parameter
     view_max_mb <- .view_set_max_mb(view_max_mb)