tests/testthat/test-cv_group.R

In blockCV: Spatial and Environmental Blocking for Cross-Validation

group_test_data <- function(){
    sizes <- c(2L, 3L, 4L, 2L, 5L, 3L)
    groups <- rep(sprintf("site_%02d", seq_along(sizes)), sizes)
    dat <- data.frame(
        site = groups,
        occ = rep(c(0L, 1L), length.out = length(groups)),
        x = seq_along(groups),
        y = (seq_along(groups) %% 5L) + rep(seq_along(sizes), sizes),
        stringsAsFactors = FALSE
    )
    sf::st_as_sf(dat, coords = c("x", "y"), crs = 7845)
}

balanced_group_test_data <- function(){
    group_ids <- sprintf("site_%02d", 1:9)
    group_occ <- c(0L, 0L, 1L, 0L, 0L, 1L, 0L, 0L, 1L)
    groups <- rep(group_ids, each = 3L)
    dat <- data.frame(
        site = groups,
        occ = rep(group_occ, each = 3L),
        x = seq_along(groups),
        y = rep(seq_along(group_ids), each = 3L),
        stringsAsFactors = FALSE
    )
    sf::st_as_sf(dat, coords = c("x", "y"), crs = 7845)
}

expect_group_integrity <- function(cv, x, group_col = "site"){
    groups <- as.character(x[[group_col]])

    row_tests <- unlist(lapply(cv$folds_list, `[[`, 2L), use.names = FALSE)
    expect_length(row_tests, nrow(x))
    expect_setequal(row_tests, seq_len(nrow(x)))

    group_folds <- tapply(cv$folds_ids, groups, function(z) unique(stats::na.omit(z)))
    expect_true(all(lengths(group_folds) == 1L))

    for(i in seq_along(cv$folds_list)){
        train_groups <- unique(groups[cv$folds_list[[i]][[1L]]])
        test_groups <- unique(groups[cv$folds_list[[i]][[2L]]])
        expect_false(any(test_groups %in% train_groups))
    }
}


test_that("cv_group keeps each group intact", {
    pts <- group_test_data()

    res <- cv_group(
        x = pts,
        group_col = "site",
        column = "occ",
        k = 3,
        biomod2 = FALSE,
        report = FALSE
    )

    expect_s3_class(res, "cv_group")
    expect_equal(res$group_col, "site")
    expect_equal(res$presence_bg, FALSE)
    expect_equal(res$k, 3)
    expect_equal(res$type, "Grouped (merged to k folds)")
    expect_group_integrity(res, pts)
})


test_that("cv_group leave-group-out mode leaves one group out per fold", {
    pts <- group_test_data()
    group_sizes <- table(pts$site)

    res <- cv_group(
        x = pts,
        group_col = "site",
        column = "occ",
        biomod2 = FALSE,
        report = FALSE
    )

    expect_s3_class(res, "cv_group")
    expect_equal(res$type, "Leave-group-out")
    expect_equal(res$k, length(group_sizes))
    expect_equal(res$n_groups, length(group_sizes))
    expect_equal(length(res$folds_list), length(group_sizes))
    expect_equal(dim(res$records), c(length(group_sizes), 4L))
    expect_null(res$biomod_table)
    expect_group_integrity(res, pts)

    test_groups <- vapply(res$folds_list, function(fold){
        unique(as.character(pts$site[fold[[2L]]]))
    }, character(1))
    expect_setequal(test_groups, names(group_sizes))
    expect_equal(unname(vapply(res$folds_list, function(fold) length(fold[[2L]]), integer(1))),
                 unname(as.integer(group_sizes[test_groups])))
})


test_that("cv_group merges groups into k folds without splitting groups", {
    pts <- group_test_data()

    res <- cv_group(
        x = pts,
        group_col = "site",
        column = "occ",
        k = 3,
        biomod2 = TRUE,
        report = FALSE
    )

    expect_equal(res$type, "Grouped (merged to k folds)")
    expect_equal(res$k, 3)
    expect_equal(length(res$folds_list), 3)
    expect_equal(dim(res$biomod_table), c(nrow(pts), 3L))
    expect_group_integrity(res, pts)

    group_folds <- tapply(res$folds_ids, pts$site, unique)
    expect_equal(sort(as.integer(table(unlist(group_folds)))), c(2L, 2L, 2L))

    for(i in seq_len(res$k)){
        test_set <- res$folds_list[[i]][[2L]]
        train_set <- res$folds_list[[i]][[1L]]
        expect_true(all(!res$biomod_table[test_set, i]))
        expect_true(all(res$biomod_table[train_set, i]))
    }
})


test_that("cv_group balance mode improves class coverage while preserving groups", {
    pts <- balanced_group_test_data()

    expect_warning(
        unbalanced <- cv_group(
            x = pts,
            group_col = "site",
            column = "occ",
            k = 3,
            balance = FALSE,
            biomod2 = FALSE,
            report = FALSE
        ),
        "zero records"
    )

    expect_silent(
        balanced <- cv_group(
            x = pts,
            group_col = "site",
            column = "occ",
            k = 3,
            balance = TRUE,
            iteration = 200,
            seed = 42,
            biomod2 = FALSE,
            report = FALSE,
            progress = FALSE
        )
    )

    expect_group_integrity(unbalanced, pts)
    expect_group_integrity(balanced, pts)
    expect_equal(balanced$type, "Grouped (merged to k folds)")

    test_cols <- grep("^test", names(balanced$records), value = TRUE)
    expect_gt(sum(unbalanced$records[, test_cols] == 0), 0)
    expect_true(all(balanced$records[, test_cols] > 0))

    balanced_again <- cv_group(
        x = pts,
        group_col = "site",
        column = "occ",
        k = 3,
        balance = TRUE,
        iteration = 200,
        seed = 42,
        biomod2 = FALSE,
        report = FALSE,
        progress = FALSE
    )
    expect_identical(balanced_again$folds_ids, balanced$folds_ids)
})


test_that("cv_group rejects missing or invalid groups", {
    pts <- group_test_data()

    expect_error(
        cv_group(x = pts, group_col = "missing_site", report = FALSE),
        "There is no column named 'missing_site'"
    )

    pts_na <- pts
    pts_na$site[1] <- NA_character_
    expect_error(
        cv_group(x = pts_na, group_col = "site", report = FALSE),
        "contains missing values"
    )

    pts_one <- pts
    pts_one$site <- "only_site"
    expect_error(
        cv_group(x = pts_one, group_col = "site", report = FALSE),
        "at least two distinct groups"
    )
})


test_that("cv_group plotting requires data and returns ggplot objects", {
    pts <- group_test_data()
    res <- cv_group(
        x = pts,
        group_col = "site",
        column = "occ",
        k = 3,
        biomod2 = FALSE,
        report = FALSE
    )

    expect_error(
        plot(res),
        "The original sample data are required"
    )

    plt <- cv_plot(cv = res, x = pts, num_plots = 1:2)
    expect_true(ggplot2::is_ggplot(plt))

    combined <- cv_plot(cv = res, x = pts, combine_folds = TRUE)
    expect_true(ggplot2::is_ggplot(combined))

    from_plot <- plot(res, data = pts, combine_folds = TRUE)
    expect_true(ggplot2::is_ggplot(from_plot))
})