improve stratified sample

Author: gilbertocamara

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: sits
 Type: Package
-Version: 1.6.0
+Version: 2.0.0
 Title: Satellite Image Time Series Analysis for Earth Observation Data Cubes
 Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolfsimoes@gmail.com'),
              person('Gilberto', 'Camara', role = c('aut', 'cre', 'ths'), email = 'gilberto.camara.inpe@gmail.com'),
@@ -296,3 +296,4 @@ Collate:
     'sits_xlsx.R'
     'zzz.R'
 Config/roxygen2/version: 8.0.0
+RoxygenNote: 7.3.3

R/api_check.R

@@ -1895,6 +1895,19 @@
     .check_set_caller(".check_smoothness")
     .check_that(length(smoothness) == 1L || length(smoothness) == nlabels)
 }
+#' @title Check samples_per_class parameter
+#' @name .check_samples_per_class
+#' @param samples_per_class a vector with the number of values to
+#' allocate per class
+#' @param labels    labels of the cube
+#' @return Called for side effects.
+#' @keywords internal
+#' @noRd
+.check_samples_per_class <- function(samples_per_class, labels) {
+    .check_set_caller(".check_samples_per_class")
+    .check_that(length(samples_per_class) == 1L ||
+                    length(samples_per_class) == length(labels))
+}
 #' @title Check if data contains predicted and reference values
 #' @name .check_pred_ref_match
 #' @param reference  vector with reference labels

R/api_samples.R

@@ -314,8 +314,7 @@
 #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com}
 #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br}
 #' @param cube          Classified data cube (raster or vector)
-#' @param samples_class Matrix with sampling design to be allocated
-#' @param alloc         Allocation method chosen
+#' @param samples_per_class Number of samples allocated per class
 #' @param dots          Other params for the function
 #' @param multicores    Number of cores to work in parallel
 #' @param block         Optimized block to be read into memory (used only in
@@ -325,21 +324,21 @@
 #' @keywords internal
 #' @noRd
 .samples_alloc_strata <- function(cube,
-                                  samples_class,
-                                  alloc, ...) {
+                                  samples_per_class, ...) {
     UseMethod(".samples_alloc_strata", cube)
 }
 #' @export
 .samples_alloc_strata.class_cube <- function(cube,
-                                             samples_class,
-                                             alloc, ...,
+                                             samples_per_class, ...,
                                              block,
                                              progress = progress) {
     # estimate size
-    size <- samples_class[[alloc]]
+    size <- unname(samples_per_class)
     size <- ceiling(max(size) / nrow(cube))
     # get labels
-    labels <- samples_class[["label"]]
+    labels <- names(samples_per_class)
+    names(labels) <- c(1:length(labels))
+    covers <- names(labels)
     # Create assets as jobs
     cube_assets <- .cube_split_assets(cube)
     # Process each asset in parallel
@@ -400,7 +399,7 @@
         cell_xy <- .raster_open_vect(cell_xy, crs = .raster_crs(tile_raster))
         # Return as sf
         sf::st_as_sf(x = cbind(cell_xy, cells[, 2, drop = FALSE])) |>
-            dplyr::left_join(samples_class, by = c("cover" = "label_id")) |>
+            dplyr::mutate(label = labels[.data[["cover"]]]) |>
             dplyr::select("label", "geometry") |>
             sf::st_transform(crs = "EPSG:4326")
     })
