Add support to f1-score in sits_accuracy with classified cubes and fix NA columns in sits_sampling_design

R/api_accuracy.R

@@ -27,11 +27,8 @@
 #' @keywords internal
 #' @noRd
 #' @param cube         Data cube.
-#' @param error_matrix Matrix given in sample counts.
-#'                     Columns represent the reference data and
-#'                     rows the results of the classification
-#' @param area         Named vector of the total area of each class on
-#'                     the map
+#' @param pred         Integer vector with predicted values.
+#' @param ref          Integer vector with reference values.
 #'
 #' @references
 #' Olofsson, P., Foody G.M., Herold M., Stehman, S.V.,
@@ -43,16 +40,31 @@
 #' A list of lists: The error_matrix, the class_areas, the unbiased
 #' estimated areas, the standard error areas, confidence interval 95% areas,
 #' and the accuracy (user, producer, and overall).
-.accuracy_area_assess <- function(cube, error_matrix, area) {
+.accuracy_area_assess <- function(cube, pred, ref) {
     # set caller to show in errors
     .check_set_caller(".accuracy_area_assess")
     # check if cube has the right type
     .check_is_class_cube(cube)
+    labels_cube <- .cube_labels(cube)
+    # Create the error matrix
+    error_matrix <- table(
+        factor(pred,
+               levels = labels_cube,
+               labels = labels_cube
+        ),
+        factor(ref,
+               levels = labels_cube,
+               labels = labels_cube
+        )
+    )
+    # Get area for each class of the cube
+    area <- .cube_class_areas(cube)
+
     # In the case where some classes are not in the classified cube, but
     # are in the validation file
     diff_classes <- setdiff(rownames(error_matrix), names(area))
     if (length(diff_classes) > 0 &&
-            length(diff_classes) < length(rownames(error_matrix))) {
+        length(diff_classes) < length(rownames(error_matrix))) {
         warning(.conf("messages", ".accuracy_area_assess"),
                 call. = FALSE
         )
@@ -103,21 +115,34 @@
 
     # overall area-weighted accuracy
     over_acc <- sum(diag(prop))
-    return(
-        list(
-            error_matrix = error_matrix,
-            area_pixels = area,
-            error_ajusted_area = error_adjusted_area,
-            stderr_prop = stderr_prop,
-            stderr_area = stderr_area,
-            conf_interval = 1.96 * stderr_area,
-            accuracy = list(
-                user = user_acc,
-                producer = prod_acc,
-                overall = over_acc
-            )
+
+    acc_area <- list(
+        error_matrix = error_matrix,
+        area_pixels = area,
+        error_ajusted_area = error_adjusted_area,
+        stderr_prop = stderr_prop,
+        stderr_area = stderr_area,
+        conf_interval = 1.96 * stderr_area,
+        accuracy = list(
+            user = user_acc,
+            producer = prod_acc,
+            overall = over_acc
         )
     )
+    class(acc_area) <- c("sits_area_accuracy", class(acc_area))
+    return(acc_area)
+}
+
+.accuracy_pixel_assess <- function(cube, pred, ref) {
+    # Create factor vectors for caret
+    unique_ref <- unique(ref)
+    pred_fac <- factor(pred, levels = unique_ref)
+    ref_fac <- factor(ref, levels = unique_ref)
+
+    # Call caret package to the classification statistics
+    acc <- caret::confusionMatrix(pred_fac, ref_fac)
+    class(acc) <- c("sits_accuracy", class(acc))
+    return(acc)
 }
 #' @title    Get validation samples
 #' @name .accuracy_get_validation

R/api_samples.R

@@ -339,16 +339,17 @@
         sf::st_transform(samples_sf, crs = "EPSG:4326")
     }, progress = progress)
 
+    labels <- unique(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 <- samples_label[[alloc]]
+        samples_label <- unique(samples_label[[alloc]])
         # filter data
         samples |>
             dplyr::filter(.data[["label"]] == lab) |>
-            dplyr::slice_sample(n = samples_label)
+            dplyr::slice_sample(n = round(samples_label))
     })
     # transform to sf object
     samples <- sf::st_as_sf(samples)

R/sits_accuracy.R

@@ -38,6 +38,8 @@
 #' @param \dots            Specific parameters
 #' @param validation       Samples for validation (see below)
 #'                         Only required when data is a class cube.
+#' @param method           A character with 'olofsson' or 'pixel' to compute
+#'                         accuracy.
 #'
 #' @return
 #' A list of lists: The error_matrix, the class_areas, the unbiased
@@ -134,7 +136,9 @@ sits_accuracy.sits <- function(data, ...) {
 #' @title Area-weighted post-classification accuracy for data cubes
 #' @rdname sits_accuracy
 #' @export
-sits_accuracy.class_cube <- function(data, ..., validation) {
+sits_accuracy.class_cube <- function(data, ...,
+                                     validation,
+                                     method = "olofsson") {
     .check_set_caller("sits_accuracy_class_cube")
     # get the validation samples
     valid_samples <- .accuracy_get_validation(validation)
@@ -206,26 +210,14 @@ sits_accuracy.class_cube <- function(data, ..., validation) {
     pred_ref <- do.call(rbind, pred_ref_lst)
     # is this data valid?
     .check_null_parameter(pred_ref)
-    # Create the error matrix
-    error_matrix <- table(
-        factor(pred_ref[["predicted"]],
-               levels = labels_cube,
-               labels = labels_cube
-        ),
-        factor(pred_ref[["reference"]],
-               levels = labels_cube,
-               labels = labels_cube
-        )
-    )
-    # Get area for each class of the cube
-    class_areas <- .cube_class_areas(cube = data)
-    # Compute accuracy metrics
-    acc_area <- .accuracy_area_assess(
-        cube = data,
-        error_matrix = error_matrix,
-        area = class_areas
+    # Get predicted and reference values
+    pred <- pred_ref[["predicted"]]
+    ref <- pred_ref[["reference"]]
+    acc_area <- switch(
+        method,
+        "olofsson" = .accuracy_area_assess(data, pred, ref),
+        "pixel" = .accuracy_pixel_assess(data, pred, ref)
     )
-    class(acc_area) <- c("sits_area_accuracy", class(acc_area))
     return(acc_area)
 }
 #' @rdname sits_accuracy

R/sits_sample_functions.R

@@ -337,7 +337,7 @@ sits_sampling_design <- function(cube,
         warning(.conf("messages", "sits_sampling_design_alloc"),
                 call. = FALSE
         )
-        alloc_options <- alloc_options[alloc_options < equal]
+        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