tests/testthat/test-cluster-compression.R

In gsClusterDetect: Utilities for Geo-Spatial Cluster Detection and Significance Classification

.load_example_data <- function() {
  location <- example_count_data <- NULL
  data(
    "example_count_data",
    package = "gsClusterDetect",
    envir = environment()
  )
  cases <- data.table::as.data.table(example_count_data)
  cases[, location := as.character(location)]
  cases
}

.make_alert_table <- function() {
  cases <- .load_example_data()
  dm <- gsClusterDetect::county_distance_matrix(
    "OH",
    source = "tigris"
  )[["distance_matrix"]]
  cg <- gsClusterDetect::generate_case_grids(
    cases,
    detect_date = as.Date("2025-01-31"),
    baseline_length = 60,
    max_test_window_days = 7
  )
  nci <- gsClusterDetect::gen_nearby_case_info(
    cg, dm,
    distance_limit = 50
  )
  oe <- gsClusterDetect::generate_observed_expected(
    nci, cg,
    adjust = TRUE
  )
  alerts <- gsClusterDetect::add_spline_threshold(
    oe,
    spline_lookup = "01"
  )
  list(cases = cases, dm = dm, alerts = alerts)
}

testthat::test_that("compress_clusters smoke and structural invariants", {
  x <- .make_alert_table()
  cl <- gsClusterDetect::compress_clusters(
    cluster_alert_table = x[["alerts"]],
    distance_matrix = x[["dm"]]
  )

  testthat::expect_true("clusters" %in% class(cl))
  testthat::expect_true(
    all(c("cluster_alert_table", "clust_loc_list") %in% names(cl))
  )
  testthat::expect_gt(nrow(cl[["cluster_alert_table"]]), 0)
  testthat::expect_equal(
    nrow(cl[["cluster_alert_table"]]),
    length(cl[["clust_loc_list"]])
  )
  testthat::expect_equal(
    as.integer(cl[["cluster_alert_table"]][["nr_locs"]]),
    as.integer(vapply(cl[["clust_loc_list"]], length, integer(1)))
  )

  dl <- gsClusterDetect::create_dist_list(
    level = "county",
    threshold = 50,
    st = "OH",
    unit = "miles"
  )
  cl_list <- gsClusterDetect::compress_clusters(
    cluster_alert_table = data.table::copy(x[["alerts"]]),
    distance_matrix = dl
  )
  testthat::expect_true("clusters" %in% class(cl_list))
})

testthat::test_that("compress_clusters errors on wrong class and empty input", {
  x <- .make_alert_table()
  empty_alerts <- data.table::copy(x[["alerts"]])[0]
  class(empty_alerts) <- unique(c(class(empty_alerts), "ClusterAlertTable"))

  testthat::expect_error(
    gsClusterDetect::compress_clusters(
      cluster_alert_table = data.table::data.table(),
      distance_matrix = x[["dm"]]
    ),
    "ClusterAlertTable"
  )
  testthat::expect_error(
    gsClusterDetect::compress_clusters(
      cluster_alert_table = empty_alerts,
      distance_matrix = x[["dm"]]
    ),
    "No clusters"
  )
})

testthat::test_that(
  "compress_clusters_fast is consistent with compress_clusters targets",
  {
    x <- .make_alert_table()
    cl_slow <- gsClusterDetect::compress_clusters(
      cluster_alert_table = data.table::copy(x[["alerts"]]),
      distance_matrix = x[["dm"]]
    )
    cl_fast <- gsClusterDetect::compress_clusters_fast(
      cluster_alert_table = data.table::copy(x[["alerts"]]),
      distance_matrix = x[["dm"]]
    )

    testthat::expect_true("clusters" %in% class(cl_fast))
    testthat::expect_equal(
      sort(cl_fast[["cluster_alert_table"]][["target"]]),
      sort(cl_slow[["cluster_alert_table"]][["target"]])
    )

    fast_sets <- lapply(cl_fast[["clust_loc_list"]], sort)
    slow_sets <- lapply(cl_slow[["clust_loc_list"]], sort)
    testthat::expect_equal(
      unname(sort(vapply(fast_sets, paste, character(1), collapse = "|"))),
      unname(sort(vapply(slow_sets, paste, character(1), collapse = "|")))
    )

    dl <- gsClusterDetect::create_dist_list(
      level = "county",
      threshold = 50,
      st = "OH",
      unit = "miles"
    )
    cl_fast_list <- gsClusterDetect::compress_clusters_fast(
      cluster_alert_table = data.table::copy(x[["alerts"]]),
      distance_matrix = dl
    )
    testthat::expect_true("clusters" %in% class(cl_fast_list))
  }
)

