From abd0ed47f15375ae783b5429ec81265a99aec083 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 12 Nov 2024 11:43:14 -0300 Subject: [PATCH 1/3] new function for random temporary subdirectory --- R/api_plot_raster.R | 10 +++++----- R/api_utils.R | 17 +++++++++++++++++ R/sits_plot.R | 2 +- 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index 1d2f08c92..36bea5e32 100644 --- 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_utils.R b/R/api_utils.R index 52010fccb..f1a0117c2 100644 --- 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_plot.R b/R/sits_plot.R index 6b6454e3b..cba4034a5 100644 --- 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 From 85220dc946922e0784c81daf0211710bb98d35b6 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 12 Nov 2024 16:37:02 -0300 Subject: [PATCH 2/3] fix tests to match tmap4 --- R/api_check.R | 3 ++- R/api_tmap_v4.R | 20 +++++++++++++++----- R/sits_active_learning.R | 2 ++ R/zzz.R | 2 +- tests/testthat/test-active_learning.R | 6 +++--- tests/testthat/test-clustering.R | 1 - tests/testthat/test-color.R | 27 --------------------------- 7 files changed, 23 insertions(+), 38 deletions(-) diff --git a/R/api_check.R b/R/api_check.R index 1b335315d..e1cef2991 100644 --- 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_tmap_v4.R b/R/api_tmap_v4.R index e1f62c62c..cabe4d730 100644 --- 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/sits_active_learning.R b/R/sits_active_learning.R index 96ff886e3..844f06c58 100644 --- 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/zzz.R b/R/zzz.R index adfcc199f..757c32f2c 100644 --- 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 index cc6905b90..19eb1e9e2 100644 --- 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-clustering.R b/tests/testthat/test-clustering.R index 217c57d15..8b5e58e01 100644 --- 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 index 3cce3c676..0bdfca4aa 100644 --- 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, From ec7b5c4609d4381487ec21748af05e759fed4f63 Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Fri, 15 Nov 2024 23:40:35 -0300 Subject: [PATCH 3/3] replace probability fractions with NA in classification results --- R/api_classify.R | 7 +-- tests/testthat/test-classification.R | 74 ++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+), 5 deletions(-) diff --git a/R/api_classify.R b/R/api_classify.R index e9c238758..74fc88256 100755 --- 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/tests/testthat/test-classification.R b/tests/testthat/test-classification.R index 4256d9bbe..3657818f4 100644 --- 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[])) +})