Handle classification metrics with raster inputs (fixes #60)

.github/workflows/test-coverage.yaml

@@ -13,6 +13,7 @@ jobs:
     runs-on: ubuntu-latest
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }}
 
     steps:
       - uses: actions/checkout@v2

DESCRIPTION

@@ -87,4 +87,4 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1

NEWS.md

@@ -1,5 +1,10 @@
 # waywiser (development version)
 
+* `ww_multi_scale()`, when called with raster arguments (either to `data` or to `truth`
+   and `estimate`) and a classification metric set, will now convert `truth` and 
+   `estimate`to factors before passing them to the metric set. Thanks to @nowosad
+   for the report in #60 (#61).
+
 # waywiser 0.5.1
 
 * `ww_multi_scale()` now warns if you provide `crs` as an argument to `sf::st_make_grid()` via `...`. Grids created by this function will always take their CRS from `data`.

R/multi_scale.R

@@ -50,7 +50,7 @@
 #' arguments; or `NULL` if `truth` and `estimate` are `SpatRaster` objects.
 #' @param truth,estimate If `data` is an `sf` object, the names (optionally
 #' unquoted) for the columns in `data` containing the true and predicted values,
-#' respectively. If `data` is a `SpatRaster` object, either layer names or
+#' respectively. If `data` is a `SpatRaster` object, either (quoted) layer names or
 #' indices which will select the true and predicted layers, respectively, via
 #' [terra::subset()] If `data` is `NULL`, `SpatRaster` objects with a single
 #' layer containing the true and predicted values, respectively.
@@ -326,9 +326,34 @@ raster_method_notes <- function(grid_list) {
 }
 
 raster_method_summary <- function(grid_list, .notes, metrics, na_rm) {
+  if (inherits(metrics, "class_prob_metric_set")) {
+    lvls <- unique(
+      unlist(
+        lapply(
+          grid_list$grids,
+          function(grid) {
+            c(
+              levels(factor(grid$.truth)),
+              levels(factor(grid$.estimate))
+            )
+          }
+        )
+      )
+    )
+
+    grid_list$grids <- lapply(
+      grid_list$grids,
+      function(grid) {
+        grid$.truth <- factor(grid$.truth, levels = lvls)
+        grid$.estimate <- factor(grid$.estimate, levels = lvls)
+        grid
+      }
+  )
+  }
+
   out <- mapply(
     function(grid, grid_arg, .notes) {
-      out <- metrics(grid, .truth, .estimate, na_rm = na_rm)
+      out <- metrics(grid, truth = .truth, estimate = .estimate, na_rm = na_rm)
       out[attr(out, "sf_column")] <- NULL
       out$.grid_args <- list(grid_list$grid_args[grid_arg, ])
       out$.grid <- list(grid)
@@ -404,7 +429,7 @@ ww_multi_scale.sf <- function(
         aggregation_function
       )
 
-      out <- metrics(matched_data, .truth, .estimate, na_rm = na_rm)
+      out <- metrics(matched_data, truth = .truth, estimate = .estimate, na_rm = na_rm)
       out["grid_cell_idx"] <- NULL
       out[attr(out, "sf_column")] <- NULL
       out$.grid_args <- list(grid_args)

tests/testthat/_snaps/misc.md

@@ -8,6 +8,7 @@
       Number of nonzero links: 85 
       Percentage nonzero weights: 1.176471 
       Average number of links: 1 
+      25 disjoint connected subgraphs
       Non-symmetric neighbours list
 
 ---
@@ -65,6 +66,7 @@
       Number of nonzero links: 85 
       Percentage nonzero weights: 1.176471 
       Average number of links: 1 
+      25 disjoint connected subgraphs
       Non-symmetric neighbours list
 
 ---
@@ -113,6 +115,7 @@
       Number of nonzero links: 85 
       Percentage nonzero weights: 1.176471 
       Average number of links: 1 
+      25 disjoint connected subgraphs
       Non-symmetric neighbours list
 
       Weights style: W 

tests/testthat/test-multi_scale.R

@@ -777,3 +777,41 @@ test_that("Passing arguments via `...` errors when using grids", {
     class = "rlib_error_dots_nonempty"
   )
 })
+
+test_that("ww_multi_scale with raster args can handle classification metrics (#60)", {
+  skip_if_not_installed("terra")
+  l1 <- terra::rast(matrix(sample(1:10, 100, TRUE), nrow = 10))
+  l2 <- l1
+
+  expect_equal(
+    ww_multi_scale(
+      truth = l1, 
+      estimate = l2,
+      metrics = list(yardstick::precision),
+      grid = list(sf::st_make_grid(l1))
+    )$.estimate,
+    1
+  )
+
+})
+
+test_that("ww_multi_scale with raster data can handle classification metrics (#60)", {
+  skip_if_not_installed("terra")
+  l1 <- terra::rast(matrix(sample(1:10, 100, TRUE), nrow = 10))
+  l2 <- l1
+
+  r <- c(l1, l2)
+  names(r) <- c("l1", "l2")
+
+  expect_equal(
+    ww_multi_scale(
+      r,
+      truth = "l1", 
+      estimate = "l2",
+      metrics = list(yardstick::precision),
+      grid = list(sf::st_make_grid(l1))
+    )$.estimate,
+    1
+  )
+
+})