tests/testthat/test-cv_knndm.R

In blockCV: Spatial and Environmental Blocking for Cross-Validation

expect_names <- c(
    "folds_list",
    "folds_ids",
    "biomod_table",
    "k",
    "column",
    "presence_bg",
    "type",
    "space",
    "q",
    "W",
    "Gij",
    "Gj",
    "Gjstar",
    "blocks",
    "plot",
    "records"
)


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_all <- pa_data
pa_data <- pa_data[1:100, ]


test_that("test that cv_knndm works with the default block clustering", {
    set.seed(1)
    knn <- cv_knndm(
        x = pa_data,
        column = "occ",
        r = aus,
        k = 5,
        num_sample = 3000,
        plot = FALSE,
        report = FALSE
    )

    expect_true(exists("knn"))
    expect_s3_class(knn, "cv_knndm")
    expect_equal(names(knn), expect_names)
    expect_equal(knn$k, 5L)
    expect_type(knn$k, "integer")
    expect_equal(length(knn$folds_list), 5L)
    expect_equal(length(knn$folds_ids), nrow(pa_data))
    expect_false(anyNA(knn$folds_ids))
    expect_equal(sort(unique(knn$folds_ids)), 1:5)
    expect_type(knn$W, "double")
    expect_equal(knn$space, "geographical")
    # regular sampling of a non-rectangular raster returns up to num_sample points
    expect_true(length(knn$Gij) > 0 && length(knn$Gij) <= 3000)
    expect_length(knn$Gj, nrow(pa_data))
    expect_length(knn$Gjstar, nrow(pa_data))
    expect_equal(dim(knn$records), c(5L, 4L))
    expect_equal(dim(knn$biomod_table), c(nrow(pa_data), 5L))
    expect_true(!all(knn$records == 0))
    # no fold exceeds maxp
    expect_true(max(table(knn$folds_ids)) <= 0.5 * nrow(pa_data))
})


test_that("cv_knndm keeps and tags spatial blocks when clustering = 'blocks'", {
    set.seed(1)
    knn <- cv_knndm(
        x = pa_data,
        column = "occ",
        r = aus,
        k = 5,
        num_sample = 3000,
        plot = FALSE,
        report = FALSE
    )

    # blocks are kept only when the blocks variant actually produced the folds
    if(identical(knn$type, "kNNDM (blocks)")){
        expect_s3_class(knn$blocks, "sf")
        expect_true("folds" %in% names(knn$blocks))
        expect_true(nrow(knn$blocks) >= 5L)
        # every block is tagged with a valid fold id
        expect_true(all(knn$blocks$folds %in% 1:5))
        # a block never straddles two folds: its points share a single fold
        bid <- sf::st_intersects(sf::st_geometry(pa_data), sf::st_geometry(knn$blocks))
        bid <- vapply(bid, function(z) if(length(z)) z[1] else NA_integer_, integer(1))
        ok <- vapply(which(!is.na(bid)), function(i){
            knn$folds_ids[i] == knn$blocks$folds[bid[i]]
        }, logical(1))
        expect_true(all(ok))
    } else {
        expect_null(knn$blocks)
    }

    # keep_blocks = FALSE drops the blocks
    set.seed(1)
    knn0 <- cv_knndm(
        x = pa_data, column = "occ", r = aus, k = 5, keep_blocks = FALSE,
        num_sample = 3000, plot = FALSE, report = FALSE
    )
    expect_null(knn0$blocks)

    # non-blocks clustering never keeps blocks
    set.seed(1)
    kh <- cv_knndm(
        x = pa_data, r = aus, k = 4, clustering = "hierarchical",
        num_sample = 3000, nk_len = 40, plot = FALSE, report = FALSE
    )
    expect_null(kh$blocks)
})


