tests/testthat/test-multi_scale.R

In waywiser: Ergonomic Methods for Assessing Spatial Models

test_that("ww_multi_scale", {
  skip_if_not_installed("modeldata")
  data(ames, package = "modeldata")
  ames_sf <- sf::st_as_sf(ames, coords = c("Longitude", "Latitude"), crs = 4326)
  ames_model <- lm(Sale_Price ~ Lot_Area, data = ames_sf)
  ames_sf$predictions <- predict(ames_model, ames_sf)

  made_w_grid_args <- ww_multi_scale(
    ames_sf,
    Sale_Price,
    predictions,
    n = list(
      c(20, 20),
      c(10, 10),
      c(1, 1)
    ),
    square = FALSE
  )

  embiggened_bbox <- expand_grid(sf::st_bbox(ames_sf))

  grids <- list(
    sf::st_make_grid(embiggened_bbox, n = c(20, 20), square = FALSE),
    sf::st_make_grid(embiggened_bbox, n = c(10, 10), square = FALSE),
    sf::st_make_grid(embiggened_bbox, n = c(1, 1), square = FALSE)
  )
  made_w_grids <- ww_multi_scale(
    ames_sf,
    Sale_Price,
    predictions,
    grids = grids
  )

  expect_identical(
    made_w_grid_args[1:3],
    made_w_grids[1:3]
  )
  expect_snapshot(made_w_grid_args)

  expect_snapshot(
    ww_multi_scale(
      ames_sf,
      Sale_Price,
      predictions,
      grids = grids[1],
      metrics = yardstick::rmse
    )
  )

  expect_snapshot(
    ww_multi_scale(
      ames_sf,
      Sale_Price,
      predictions,
      n = list(c(1, 1)),
      autoexpand_grid = FALSE
    )
  )

  expect_equal(
    ww_multi_scale(
      ames_sf,
      Sale_Price,
      predictions,
      n = list(c(1, 1)),
      metrics = list(yardstick::mae)
    )$.estimate,
    yardstick::mae_vec(mean(ames_sf$Sale_Price), mean(ames_sf$predictions))
  )

  expect_equal(
    ww_multi_scale(
      ames_sf,
      Sale_Price,
      predictions,
      n = list(c(1, 1)),
      metrics = list(yardstick::mae),
      aggregation_function = median
    )$.estimate,
    yardstick::mae_vec(median(ames_sf$Sale_Price), median(ames_sf$predictions))
  )

  expect_snapshot(
    ww_multi_scale(
      dplyr::group_by(ames_sf, Neighborhood),
      Sale_Price,
      predictions,
      n = list(
        c(10, 10),
        c(1, 1)
      ),
      square = FALSE
    )
  )
})

test_that("expected errors", {
  guerry_modeled <- guerry
  guerry_lm <- lm(Crm_prs ~ Litercy, guerry_modeled)
  guerry_modeled$predictions <- predict(guerry_lm, guerry_modeled)

  expect_snapshot(
    ww_multi_scale(
      guerry_modeled,
      Crm_prs,
      predictions,
      n = list(c(1, 1)),
      metrics = yardstick::rmse
    ),
    error = TRUE
  )

  expect_snapshot(
    ww_multi_scale(
      suppressWarnings(sf::st_centroid(guerry_modeled)),
      Crm_prs,
      predictions,
      n = list(c(1, 1)),
      na_rm = c(TRUE, FALSE),
      metrics = yardstick::rmse
    ),
    error = TRUE
  )

  expect_snapshot(
    ww_multi_scale(
      iris,
      Sepal.Length,
      Sepal.Width,
      n = list(c(1, 1)),
      metrics = yardstick::rmse
    ),
    error = TRUE
  )
})

