fix errors in test and view function

e-sensing · Nov 20, 2024 · 649eae9 · 649eae9
1 parent c3786b3
commit 649eae9
Show file tree

Hide file tree

Showing 17 changed files with 80 additions and 89 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,19 @@
 # SITS Release History
 
+# What's new in SITS version 1.5.2 
+
+* Include exclusion_mask in 'sits_classify()' and 'sits_smooth()'
+* Support for classification with pixels without data (NA)
+* Use ROI when plotting data cubes
+* Refactor 'sits_cube_copy()' to improve timeout handling and efficiency
+* Enable merging of Sentinel-1, Sentinel-2 and DEM in Brazil Data Cube tiling system
+* Include filtering by tiles in regularization operation 
+* Include start_date and end_date for each collection in sits_list_collections()
+* Add support to SpatExtent object from terra as roi in sits_cube() 
+* Fix crs usage in sits_get_data() to support WKT
+* Implement Sakoe-Chiba approximation for DTW algorithm
+
+
 # What's new in SITS version 1.5.1
 
 * Support for ESA World Cover map

diff --git a/R/api_colors.R b/R/api_colors.R
@@ -9,7 +9,7 @@
 #' @noRd
 #' @return colors required to display the labels
 .colors_get <- function(labels,
-                        palette = "Spectral",
+                        palette = "Set3",
                         legend = NULL,
                         rev = TRUE) {
     .check_set_caller(".colors_get")

diff --git a/R/api_data.R b/R/api_data.R
@@ -888,8 +888,8 @@
         classes <- labels[class_numbers]
         # insert classes into samples
         samples[["label"]] <- unname(classes)
-        samples <- dplyr::select(samples, .data[["longitude"]],
-                                 .data[["latitude"]], .data[["label"]])
+        samples <- dplyr::select(samples, dplyr::all_of("longitude"),
+                    dplyr::all_of("latitude"), dplyr::all_of("label"))
         return(samples)
     })
     return(data)

diff --git a/R/api_som.R b/R/api_som.R
@@ -156,7 +156,7 @@
     colors <- .colors_get(
         labels = kohonen_obj[["neuron_label"]],
         legend = NULL,
-        palette = "Spectral",
+        palette = "Set3",
         rev = TRUE
     )
     labels <- kohonen_obj[["neuron_label"]]

diff --git a/R/api_view.R b/R/api_view.R
@@ -581,6 +581,8 @@
     if (.has_not(dates)) {
         dates <- timeline[[1]]
     }
+    # make sure dates are valid
+    dates <- lubridate::as_date(dates)
     return(dates)
 }
 #' @title  Select the tiles to be visualised
@@ -736,7 +738,7 @@
 #' @noRd
 #' @export
 .view_add_overlay_group.raster_cube <- function(tile, date, band) {
-    group <- paste(tile[["tile"]], as.Date(date))
+    group <- paste(tile[["tile"]], date)
 }
 #' @noRd
 #' @export

diff --git a/R/sits_plot.R b/R/sits_plot.R
@@ -1585,7 +1585,7 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") {
     colors <- .colors_get(
         labels = labels,
         legend = NULL,
-        palette = "Spectral",
+        palette = "Set3",
         rev = TRUE
     )
 