testthat::test_that(
  "compress_clusters_fast validates class and empty alert table",
  {
    x <- .make_alert_table()
    empty_alerts <- data.table::copy(x[["alerts"]])[0]
    class(empty_alerts) <- unique(c(class(empty_alerts), "ClusterAlertTable"))

    testthat::expect_error(
      gsClusterDetect::compress_clusters_fast(
        cluster_alert_table = data.table::data.table(),
        distance_matrix = x[["dm"]]
      ),
      "ClusterAlertTable"
    )
    testthat::expect_error(
      gsClusterDetect::compress_clusters_fast(
        cluster_alert_table = empty_alerts,
        distance_matrix = x[["dm"]]
      ),
      "No clusters"
    )
  }
)

testthat::test_that(
  "add_location_counts attaches per-location counts for each cluster",
  {
    x <- .make_alert_table()
    cl <- gsClusterDetect::compress_clusters_fast(
      cluster_alert_table = data.table::copy(x[["alerts"]]),
      distance_matrix = x[["dm"]]
    )
    out <- gsClusterDetect::add_location_counts(cl, x[["cases"]])

    testthat::expect_true("clusters" %in% class(out))
    testthat::expect_true(
      all(c("cluster_alert_table", "cluster_location_counts") %in% names(out))
    )
    testthat::expect_gt(nrow(out[["cluster_location_counts"]]), 0)
    testthat::expect_true(all(out[["cluster_location_counts"]][["count"]] >= 0))

    loc_counts <- out[["cluster_location_counts"]][, .N, by = target][
      order(target)
    ]
    nr <- out[["cluster_alert_table"]][, .(target, nr_locs)][order(target)]
    data.table::setnames(loc_counts, "N", "nr_locs")
    data.table::setkey(nr, NULL)
    data.table::setkey(loc_counts, NULL)
    testthat::expect_equal(nr, loc_counts)

    loc0 <- cl[["clust_loc_list"]][[1]][1]
    cases_df <- as.data.frame(x[["cases"]])
    cases_df[cases_df$location == loc0, "count"] <- 0L
    out0 <- try(
      gsClusterDetect::add_location_counts(cl, cases_df),
      silent = TRUE
    )
    if (!inherits(out0, "try-error")) {
      testthat::expect_true(
        any(out0[["cluster_location_counts"]][location == loc0, count] == 0)
      )
    } else {
      testthat::expect_true(inherits(out0, "try-error"))
    }
  }
)

testthat::test_that("add_location_counts validates class requirements", {
  x <- .make_alert_table()
  testthat::expect_error(
    gsClusterDetect::add_location_counts(
      cluster_list = list(),
      cases = x[["cases"]]
    ),
    "class 'clusters'"
  )

  cl <- gsClusterDetect::compress_clusters_fast(
    cluster_alert_table = data.table::copy(x[["alerts"]]),
    distance_matrix = x[["dm"]]
  )
  bad_cl <- cl
  bad_cl[["cluster_alert_table"]][, nr_locs := nr_locs + 1]
  testthat::expect_error(
    gsClusterDetect::add_location_counts(bad_cl, x[["cases"]]),
    "differs from number of locations"
  )
})

testthat::test_that("reduce_clusters_to_min filters by summed cluster count", {
  x <- .make_alert_table()
  cl <- gsClusterDetect::compress_clusters_fast(
    cluster_alert_table = data.table::copy(x[["alerts"]]),
    distance_matrix = x[["dm"]]
  )
  with_counts <- gsClusterDetect::add_location_counts(cl, x[["cases"]])

  unchanged <- gsClusterDetect::reduce_clusters_to_min(
    with_counts,
    minimum = 1
  )
  testthat::expect_equal(unchanged, with_counts)

  with_counts[[1]] <- .clean_up_alert_table(with_counts[[1]])
  with_counts[[2]] <- data.table::setnames(
    with_counts[[2]],
    c("location", "count", "cluster_center")
  )

  reduced <- gsClusterDetect::reduce_clusters_to_min(
    with_counts,
    minimum = 20
  )
  testthat::expect_true("clusters" %in% class(reduced))
  if (nrow(reduced[[2]]) > 0) {
    sums <- reduced[[2]][
      ,
      .(total = sum(count, na.rm = TRUE)),
      by = cluster_center
    ]
    testthat::expect_true(all(sums[["total"]] >= 20))
  }
})

testthat::test_that("reduce_clusters_to_min validates clusters input", {
  testthat::expect_error(
    gsClusterDetect::reduce_clusters_to_min(list(), minimum = 2),
    "class 'clusters'"
  )
})