test_that("srr: expected failures for ww_multi_scale", {
  worldclim_predicted <- worldclim_simulation
  worldclim_predicted$predicted <- predict(
    lm(response ~ bio2 * bio10 * bio13 * bio19, data = worldclim_simulation),
    worldclim_simulation
  )

  worldclim_predicted$predicted <- as.character(worldclim_predicted$predicted)
  #' @srrstats {G5.2} Testing errors
  #' @srrstats {G5.2b} Testing errors
  #' @srrstats {G5.8b} Data of unsupported types
  #' @srrstats {G2.1} Truth and estimate are numeric:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, predicted, response, n = c(2, 4)),
    error = TRUE
  )

  #' @srrstats {G5.2} Testing errors
  #' @srrstats {G5.2b} Testing errors
  #' @srrstats {G5.8b} Data of unsupported types
  #' @srrstats {G2.1} Truth and estimate are numeric:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, response, predicted, n = c(2, 4)),
    error = TRUE
  )

  worldclim_predicted$predicted <- lapply(
    as.numeric(worldclim_predicted$predicted),
    function(x) (x)
  )
  #' @srrstats {G5.2} Testing errors
  #' @srrstats {G5.2b} Testing errors
  #' @srrstats {G5.8b} Data of unsupported types
  #' @srrstats {G2.12} List column inputs fail:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, predicted, response, n = c(2, 4)),
    error = TRUE
  )

  #' @srrstats {G5.2} Testing errors
  #' @srrstats {G5.2b} Testing errors
  #' @srrstats {G5.8b} Data of unsupported types
  #' @srrstats {G2.12} List column inputs fail:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, response, predicted, n = c(2, 4)),
    error = TRUE
  )

  worldclim_predicted$predicted <- unlist(worldclim_predicted$predicted)
  #' @srrstats {G2.13} Missing data is properly handled
  #' @srrstats {G2.15} Missingness is checked
  #' @srrstats {G2.14} Users can specify behavior with NA results
  #' @srrstats {G2.16} NaN is properly handled
  #' Default removes NA:
  worldclim_predicted$response[4] <- NA_real_
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, predicted, response, n = 2)
  )

  # Default removes NA:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, response, predicted, n = 2),
  )

  # Or return NA:
  expect_snapshot(
    ww_multi_scale(
      worldclim_predicted,
      predicted,
      response,
      n = 2,
      na_rm = FALSE
    )
  )

  # Or return NA:
  expect_snapshot(
    ww_multi_scale(
      worldclim_predicted,
      response,
      predicted,
      n = 2,
      na_rm = FALSE
    ),
  )

  #' @srrstats {G5.8} Edge condition tests
  #' @srrstats {G5.8a} Zero-length data:
  expect_snapshot(
    ww_multi_scale(
      head(worldclim_predicted, 0),
      response,
      predicted,
      n = c(2, 4)
    ),
    error = TRUE
  )

  #' @srrstats {G5.8} Edge condition tests
  #' @srrstats {G5.8a} Zero-length data:
  expect_snapshot(
    ww_multi_scale(
      head(worldclim_predicted, 0),
      predicted,
      response,
      n = c(2, 4)
    ),
    error = TRUE
  )

  worldclim_predicted$response <- NA_real_
  #' @srrstats {G5.8} Edge condition tests
  #' @srrstats {G5.8c} All-NA:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, response, predicted, n = c(2, 4)),
  )

  #' @srrstats {G5.8} Edge condition tests
  #' @srrstats {G5.8c} All-NA:
  expect_snapshot(
    ww_multi_scale(worldclim_predicted, predicted, response, n = c(2, 4)),
  )

  #' @srrstats {G5.8} Edge condition tests
  #' @srrstats {G5.8c} All-identical:
  expect_snapshot(
    ww_multi_scale(worldclim_simulation, response, response, n = c(2, 4))
  )
})