@@ -409,10 +408,7 @@
     # Process labels
     samples <- .map_dfr(labels, function(lab) {
         # get metadata for the current label
-        samples_label <- samples_class |>
-            dplyr::filter(.data[["label"]] == lab)
-        # extract alloc strategy
-        samples_label <- unique(samples_label[[alloc]])
+        samples_label <- samples_per_class[[lab]]
         # filter data
         samples |>
             dplyr::filter(.data[["label"]] == lab) |>
@@ -423,8 +419,7 @@
 }
 #' @export
 .samples_alloc_strata.class_vector_cube <- function(cube,
-                                                    samples_class,
-                                                    alloc, ...,
+                                                    samples_per_class, ...,
                                                     multicores = 2,
                                                     progress = progress) {
     # Open segments and transform them to tibble
@@ -438,10 +433,7 @@
             # prepare class name
             class <- class[["class"]]
             # get metadata for the current label
-            samples_label <- samples_class |>
-                dplyr::filter(.data[["label"]] == class)
-            # extract alloc strategy
-            samples_label <- samples_label[[alloc]]
+            samples_label <- samples_per_class(cl)
             # extract samples
             samples_label <- sf::st_sample(cl, samples_label)
             # prepare extracted samples
@@ -497,14 +489,13 @@
     )
     # merge sampling design with samples metadata to ensure reference to the
     # correct class / values from the cube
-    samples_class <- dplyr::inner_join(
+    samples_per_class <- dplyr::inner_join(
         x = sampling_design,
         y = labels,
         by = "labels"
     ) |>
         dplyr::select("labels", "label_id", dplyr::all_of(alloc)) |>
         dplyr::rename("label" = "labels")
     # include overhead
-    samples_class[alloc] <- ceiling(unlist(samples_class[[alloc]]) * overhead)
-
+    samples_per_class <- ceiling(unlist(samples_per_class[[alloc]]) * overhead)
 }

R/sits_sample_functions.R

@@ -532,24 +532,26 @@ sits_sampling_design <- function(cube,
 #' with a number of samples per class and allocates a set of
 #' locations for each class.
 #'
-#' (b) When the parameter "n_alloc_class" is available, the method selects
-#'  a set of locations based on a classified cube based on the number of
-#'  samples per class in this parameter. The "n_alloc_class" parameter
+#' (b) When the parameter "sampling_design" is not provided, the method selects
+#'  a set of locations based on a classified cube based on the parameter
+#'  "samples_per_class". This parameter
 #'  should either be a named vector (names are the labels of the cube)
-#'  or a single value. In the latter case, this value is used to retrieve
+#'  or a single value. In the latter case, the same value is used to retrieve
 #'  the samples for all classes.
 #'
 #' @param  cube                 Classified cube
 #' @param  sampling_design      Result of sits_sampling_design
 #' @param  alloc                Allocation method chosen
+#' @param  samples_per_class    Number of samples per class
+#'                              (in case sampling_design is NULL)
 #' @param  overhead             Additional percentage to account
 #'                              for border points
 #' @param  multicores           Number of cores that will be used to
 #'                              sample the images in parallel.
 #' @param  memsize              Memory available for sampling.
 #' @param  shp_file             Name of shapefile to be saved (optional)
 #' @param progress              Show progress bar? Default is TRUE.
-#' @return samples              Point sf object with required samples
+#' @return samples              Point sf object with required samples and label
 #'
 #' @examples
 #' if (sits_run_examples()) {
@@ -571,24 +573,31 @@ sits_sampling_design <- function(cube,
 #'         probs_cube,
 #'         output_dir = tempdir()
 #'     )
+#'     # Option 1 - select samples based on sampling design
 #'     # estimated UA for classes
 #'     expected_ua <- c(
 #'         Cerrado = 0.95, Forest = 0.95,
 #'         Pasture = 0.95, Soy_Corn = 0.95
 #'     )
 #'     # design sampling
 #'     sampling_design <- sits_sampling_design(label_cube, expected_ua)
-#'     # select samples
+#'     # select samples using the sampling design
 #'     samples <- sits_stratified_sampling(
 #'         label_cube,
-#'         sampling_design, "alloc_prop"
+#'         sampling_design = sampling_design,
+#'         alloc = "alloc_prop"
+#'     )
+#'     # Option 2 - Select samples based on a fixed number of samples per class
+#'      samples <- sits_stratified_sampling(
+#'         label_cube,
+#'         samples_per_class = 100
 #'     )
 #' }
 #' @export
 sits_stratified_sampling <- function(cube,
                                      sampling_design = NULL,
                                      alloc = "alloc_prop",
-                                     n_alloc_class = 100,
+                                     samples_per_class = 100,
                                      overhead = 1.2,
                                      multicores = 2L,
                                      memsize = 2L,
@@ -605,12 +614,21 @@ sits_stratified_sampling <- function(cube,
     # get the labels
     labels <- .cube_labels(cube)
     n_labels <- length(labels)
-    # check number of labels
-    .check_smoothness(n_alloc_class, n_labels)
-    # Prepare smoothness parameter
-    if (length(n_alloc_class) == 1L) {
-        n_alloc_class <- rep(n_alloc_class, n_labels)
+    # check progress
+    progress <- .message_progress(progress)
+    # check samples_per_class parameter is either 1
+    # or is a named vector with the cube labels
+    .check_samples_per_class(samples_per_class, labels)
+    # Prepare samples_per_class parameter
+    if (length(samples_per_class) == 1L) {
+        samples_per_class <- rep(samples_per_class, n_labels)
+        names(samples_per_class) <- labels
+    } else{
+        .check_that(all(names(samples_per_class) %in% labels),
+                    msg = .conf("messages",
+                                "sits_stratified_sampling_wrong_labels"))
     }
+    # if a sampling_design parameter exists, use it
     if (.has(sampling_design)) {
         .check_that(nrow(sampling_design) <= n_labels)
         # check names of labels
@@ -619,15 +637,14 @@ sits_stratified_sampling <- function(cube,
         .check_that(alloc %in% colnames(sampling_design),
                     msg = .conf("messages", "sits_stratified_sampling_alloc")
         )
+
         # check samples by class
-        n_alloc_class <- unlist(sampling_design[, alloc])
+        samples_per_class <- .samples_by_design(sampling_design,
+                                                labels,
+                                                alloc,
+                                                overhead)
     }
-    .check_int_parameter(n_alloc_class,
-        is_named = TRUE,
-        msg = .conf("messages", "sits_stratified_sampling_samples")
-    )
-    # check progress
-    progress <- .message_progress(progress)
+
     # The following functions define optimal parameters for parallel processing
     # Get block size
     block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube)))
@@ -656,14 +673,11 @@ sits_stratified_sampling <- function(cube,
     if (.parallel_start(workers = multicores)) {
         on.exit(.parallel_stop(), add = TRUE)
     }
-    samples_class <- .samples_by_design(sampling_design,
-                                        labels,
-                                        alloc,
-                                        overhead)
+
     # call function to allocate sample per strata
     samples <- .samples_alloc_strata(
         cube = cube,
-        samples_class = samples_class,
+        samples_per_class = samples_per_class,
         alloc = alloc,
         block = block,
         progress = progress

inst/extdata/config_messages.yml

@@ -118,6 +118,7 @@
 .check_samples_embeddings_index: "missing colunm Index in embeddings data"
 .check_samples_embeddings_bands: "all embeddings should have the same dimensions (bands)"
 .check_samples_embeddings_range: "all embeddings should have finite values"
+.check_samples_per_class: "samples_per_class must be either one value or a named vector with a value for each label"
 .check_samples_tile_match_bands: "tile bands do not match samples bands"
 .check_samples_tile_match_timeline: "tile timeline does not match samples timeline"
 .check_samples_timeline: "samples contain timelines with different lengths"
@@ -555,6 +556,7 @@ sits_som_map_grid_size: "recommended values for grid_xdim and grid_ydim are "
 sits_stratified_sampling: "labels in sampling design do not match labels in cube"
 sits_stratified_sampling_alloc: "allocation method is not included in sampling design"
 sits_stratified_sampling_samples: "number of samples per allocation method should be integer"
+sits_stratified_sampling_wrong_labels: "label names requested do not match those of the data cube"
 sits_stratified_sampling_shp: "invalid shapefile name"
 sits_stratified_sampling_shp_save: "saved allocation in shapefile"
 sits_svm: "wrong input parameters - see example in documentation"