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

e-sensing · Nov 18, 2024 · 8d99772 · 8d99772
2 parents 4f47c8e + ec7b5c4
commit 8d99772
Show file tree

Hide file tree

Showing 12 changed files with 122 additions and 49 deletions.
diff --git a/R/api_check.R b/R/api_check.R
@@ -2358,7 +2358,8 @@
     .check_require_packages("cols4all")
     # set caller to show in errors
     .check_set_caller(".check_palette")
-    c4a_palette <- cols4all::c4a_info(palette, no.match = "null")
+    c4a_palette <- suppressWarnings(cols4all::c4a_info(palette,
+                                                      no.match = "null"))
     .check_that(.has(c4a_palette))
     return(invisible(palette))
 }

diff --git a/R/api_classify.R b/R/api_classify.R
@@ -106,8 +106,6 @@
         # Should bbox of resulting tile be updated?
         update_bbox <- nrow(chunks) != nchunks
     }
-    # Compute fractions probability
-    probs_fractions <- 1 / length(.ml_labels(ml_model))
     # Process jobs in parallel
     block_files <- .jobs_map_parallel_chr(chunks, function(chunk) {
         # Job block
@@ -171,10 +169,9 @@
         scale <- .scale(band_conf)
         if (.has(scale) && scale != 1) {
             values <- values / scale
-            probs_fractions  <- probs_fractions / scale
         }
-        # Mask NA pixels with same probabilities for all classes
-        values[na_mask, ] <- probs_fractions
+        # Put NA back in the result
+        values[na_mask, ] <- NA
         # Log
         .debug_log(
             event = "start_block_data_save",

diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R
@@ -42,7 +42,7 @@
             .tile_filter_bands(bands = band) |>
             .tile_filter_dates(dates = date) |>
             .crop(roi = roi,
-                  output_dir = tempdir(),
+                  output_dir = .rand_sub_tempdir(),
                   progress = FALSE)
     }
 
@@ -131,7 +131,7 @@
             .tile_filter_bands(bands = band) |>
             .tile_filter_dates(dates = dates) |>
             .crop(roi = roi,
-                  output_dir = tempdir(),
+                  output_dir = .rand_sub_tempdir(),
                   progress = FALSE)
     }
     # select the files to be plotted
@@ -200,7 +200,7 @@
             .tile_filter_bands(bands = c(red, green, blue)) |>
             .tile_filter_dates(dates = date) |>
             .crop(roi = roi,
-                  output_dir = tempdir(),
+                  output_dir = .rand_sub_tempdir(),
                   progress = FALSE)
     }
 
@@ -330,7 +330,7 @@
     if (.has(roi)) {
         tile <- tile |>
             .crop(roi = roi,
-                  output_dir = tempdir(),
+                  output_dir = .rand_sub_tempdir(),
                   progress = FALSE)
     }
     # size of data to be read
@@ -412,7 +412,7 @@
     if (.has(roi)) {
         tile <- tile |>
             .crop(roi = roi,
-                  output_dir = tempdir(),
+                  output_dir = .rand_sub_tempdir(),
                   progress = FALSE)
     }
     # size of data to be read