test_that("other generic srr standards", {
  skip_if_not_installed("withr")
  worldclim_predicted <- worldclim_simulation
  worldclim_predicted$predicted <- predict(
    lm(response ~ bio2 * bio10 * bio13 * bio19, data = worldclim_simulation),
    worldclim_simulation
  )
  noised_worldclim <- worldclim_predicted +
    rnorm(
      nrow(worldclim_predicted) * ncol(worldclim_predicted),
      .Machine$double.eps,
      .Machine$double.eps
    )
  noised_worldclim <- sf::st_as_sf(
    noised_worldclim,
    crs = sf::st_crs(worldclim_predicted)
  )

  #' @srrstats {G3.0} Testing with appropriate tolerances.
  #' @srrstats {G5.9} Noise susceptibility tests
  #' @srrstats {G5.9a} Trivial noise doesn't change results:
  expect_equal(
    withr::with_seed(
      123,
      ww_multi_scale(worldclim_predicted, response, predicted, n = c(2, 4))
    ),
    withr::with_seed(
      123,
      ww_multi_scale(noised_worldclim, response, predicted, n = c(2, 4))
    )
  )

  #' @srrstats {G3.0} Testing with appropriate tolerances.
  #' @srrstats {G5.9} Noise susceptibility tests
  #' @srrstats {G5.9a} Trivial noise doesn't change results:
  expect_equal(
    withr::with_seed(
      123,
      ww_multi_scale(worldclim_predicted, predicted, response, n = c(2, 4))
    ),
    withr::with_seed(
      123,
      ww_multi_scale(noised_worldclim, predicted, response, n = c(2, 4))
    )
  )

  #' @srrstats {G3.0} Testing with appropriate tolerances.
  #' @srrstats {G5.9} Noise susceptibility tests
  #' @srrstats {G5.9b} Different seeds are equivalent:
  expect_equal(
    withr::with_seed(
      123,
      ww_multi_scale(worldclim_predicted, predicted, response, n = c(2, 4))
    ),
    withr::with_seed(
      1107,
      ww_multi_scale(worldclim_predicted, predicted, response, n = c(2, 4))
    )
  )

  #' @srrstats {G3.0} Testing with appropriate tolerances.
  #' @srrstats {G5.9} Noise susceptibility tests
  #' @srrstats {G5.9b} Different seeds are equivalent:
  expect_equal(
    withr::with_seed(
      123,
      ww_multi_scale(worldclim_predicted, response, predicted, n = c(2, 4))
    ),
    withr::with_seed(
      1107,
      ww_multi_scale(worldclim_predicted, response, predicted, n = c(2, 4))
    )
  )

  #' @srrstats {SP2.3} Testing that loading data is equivalent
  expect_equal(
    ww_multi_scale(
      sf::st_read(
        system.file("worldclim_simulation.gpkg", package = "waywiser")
      ),
      bio13,
      bio19,
      n = c(2, 4)
    )$.estimate,
    ww_multi_scale(worldclim_predicted, bio13, bio19, n = c(2, 4))$.estimate
  )

  #' @srrstats {SP4.1} CRS (and therefore units) is preserved
  expect_identical(
    sf::st_crs(
      ww_multi_scale(worldclim_simulation, bio13, bio19, n = c(2, 4))$.grid[[1]]
    ),
    sf::st_crs(
      worldclim_simulation
    )
  )

  guerry_modeled <- suppressWarnings(sf::st_centroid(guerry))
  guerry_modeled$predictions <- predict(
    lm(Crm_prs ~ Litercy, guerry),
    guerry
  )
  proj_grid <- sf::st_make_grid(guerry, n = 2)

  guerry_modeled_geo <- sf::st_transform(guerry_modeled, 4326)
  geo_grid <- sf::st_transform(proj_grid, 4326)

  #' @srrstats {G3.0} Testing with appropriate tolerances.
  #' @srrstats {SP6.1} Testing with both projected and geographic CRS
  #' @srrstats {SP6.1b} Testing with both projected and geographic CRS
  #' @srrstats {SP6.2} Testing with ~global data
  expect_equal(
    ww_multi_scale(
      guerry_modeled,
      predictions,
      Crm_prs,
      grids = list(proj_grid)
    )$.estimate,
    ww_multi_scale(
      guerry_modeled_geo,
      predictions,
      Crm_prs,
      grids = list(geo_grid)
    )$.estimate
  )
})

