tests/testthat/test-cv_distance.R

In blockCV: Spatial and Environmental Blocking for Cross-Validation

aus <- terra::rast(
    list.files(system.file("extdata/au/", package = "blockCV"), full.names = TRUE)
)

pa_data <- sf::st_as_sf(
    read.csv(system.file("extdata/", "species.csv", package = "blockCV")),
    coords = c("x", "y"),
    crs = 7845
)
pa_data <- pa_data[1:200, ]

scv <- cv_spatial(
    x = pa_data,
    k = 5,
    selection = "random",
    iteration = 1,
    balance = FALSE,
    biomod2 = FALSE,
    plot = FALSE,
    report = FALSE,
    progress = FALSE
)


test_that("cv_distance returns a cv_distance object with W", {

    res <- cv_distance(cv = scv, x = pa_data, r = aus, num_sample = 2000,
                       add_random = TRUE, plot = FALSE)

    expect_s3_class(res, "cv_distance")
    expect_named(res, c("distances", "W", "plot", "pbg"))
    W <- res$W
    expect_true(is.numeric(W))
    expect_true(all(c("CV", "LOO", "Random") %in% names(W)))
    expect_true(all(W >= 0))
})


test_that("cv_distance returns a per-fold distance summary", {

    res <- cv_distance(cv = scv, x = pa_data, r = aus, num_sample = 2000,
                       add_random = FALSE, plot = FALSE)

    d <- res$distances
    expect_s3_class(d, "data.frame")
    # one row per fold
    expect_equal(nrow(d), length(scv$folds_list))
    expect_setequal(d$fold, seq_along(scv$folds_list))
    expect_named(d, c("fold", "n_test", "min", "q1", "median", "q3", "max", "pct_below_pred"))
    # quartiles are ordered and distances non-negative
    expect_true(all(d$min <= d$median & d$median <= d$max))
    expect_true(all(d$min >= 0))
    # pct_below_pred is a valid percentage
    expect_true(all(d$pct_below_pred >= 0 & d$pct_below_pred <= 100))
})


test_that("plot toggle controls drawing only, not the returned object", {

    # the ggplot is always built and returned, whether or not it is drawn
    res0 <- cv_distance(cv = scv, x = pa_data, r = aus, num_sample = 2000,
                        seed = 1, plot = FALSE)
    res1 <- cv_distance(cv = scv, x = pa_data, r = aus, num_sample = 2000,
                        seed = 1, plot = TRUE)
    expect_true(ggplot2::is_ggplot(res0$plot))
    expect_true(ggplot2::is_ggplot(res1$plot))
    # same data regardless of the plot toggle
    expect_equal(res0$distances, res1$distances)
    expect_equal(res0$W, res1$W)
})


test_that("cv_distance works in feature space", {

    res <- cv_distance(cv = scv, x = pa_data, r = aus, space = "feature",
                       num_sample = 2000, plot = FALSE)

    expect_s3_class(res, "cv_distance")
    expect_true("CV" %in% names(res$W))
})


test_that("cv_distance works on a leave-one-out object (no Random curve)", {
    bloo <- cv_buffer(
        x = pa_data,
        size = 250000,
        progress = FALSE,
        report = FALSE
    )

    expect_message(
        res <- cv_distance(cv = bloo, x = pa_data, r = aus, num_sample = 2000, plot = FALSE),
        "leave-one-out"
    )
    expect_s3_class(res, "cv_distance")
    W <- res$W
    expect_false("Random" %in% names(W))
    expect_true(all(c("CV", "LOO") %in% names(W)))
})


test_that("cv_distance errors on a non-cv object", {
    expect_error(cv_distance(cv = list(a = 1), x = pa_data, r = aus, plot = FALSE))
})


test_that("cv_distance adds a Transfer curve and W_transfer with a transfer raster", {

    # a stand-in transfer domain (e.g. a future scenario): same layers, shifted values
    fut <- aus + 2
    names(fut) <- names(aus)

    res <- cv_distance(cv = scv, x = pa_data, r = aus, transfer = fut,
                       space = "feature", num_sample = 2000, seed = 1, plot = FALSE)

    expect_s3_class(res, "cv_distance")
    expect_true("W_transfer" %in% names(res))
    expect_named(res$W_transfer, c("CV", "LOO", "Prediction"))
    expect_true(all(res$W_transfer >= 0))
    # the Transfer curve is drawn (its ecdf column is in the plot data)
    expect_true("Transfer" %in% names(res$plot$data))
    expect_true(ggplot2::is_ggplot(res$plot))
})


test_that("cv_distance omits W_transfer when no transfer raster is supplied", {

    res <- cv_distance(cv = scv, x = pa_data, r = aus, space = "feature",
                       num_sample = 2000, plot = FALSE)
    expect_false("W_transfer" %in% names(res))
})


test_that("transfer requires feature space and matching layers", {

    fut <- aus + 2
    names(fut) <- names(aus)

    # geographical space is not supported with a transfer domain
    expect_error(
        cv_distance(cv = scv, x = pa_data, r = aus, transfer = fut,
                    space = "geographical", num_sample = 500, plot = FALSE),
        "only supported when space"
    )

    # a transfer raster with different layers is rejected
    fut_bad <- fut[[1:3]]
    expect_error(
        cv_distance(cv = scv, x = pa_data, r = aus, transfer = fut_bad,
                    space = "feature", num_sample = 500, plot = FALSE),
        "same layers"
    )
})