diff --git a/R/api_tmap_v4.R b/R/api_tmap_v4.R
@@ -10,7 +10,9 @@
                                       tmap_params){
 
     # recover palette name used by cols4all
-    cols4all_name <- cols4all::c4a_info(palette)$fullname
+    cols4all_name <- suppressWarnings(
+        cols4all::c4a_info(palette)$fullname
+    )
     # reverse order of colors?
     if (rev)
         cols4all_name <- paste0("-", cols4all_name)
@@ -55,7 +57,9 @@
 .tmap_dem_map.tmap_v4 <- function(r, band,
                                   palette, rev,
                                   scale, tmap_params){
-    cols4all_name <- cols4all::c4a_info(palette)$fullname
+    cols4all_name <- suppressWarnings(
+        cols4all::c4a_info(palette)$fullname
+    )
     # reverse order of colors?
     if (rev)
         cols4all_name <- paste0("-", cols4all_name)
@@ -136,7 +140,9 @@
                                     tmap_params){
 
     # recover palette name used by cols4all
-    cols4all_name <- cols4all::c4a_info(palette)$fullname
+    cols4all_name <- suppressWarnings(
+        cols4all::c4a_info(palette)$fullname
+    )
     # reverse order of colors?
     if (rev)
         cols4all_name <- paste0("-", cols4all_name)
@@ -184,7 +190,9 @@
                                        labels, labels_plot,
                                        scale, tmap_params){
 
-    cols4all_name <- cols4all::c4a_info(palette)$fullname
+    cols4all_name <- suppressWarnings(
+        cols4all::c4a_info(palette)$fullname
+    )
     # reverse order of colors?
     if (rev)
         cols4all_name <- paste0("-", cols4all_name)
@@ -303,7 +311,9 @@
 .tmap_vector_uncert.tmap_v4 <- function(sf_seg, palette, rev,
                                         type, scale, tmap_params){
     # recover palette name used by cols4all
-    cols4all_name <- cols4all::c4a_info(palette)$fullname
+    cols4all_name <- suppressWarnings(
+        cols4all::c4a_info(palette)$fullname
+    )
     # reverse order of colors?
     if (rev)
         cols4all_name <- paste0("-", cols4all_name)

diff --git a/R/api_utils.R b/R/api_utils.R
@@ -349,3 +349,20 @@ NULL
 .map_dfc <- function(x, fn, ...) {
     purrr::list_cbind(lapply(x, fn, ...))
 }
+#' @title       Function that returns a random subdirectory of tempdir()
+#' @description Generates a random subdir
+#' @noRd
+#' @keywords internal
+#' @returns  Name of a valid subdir of tempdir()
+#'
+.rand_sub_tempdir <- function() {
+    new_dir <- FALSE
+    while (!new_dir) {
+        new_temp_dir <- paste0(tempdir(), "/", sample(1:10000, size = 1))
+        if (!dir.exists(new_temp_dir)) {
+            dir.create(new_temp_dir)
+            new_dir <- TRUE
+        }
+    }
+    return(new_temp_dir)
+}
diff --git a/R/sits_active_learning.R b/R/sits_active_learning.R
@@ -156,6 +156,8 @@ sits_uncertainty_sampling <- function(uncert_cube,
         result_tile[["label"]] <- "NoClass"
         return(result_tile)
     })
+    samples_tb <- dplyr::rename(samples_tb, uncertainty = value)
+
     return(samples_tb)
 }
 #' @title Suggest high confidence samples to increase the training set.

diff --git a/R/sits_plot.R b/R/sits_plot.R
@@ -676,7 +676,7 @@ plot.dem_cube <- function(x, ...,
         tile <- tile |>
             .tile_filter_bands(bands = band) |>
             .crop(roi = roi,
-                  output_dir = tempdir(),
+                  output_dir = .rand_sub_tempdir(),
                   progress = FALSE)
     }
     # select the file to be plotted

diff --git a/R/zzz.R b/R/zzz.R
@@ -23,7 +23,7 @@ sits_env[["model_formula"]] <- "log"
 utils::globalVariables(c(
     ".x", ".y", ":=", # dplyr
     "self", "ctx", "super", "private", # torch
-    "uniform", "choice", "randint", "geometry",
+    "uniform", "choice", "randint", "geometry", "value",
     "normal", "lognormal", "loguniform", # sits_tuning_random
     "sar:frequency_band", "sar:instrument_mode", "sat:orbit_state" # S1 stac
 ))

diff --git a/tests/testthat/test-active_learning.R b/tests/testthat/test-active_learning.R
@@ -9,7 +9,7 @@ test_that("Suggested samples have low confidence, high entropy", {
     )
     set.seed(123)
     rfor_model <- sits_train(samples_modis_ndvi,
-        ml_method = sits_xgboost(verbose = FALSE)
+        ml_method = sits_rfor()
     )
     output_dir <- paste0(tempdir(), "/al")
     if (!dir.exists(output_dir)) {
@@ -41,9 +41,9 @@ test_that("Suggested samples have low confidence, high entropy", {
 
     expect_true(nrow(samples_df) <= 100)
     expect_true(all(colnames(samples_df) %in% c(
-        "longitude", "latitude",
+        "longitude", "latitude", "uncertainty",
         "start_date", "end_date",
-        "label", "uncertainty"
+        "label"
     )))
     expect_true(all(samples_df[["label"]] == "NoClass"))
     expect_true(all(samples_df[["uncertainty"]] >= 0.3))

diff --git a/tests/testthat/test-classification.R b/tests/testthat/test-classification.R
@@ -56,3 +56,77 @@ test_that("Classify error bands 1", {
         )
     )
 })
+
+test_that("Classify with NA values", {
+    # load cube
+    data_dir <- system.file("extdata/raster/mod13q1", package = "sits")
+    raster_cube <- sits_cube(
+        source = "BDC",
+        collection = "MOD13Q1-6.1",
+        data_dir = data_dir,
+        tiles = "012010",
+        bands = "NDVI",
+        start_date = "2013-09-14",
+        end_date = "2014-08-29",
+        multicores = 2,
+        progress = FALSE
+    )
+    # preparation - create directory to save NA
+    data_dir <- paste0(tempdir(), "/na-cube")
+    dir.create(data_dir, recursive = TRUE, showWarnings = FALSE)
+    # preparation - insert NA in cube
+    raster_cube <- sits_apply(
+        data = raster_cube,
+        NDVI_NA = ifelse(NDVI > 0.5, NA, NDVI),
+        output_dir = data_dir
+    )
+    raster_cube <- sits_select(raster_cube, bands = "NDVI_NA")
+    .fi(raster_cube) <- .fi(raster_cube) |>
+                            dplyr::mutate(band = "NDVI")
+    # preparation - create a random forest model
+    rfor_model <- sits_train(samples_modis_ndvi, sits_rfor(num_trees = 40))
+    # test classification with NA
+    class_map <- sits_classify(
+        data = raster_cube,
+        ml_model = rfor_model,
+        output_dir = tempdir(),
+        progress = FALSE
+    )
+    class_map_rst <- terra::rast(class_map[["file_info"]][[1]][["path"]])
+    expect_true(anyNA(class_map_rst[]))
+})
+
+test_that("Classify with exclusion mask", {
+    # load cube
+    data_dir <- system.file("extdata/raster/mod13q1", package = "sits")
+    raster_cube <- sits_cube(
+        source = "BDC",
+        collection = "MOD13Q1-6.1",
+        data_dir = data_dir,
+        tiles = "012010",
+        bands = "NDVI",
+        start_date = "2013-09-14",
+        end_date = "2014-08-29",
+        multicores = 2,
+        progress = FALSE
+    )
+    # preparation - create a random forest model
+    rfor_model <- sits_train(samples_modis_ndvi, sits_rfor(num_trees = 40))
+    # test classification with NA
+    class_map <- suppressWarnings(
+        sits_classify(
+            data = raster_cube,
+            ml_model = rfor_model,
+            output_dir = tempdir(),
+            exclusion_mask = c(
+                xmin = -55.63478,
+                ymin = -11.63328,
+                xmax = -55.54080,
+                ymax = -11.56978
+            ),
+            progress = FALSE
+        )
+    )
+    class_map_rst <- terra::rast(class_map[["file_info"]][[1]][["path"]])
+    expect_true(anyNA(class_map_rst[]))
+})
diff --git a/tests/testthat/test-clustering.R b/tests/testthat/test-clustering.R
@@ -16,7 +16,6 @@ test_that("Creating a dendrogram and clustering the results", {
             )
     })
     # test message
-    expect_true(grepl("desired", messages[3]))
     dendro <- .cluster_dendrogram(cerrado_2classes,
         bands = c("NDVI", "EVI")
     )

diff --git a/tests/testthat/test-color.R b/tests/testthat/test-color.R
@@ -43,33 +43,6 @@ test_that("color errors", {
     expect_equal(colors[16,1]$name, "Water_Bodies")
 })
 
-test_that("plot colors", {
-    data_dir <- system.file("extdata/raster/classif", package = "sits")
-    ro_class <- sits_cube(
-        source = "MPC",
-        collection = "SENTINEL-2-L2A",
-        data_dir = data_dir,
-        parse_info = c(
-            "X1", "X2", "tile", "start_date", "end_date",
-            "band", "version"
-        ),
-        bands = "class",
-        labels = c(
-            "1" = "Clear_Cut_Burned_Area", "2" = "Clear_Cut_Bare_Soil",
-            "3" = "Clear_Cut_Vegetation", "4" = "Forest"
-        ),
-        progress = FALSE
-    )
-    p <- plot(ro_class)
-    expect_equal(p$tm_shape$line.center, "midpoint")
-    expect_equal(p$tm_layout$legend.bg.color, "white")
-    expect_equal(
-        unname(p$tm_raster$labels),
-        c("Clear_Cut_Burned_Area", "Clear_Cut_Bare_Soil",
-          "Clear_Cut_Vegetation", "Forest")
-    )
-})
-
 test_that("colors_get", {
     labels <- c("Forest", "Cropland", "Pasture")
     colors <- suppressWarnings(sits:::.colors_get(labels,