test_that("raster method works", {
  skip_if_not_installed("terra")
  skip_if_not_installed("exactextractr")
  skip_if_not_installed("withr")

  r1 <- matrix(nrow = 10, ncol = 10)
  r1[] <- 1
  r1 <- terra::rast(r1)

  r2 <- matrix(nrow = 10, ncol = 10)
  r2[] <- 2
  r2 <- terra::rast(r2)

  r3 <- c(r1, r2)

  expect_identical(
    ww_multi_scale(
      truth = r1,
      estimate = r2,
      metrics = yardstick::rmse,
      n = 1
    )$.estimate,
    1
  )

  expect_identical(
    ww_multi_scale(
      truth = r1,
      estimate = r1,
      metrics = yardstick::rmse,
      n = 1
    )$.estimate,
    0
  )

  expect_identical(
    ww_multi_scale(
      r3,
      truth = 1,
      estimate = 2,
      metrics = yardstick::rmse,
      n = 1
    )$.estimate,
    1
  )

  expect_identical(
    ww_multi_scale(
      r3,
      truth = 1,
      estimate = 1,
      metrics = yardstick::rmse,
      n = 1
    )$.estimate,
    0
  )

  # built-in functions
  expect_identical(
    ww_multi_scale(
      truth = r1,
      estimate = r2,
      metrics = yardstick::rmse,
      aggregation_function = "median",
      n = 1
    )$.estimate,
    1
  )

  expect_identical(
    ww_multi_scale(
      r3,
      truth = 1,
      estimate = 2,
      metrics = yardstick::rmse,
      aggregation_function = "median",
      n = 1
    )$.estimate,
    1
  )

  # R functions
  expect_identical(
    ww_multi_scale(
      truth = r1,
      estimate = r2,
      metrics = yardstick::rmse,
      aggregation_function = stats::weighted.mean,
      n = 1
    )$.estimate,
    1
  )
})

test_that("raster method is equivalent", {
  skip_if_not_installed("terra")
  skip_if_not_installed("exactextractr")
  skip_if_not_installed("withr")

  withr::with_seed(
    123,
    {
      x <- terra::rast(matrix(rnorm(100), 10))
      y <- terra::rast(matrix(rnorm(100), 10))
    }
  )

  z <- sf::st_as_sf(terra::as.points(c(x, y)))

  sf_method <- ww_multi_scale(z, lyr.1, lyr.1.1, n = 2)
  sf::st_geometry(sf_method$.grid[[1]]) <- NULL
  sf::st_geometry(sf_method$.grid[[2]]) <- NULL

  terra_method <- ww_multi_scale(truth = x, estimate = y, n = 2)
  sf::st_geometry(terra_method$.grid[[1]]) <- NULL
  sf::st_geometry(terra_method$.grid[[2]]) <- NULL

  terra_data_method <- ww_multi_scale(c(x, y), truth = 1, estimate = 2, n = 2)
  sf::st_geometry(terra_data_method$.grid[[1]]) <- NULL
  sf::st_geometry(terra_data_method$.grid[[2]]) <- NULL

  expect_identical(sf_method, terra_method, tolerance = 1e-6)
  expect_identical(sf_method, terra_data_method, tolerance = 1e-6)
})

test_that("raster method errors as expected", {
  skip_if_not_installed("terra")
  skip_if_not_installed("exactextractr")

  r1 <- matrix(nrow = 10, ncol = 10)

  expect_snapshot(
    ww_multi_scale(truth = 1),
    error = TRUE
  )
  expect_snapshot(
    ww_multi_scale(truth = c(terra::rast(r1), terra::rast(r1))),
    error = TRUE
  )

  expect_snapshot(
    ww_multi_scale(truth = terra::rast(r1), estimate = 1),
    error = TRUE
  )
  expect_snapshot(
    ww_multi_scale(
      truth = terra::rast(r1),
      estimate = c(terra::rast(r1), terra::rast(r1))
    ),
    error = TRUE
  )
})