@@ -1667,7 +1667,7 @@ plot.som_evaluate_cluster <- function(x, y, ...,
     colors <- .colors_get(
         labels = labels,
         legend = NULL,
-        palette = "Spectral",
+        palette = "Set3",
         rev = TRUE
     )
 

diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R
@@ -325,20 +325,12 @@ sits_sampling_design <- function(cube,
     std_dev <- signif(sqrt(expected_ua * (1 - expected_ua)), 3)
     # calculate sample size
     sample_size <-  round((sum(prop * std_dev) / std_err) ^ 2)
-    # determine "Equal" allocation
+    # determine "equal" allocation
     n_classes <- length(class_areas)
     equal <- rep(round(sample_size / n_classes), n_classes)
     names(equal) <- names(class_areas)
     # find out the classes which are rare
     rare_classes <- prop[prop <= rare_class_prop]
-    #  Determine allocation possibilities
-    #  Exclude allocation options that exceed the equal
-    if (any(alloc_options < equal)) {
-        warning(.conf("messages", "sits_sampling_design_alloc"),
-                call. = FALSE
-        )
-        alloc_options <- alloc_options[alloc_options < unique(equal)]
-    }
     #  Given each allocation for rare classes (e.g, 100 samples)
     #  allocate the rest of the sample size proportionally
     #  to the other more frequent classes
@@ -483,7 +475,8 @@ sits_stratified_sampling <- function(cube,
         cube = cube,
         samples_class = samples_class,
         alloc = alloc,
-        multicores = multicores
+        multicores = multicores,
+        progress = progress
     )
     # save results
     if (.has(shp_file)) {

diff --git a/R/sits_view.R b/R/sits_view.R
@@ -194,8 +194,10 @@ sits_view.raster_cube <- function(x, ...,
     for (i in seq_len(nrow(cube))) {
         row <- cube[i, ]
         for (date in dates) {
+            # convert to proper date
+            date <- lubridate::as_date(date)
             # add group
-            group <- .view_add_overlay_group(row, as.Date(date), band)
+            group <- .view_add_overlay_group(row, date, band)
             overlay_groups <- append(overlay_groups, group)
             # view image raster
             leaf_map <- leaf_map |>

diff --git a/tests/testthat/test-apply.R b/tests/testthat/test-apply.R
@@ -29,14 +29,14 @@ test_that("Testing normalized index generation", {
                       pattern = "\\.tif$",
                       full.names = TRUE
     ))
-    expect_warning({gc_cube <- sits_regularize(
+    gc_cube <- sits_regularize(
             cube = s2_cube,
             output_dir = dir_images,
             res = 160,
             period = "P1M",
             multicores = 2,
             progress = FALSE
-    )})
+    )
 
     gc_cube_new <- sits_apply(gc_cube,
                               EVI = 2.5 * (B8A - B05) / (B8A + 2.4 * B05 + 1),

diff --git a/tests/testthat/test-color.R b/tests/testthat/test-color.R
@@ -78,7 +78,8 @@ test_that("legend", {
         expect_warning({
             .colors_get(labels,
                 legend = def_legend_2,
-                palette = "Spectral", rev = TRUE
+                palette = "Set3",
+                rev = TRUE
             )
         })
     })

diff --git a/tests/testthat/test-cube-bdc.R b/tests/testthat/test-cube-bdc.R
@@ -499,16 +499,6 @@ test_that("One-year, multi-core classification in parallel", {
                               output_dir = dir_images,
                               progress = FALSE
     )
-
-    l8_probs_orig <- sits_cube(
-        source = "BDC",
-        collection = "LANDSAT-OLI-16D",
-        labels = sits_labels(l8_probs),
-        bands = "probs",
-        data_dir = paste0(tempdir(), "/images/.sits")
-    )
-
-
     r_obj <- .raster_open_rast(.tile_path(l8_probs))
 
     expect_true(l8_probs[["xmin"]] >= l8_cube[["xmin"]])

diff --git a/tests/testthat/test-cube-deafrica.R b/tests/testthat/test-cube-deafrica.R
@@ -289,12 +289,12 @@ test_that("Creating Sentinel-1 RTC cubes from DEA using tiles", {
     expect_true(all("EPSG:32636" %in% cube_s1_reg$crs))
 
     bbox <- sits_bbox(cube_s1_reg, as_crs = "EPSG:4326")
-    roi_cube_s1 <- sits_mgrs_to_roi("36NWJ")
+    roi_cube_s1 <- sits_tiles_to_roi("36NWJ")
 
-    expect_equal(bbox[["xmin"]], roi_cube_s1[["lon_min"]], tolerance = 0.01)
-    expect_equal(bbox[["xmax"]], roi_cube_s1[["lon_max"]], tolerance = 0.01)
-    expect_equal(bbox[["ymin"]], roi_cube_s1[["lat_min"]], tolerance = 0.01)
-    expect_equal(bbox[["ymax"]], roi_cube_s1[["lat_max"]], tolerance = 0.01)
+    expect_equal(bbox[["xmin"]], roi_cube_s1[["xmin"]], tolerance = 0.01)
+    expect_equal(bbox[["xmax"]], roi_cube_s1[["xmax"]], tolerance = 0.01)
+    expect_equal(bbox[["ymin"]], roi_cube_s1[["ymin"]], tolerance = 0.01)
+    expect_equal(bbox[["ymax"]], roi_cube_s1[["ymax"]], tolerance = 0.01)
 
     expect_true(all(c("VV") %in% sits_bands(cube_s1_reg)))
 })

diff --git a/tests/testthat/test-cube-mpc.R b/tests/testthat/test-cube-mpc.R
@@ -119,12 +119,12 @@ test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", {
     expect_true(all("EPSG:32721" %in% cube_s1_reg$crs))
 
     bbox <- sits_bbox(cube_s1_reg, as_crs = "EPSG:4326")
-    roi_cube_s1 <- sits_mgrs_to_roi(c("21LUJ","21LVJ"))
+    roi_cube_s1 <- sits_tiles_to_roi(c("21LUJ","21LVJ"))
 
-    expect_equal(bbox[["xmin"]], roi_cube_s1[["lon_min"]], tolerance = 0.01)
-    expect_equal(bbox[["xmax"]], roi_cube_s1[["lon_max"]], tolerance = 0.01)
-    expect_equal(bbox[["ymin"]], roi_cube_s1[["lat_min"]], tolerance = 0.01)
-    expect_equal(bbox[["ymax"]], roi_cube_s1[["lat_max"]], tolerance = 0.01)
+    expect_equal(bbox[["xmin"]], roi_cube_s1[["xmin"]], tolerance = 0.01)
+    expect_equal(bbox[["xmax"]], roi_cube_s1[["xmax"]], tolerance = 0.01)
+    expect_equal(bbox[["ymin"]], roi_cube_s1[["ymin"]], tolerance = 0.01)
+    expect_equal(bbox[["ymax"]], roi_cube_s1[["ymax"]], tolerance = 0.01)
     expect_true(all(c("VV") %in% sits_bands(cube_s1_reg)))
 
 })

diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R
@@ -83,30 +83,6 @@ test_that("Plot Time Series and Images", {
     vdiffr::expect_doppelganger("NDVI_labels", p4)
 })
 
-test_that("Plot class cube from STAC", {
-    world_cover <- .try(
-        {
-            sits_cube(
-                source     = "TERRASCOPE",
-                collection = "WORLD-COVER-2021",
-                bands      = "CLASS",
-                roi        = c("lon_min" = -62.7,
-                               "lon_max" = -62.5,
-                               "lat_min" = -8.83 ,
-                               "lat_max" = -8.70
-                ),
-                progress   = FALSE
-            )
-        },
-        .default = NULL
-    )
-    testthat::skip_if(purrr::is_null(world_cover),
-                      message = "TERRASCOPE is not accessible"
-    )
-    p_world_cover <- plot(world_cover)
-    vdiffr::expect_doppelganger("World_Cover", p_world_cover)
-})
-
 test_that("Plot Accuracy", {
     set.seed(290356)
     # show accuracy for a set of samples

diff --git a/tests/testthat/test-samples.R b/tests/testthat/test-samples.R
@@ -31,24 +31,28 @@ test_that("Sampling design", {
     cube <- sits_cube(
         source = "BDC",
         collection = "MOD13Q1-6.1",
-        data_dir = data_dir
+        data_dir = data_dir,
+        progress = FALSE
     )
     # classify a data cube
     probs_cube <- sits_classify(
-        data = cube, ml_model = rfor_model, output_dir = tempdir()
+        data = cube, ml_model = rfor_model, output_dir = tempdir(),
+        progress = FALSE
     )
     # label the probability cube
     label_cube <- sits_label_classification(
         probs_cube,
-        output_dir = tempdir()
+        output_dir = tempdir(),
+        progress = FALSE
     )
     # estimated UA for classes
     expected_ua <- c(Cerrado = 0.75, Forest = 0.9,
                      Pasture = 0.8, Soy_Corn = 0.8)
-    sampling_design <- sits_sampling_design(label_cube, expected_ua)
+    sampling_design <- sits_sampling_design(label_cube, expected_ua,
+                            alloc_options = c(100))
 
     expect_true(all(c("prop", "expected_ua", "std_dev", "equal",
-                      "alloc_100", "alloc_75", "alloc_50", "alloc_prop")
+                      "alloc_100", "alloc_prop")
                     %in% colnames(sampling_design)))
 
     # select samples
@@ -58,7 +62,8 @@ test_that("Sampling design", {
                                         sampling_design = sampling_design,
                                         overhead = overhead,
                                         alloc = "alloc_prop",
-                                        shp_file = shp_file)
+                                        shp_file = shp_file,
+                                        progress = FALSE)
     expect_true(file.exists(shp_file))
 
     sd <- unlist(sampling_design[,5], use.names = FALSE)
@@ -108,7 +113,8 @@ test_that("Sampling design with class cube from STAC", {
                                         sampling_design = sampling_design,
                                         overhead = overhead,
                                         alloc = "alloc_prop",
-                                        shp_file = shp_file)
+                                        shp_file = shp_file,
+                                        progress = FALSE)
     expect_true(file.exists(shp_file))
 
     sd <- unlist(sampling_design[,5], use.names = FALSE)

diff --git a/tests/testthat/test-variance.R b/tests/testthat/test-variance.R
@@ -39,19 +39,6 @@ test_that("Variance cube", {
     max_lyr3 <- max(.raster_get_values(r_obj)[, 3], na.rm = TRUE)
     expect_true(max_lyr3 <= 4000)
 
-    p <- plot(var_cube, sample_size = 10000, labels = "Cerrado")
-
-    expect_true(p$tm_raster$style == "cont")
-
-    p <- plot(var_cube, sample_size = 10000, labels = "Cerrado", type = "hist")
-    expect_true(all(p$data_labels %in% c(
-        "Cerrado", "Forest",
-        "Pasture", "Soy_Corn"
-    )))
-    v <- p$data$variance
-    expect_true(max(v) <= 100)
-    expect_true(min(v) >= 0)
-
     # test Recovery
     Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE")
     expect_message({

diff --git a/tests/testthat/test_get_probs_class.R b/tests/testthat/test_get_probs_class.R
@@ -7,35 +7,55 @@ test_that("Getting data for probs and classified cube", {
     cube <- sits_cube(
         source = "BDC",
         collection = "MOD13Q1-6.1",
-        data_dir = data_dir
+        data_dir = data_dir,
+        progress = FALSE
     )
     # classify a data cube
     probs_cube <- sits_classify(
         data = cube,
         ml_model = rf_model,
         output_dir = tempdir(),
-        version = "probs_get"
+        version = "probs_get",
+        progress = FALSE
     )
-    samples_sinop <- paste0(system.file("extdata/samples/samples_sinop_csv",
+    samples_sinop <- paste0(system.file("extdata/samples/samples_sinop_crop.csv",
                                         package = "sits"))
     probs_values <- sits_get_probs(
         cube = probs_cube,
         samples = samples_sinop
     )
+    expect_true(all(c("longitude", "latitude", "X", "Y", "Cerrado",
+                      "Forest", "Pasture", "Soy_Corn") %in% colnames(probs_values)))
+    probs <- probs_values[1, c(5:8)]
+    expect_true(sum(probs) > 0.99)
+    probs2 <- probs_values[2, c(5:8)]
+    expect_true(sum(probs2) > 0.99)
+
     probs_neigh <- sits_get_probs(
         cube = probs_cube,
         samples = samples_sinop,
         window_size = 5L
     )
+    expect_true(all(c("longitude", "latitude", "X", "Y",
+                      "neighbors") %in% colnames(probs_neigh)))
+
+    probs_mat1 <- probs_neigh[1,]$neighbors[[1]]
+    expect_true(nrow(probs_mat1) == 25)
+    expect_true(sum(probs_mat1[1,]) > 0.99)
 
     class_cube <- sits_label_classification(
         cube = probs_cube,
         output_dir = tempdir(),
-        version = "class_get"
+        version = "class_get",
+        progress = FALSE
     )
     class_values <- sits_get_class(
         cube = class_cube,
         samples = samples_sinop
     )
+    expect_true(all(c("longitude", "latitude", "label")
+                      %in% colnames(class_values)))
+    expect_true(all(unique(class_values[["label"]]) %in%
+                        c("Forest", "Cerrado", "Pasture", "Soy_Corn")))
 
 })