test_that("test that cv_knndm works with hierarchical and kmeans clustering", {
    set.seed(1)
    kh <- cv_knndm(
        x = pa_data, r = aus, k = 4, clustering = "hierarchical",
        num_sample = 3000, nk_len = 40, plot = FALSE, report = FALSE
    )
    expect_s3_class(kh, "cv_knndm")
    expect_equal(names(kh), expect_names)
    expect_equal(length(kh$folds_list), 4L)
    expect_equal(dim(kh$records), c(4L, 2L))

    set.seed(1)
    km <- cv_knndm(
        x = pa_data, r = aus, k = 4, clustering = "kmeans",
        num_sample = 3000, nk_len = 40, plot = FALSE, report = FALSE
    )
    expect_s3_class(km, "cv_knndm")
    expect_equal(sort(unique(km$folds_ids)), 1:4)

    expect_output(print(kh), "blockCV cv_knndm")
    expect_output(summary(kh))
})


test_that("test that cv_knndm avoids avoidable class-empty folds", {
    set.seed(1)
    expect_warning(
        knn <- cv_knndm(
            x = pa_data_all,
            column = "occ",
            r = aus,
            k = 5,
            clustering = "hierarchical",
            num_sample = 1000,
            sampling = "random",
            nk_len = 60,
            plot = FALSE,
            report = FALSE
        ),
        NA
    )

    test_records <- knn$records[, startsWith(names(knn$records), "test_"), drop = FALSE]
    expect_true(all(test_records > 0))
})


test_that("test that cv_knndm works in feature space", {
    set.seed(1)
    kf <- cv_knndm(
        x = pa_data, r = aus, k = 4, space = "feature",
        clustering = "hierarchical", num_sample = 2000, nk_len = 40,
        plot = FALSE, report = FALSE
    )
    expect_s3_class(kf, "cv_knndm")
    expect_equal(kf$space, "feature")
    expect_equal(sort(unique(kf$folds_ids)), 1:4)

    # blocks is coerced to hierarchical in feature space
    expect_message(
        cv_knndm(x = pa_data, r = aus, k = 4, space = "feature",
                 clustering = "blocks", num_sample = 2000, nk_len = 20,
                 plot = FALSE, report = FALSE)
    )
})


test_that("test that cv_knndm accepts explicit prediction points", {
    set.seed(1)
    pp <- sf::st_as_sf(terra::spatSample(aus[[1]], size = 1000, method = "regular",
                                         na.rm = TRUE, as.points = TRUE))
    knn <- cv_knndm(
        x = pa_data, pred_points = pp, k = 5, clustering = "hierarchical",
        nk_len = 30, plot = FALSE, report = FALSE
    )
    expect_s3_class(knn, "cv_knndm")
    expect_length(knn$Gij, nrow(pp))
})


test_that("test that cv_knndm is reproducible with a seed", {
    a <- cv_knndm(x = pa_data, r = aus, k = 5, num_sample = 2000, seed = 42, plot = FALSE, report = FALSE)
    b <- cv_knndm(x = pa_data, r = aus, k = 5, num_sample = 2000, seed = 42, plot = FALSE, report = FALSE)
    expect_identical(a$folds_ids, b$folds_ids)
})


test_that("test cv_knndm errors with invalid arguments", {
    # invalid x
    expect_error(cv_knndm(x = "pa_data", r = aus, k = 5), "sf or spatial")
    # k too small
    expect_error(cv_knndm(x = pa_data, r = aus, k = 1, num_sample = 2000))
    # maxp outside (1/k, 1)
    expect_error(cv_knndm(x = pa_data, r = aus, k = 5, maxp = 2, num_sample = 2000))
    expect_error(cv_knndm(x = pa_data, r = aus, k = 5, maxp = 0.1, num_sample = 2000))
    # no prediction source
    expect_error(cv_knndm(x = pa_data, k = 5))
})


test_that("test cv_knndm errors with mismatched or missing CRS", {
    nocrs <- pa_data
    sf::st_crs(nocrs) <- NA
    expect_error(cv_knndm(x = nocrs, column = "occ", r = aus, k = 5))

    reproj <- sf::st_transform(pa_data, 4326)
    expect_error(cv_knndm(x = reproj, r = aus, k = 5, num_sample = 2000))
})