test_that("sf method supports quoted names", {
  expect_identical(
    waywiser::ww_multi_scale(
      waywiser::ny_trees,
      n_trees,
      agb,
      n = 10
    )$.estimate,
    waywiser::ww_multi_scale(
      waywiser::ny_trees,
      n_trees,
      "agb",
      n = 10
    )$.estimate
  )

  expect_identical(
    waywiser::ww_multi_scale(
      waywiser::ny_trees,
      n_trees,
      "agb",
      n = 10
    )$.estimate,
    waywiser::ww_multi_scale(
      waywiser::ny_trees,
      "n_trees",
      agb,
      n = 10
    )$.estimate
  )

  expect_identical(
    waywiser::ww_multi_scale(
      waywiser::ny_trees,
      "n_trees",
      agb,
      n = 10
    )$.estimate,
    waywiser::ww_multi_scale(
      waywiser::ny_trees,
      "n_trees",
      "agb",
      n = 10
    )$.estimate
  )
})

test_that("units are handled properly", {
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347),
        crs = 5072
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$truth <- rnorm(500, 123, 35)
  pts$estimate <- rnorm(500, 123, 39)

  cellsizes <- units::set_units(seq(20, 100, 10), "km")

  ww_output <- ww_multi_scale(
    pts,
    truth,
    estimate,
    cellsize = cellsizes,
    square = FALSE,
    metrics = yardstick::rmse
  )

  expect_identical(
    vapply(ww_output$.grid, nrow, integer(1)),
    vapply(
      cellsizes,
      function(cellsize)
        length(sf::st_make_grid(pts, cellsize, square = FALSE)),
      integer(1)
    )
  )
})

test_that("counts of non-NA values are correct", {
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347),
        crs = 5072
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$truth <- rnorm(500, 123, 35)
  pts$estimate <- rnorm(500, 123, 39)

  cellsizes <- units::set_units(20, "km")

  ww_output <- ww_multi_scale(
    pts,
    truth,
    estimate,
    cellsize = cellsizes,
    square = FALSE,
    metrics = yardstick::rmse
  )

  actual <- ww_output$.grid[[1]]$.truth_count
  expected <- vapply(
    seq_len(nrow(ww_output$.grid[[1]])),
    function(idx)
      nrow(sf::st_intersection((ww_output$.grid[[1]][idx, ]["x"]), pts["x"])),
    integer(1)
  )
  expected[expected == 0] <- NA_integer_
  expect_identical(actual, expected)
})

test_that("counts are the same whether or not column names are quoted", {
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347),
        crs = 5072
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$truth <- rnorm(500, 123, 35)
  pts$estimate <- rnorm(500, 123, 39)

  cellsizes <- units::set_units(seq(20, 100, 10), "km")

  expect_identical(
    lapply(
      waywiser::ww_multi_scale(
        pts,
        truth,
        estimate,
        cellsize = cellsizes,
        square = FALSE,
        metrics = yardstick::rmse
      )$.grid,
      function(x) x$.truth_count
    ),
    lapply(
      waywiser::ww_multi_scale(
        pts,
        "truth",
        "estimate",
        cellsize = cellsizes,
        square = FALSE,
        metrics = yardstick::rmse
      )$.grid,
      function(x) x$.truth_count
    )
  )
})

test_that("using protected names triggers errors", {
  skip_if_not_installed("units")
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347),
        crs = 5072
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$.truth <- rnorm(500, 123, 35)
  pts$.estimate <- rnorm(500, 123, 39)

  cellsizes <- units::set_units(20, "km")

  expect_snapshot_error(
    ww_multi_scale(
      pts,
      .truth,
      .estimate,
      cellsize = cellsizes,
      square = FALSE,
      metrics = yardstick::rmse
    )
  )

  pts$truth <- pts$.truth
  pts$.truth <- NULL

  expect_snapshot_error(
    ww_multi_scale(
      pts,
      truth,
      .estimate,
      cellsize = cellsizes,
      square = FALSE,
      metrics = yardstick::rmse
    )
  )
})


test_that("Data with an NA CRS works", {
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347)
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$truth <- rnorm(500, 123, 35)
  pts$estimate <- rnorm(500, 123, 39)

  expect_no_error(
    waywiser::ww_multi_scale(
      pts,
      truth,
      estimate,
      cellsize = 20000,
      square = FALSE,
      metrics = yardstick::rmse
    )
  )
})

test_that("Passing crs via `...` warns", {
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347)
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$truth <- rnorm(500, 123, 35)
  pts$estimate <- rnorm(500, 123, 39)

  expect_warning(
    waywiser::ww_multi_scale(
      pts,
      truth,
      estimate,
      cellsize = 20000,
      square = FALSE,
      metrics = yardstick::rmse,
      crs = sf::st_crs(4326)
    ),
    "`crs` argument"
  )
})

test_that("Passing arguments via `...` errors when using grids", {
  pts <- sf::st_sample(
    sf::st_as_sfc(
      sf::st_bbox(
        c(xmin = 1327326, ymin = 2175524, xmax = 1971106, ymax = 2651347)
      )
    ),
    500
  )

  pts <- sf::st_as_sf(pts)
  pts$truth <- rnorm(500, 123, 35)
  pts$estimate <- rnorm(500, 123, 39)

  grid <- sf::st_make_grid(pts, n = 4)

  expect_error(
    waywiser::ww_multi_scale(
      pts,
      truth,
      estimate,
      grids = list(grid),
      square = FALSE,
      metrics = yardstick::rmse,
      crs = sf::st_crs(4326)
    ),
    class = "rlib_error_dots_nonempty"
  )
})

test_that("ww_multi_scale with raster args can handle classification metrics (#60)", {
  skip_if_not_installed("terra")
  skip_if_not_installed("exactextractr")
  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),
      grids = 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")
  skip_if_not_installed("exactextractr")
  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),
      grids = list(sf::st_make_grid(l1))
    )$.estimate,
    1
  )
})

test_that("ww_multi_scale with raster args can handle class prob metrics", {
  skip_if_not_installed("terra")
  skip_if_not_installed("withr")
  skip_if_not_installed("exactextractr")
  l1 <- withr::with_seed(
    1107,
    matrix(sample(1:2, 100, TRUE), nrow = 10)
  )
  l1 <- terra::rast(l1)
  l2 <- withr::with_seed(
    1107,
    matrix(runif(100, 0, 1), nrow = 10)
  )
  l2 <- terra::rast(l2)

  expect_equal(
    ww_multi_scale(
      truth = l1,
      estimate = l2,
      metrics = list(yardstick::pr_auc),
      grids = list(sf::st_make_grid(l1))
    )$.estimate,
    0.47208959
  )
})

test_that("ww_multi_scale with raster data can handle class prob metrics", {
  skip_if_not_installed("terra")
  skip_if_not_installed("withr")
  skip_if_not_installed("exactextractr")
  l1 <- withr::with_seed(
    1107,
    matrix(sample(1:2, 100, TRUE), nrow = 10)
  )
  l1 <- terra::rast(l1)
  l2 <- withr::with_seed(
    1107,
    matrix(runif(100, 0, 1), nrow = 10)
  )
  l2 <- terra::rast(l2)

  r <- c(l1, l2)
  names(r) <- c("l1", "l2")

  expect_equal(
    ww_multi_scale(
      r,
      truth = "l1",
      estimate = "l2",
      metrics = list(yardstick::pr_auc),
      grids = list(sf::st_make_grid(l1))
    )$.estimate,
    0.47208959
  )
})

test_that("ww_multi_scale with rasters fails if metrics are mixed", {
  skip_if_not_installed("terra")
  skip_if_not_installed("exactextractr")
  l1 <- terra::rast(matrix(sample(1:10, 100, TRUE), nrow = 10))
  l2 <- l1

  r <- c(l1, l2)
  names(r) <- c("l1", "l2")

  expect_error(
    ww_multi_scale(
      truth = l1,
      estimate = l2,
      metrics = list(yardstick::precision, yardstick::pr_auc),
      grids = list(sf::st_make_grid(l1))
    )$.estimate,
    class = "waywiser_mixed_metrics"
  )

  expect_error(
    ww_multi_scale(
      r,
      truth = "l1",
      estimate = "l2",
      metrics = list(yardstick::precision, yardstick::pr_auc),
      grids = list(sf::st_make_grid(l1))
    )$.estimate,
    class = "waywiser_mixed_metrics"
  )
})