tests/testthat/test-bqs-select.R

In qcluster: Clustering via Quadratic Scoring

capture_warnings <- function(expr) {
  warnings <- character()
  value <- withCallingHandlers(
    expr,
    warning = function(w) {
      warnings <<- c(warnings, conditionMessage(w))
      invokeRestart("muffleWarning")
    }
  )

  list(value = value, warnings = warnings)
}

rankable_dat <- matrix(
  c(seq(-2, -1, length.out = 50), seq(1, 2, length.out = 50)),
  ncol = 1
)

rankable_method <- function(data) {
  x <- as.matrix(data)[, 1]
  cl <- ifelse(x < 0, 1L, 2L)
  list(
    params = clust2params(data, cl),
    K = 2L
  )
}

test_that("bqs_select validates rank as a positive integer", {
  dat <- iris[1:20, 1:4]

  good_method <- function(data) {
    list(params = clust2params(data, rep(1L, nrow(data))))
  }

  res <- bqs(dat, mbind(good_method), B = 0, ncores = 1, rankby = "mean")

  expect_error(
    bqs_select(res, rank = 0),
    "greater than or equal to 1"
  )
  expect_error(
    bqs_select(res, rank = 1.5),
    "greater than or equal to 1"
  )
})

test_that("bqs validates B as a non-negative integer", {
  dat <- iris[1:20, 1:4]

  good_method <- function(data) {
    list(params = clust2params(data, rep(1L, nrow(data))))
  }

  expect_error(
    bqs(dat, mbind(good_method), B = -1, ncores = 1, rankby = "mean"),
    "'B' must be an integer >= 0"
  )
})

test_that("bqs_select returns NULL cleanly when no ranked solution is available", {
  dat <- iris[1:20, 1:4]

  bad_method <- function(data) {
    stop("boom")
  }

  res <- suppressWarnings(
    bqs(dat, mbind(list(bad_method, bad_method)), B = 3, ncores = 1, rankby = "lq")
  )

  expect_no_warning({
    expect_message(
      selected <- bqs_select(res),
      "No ranked solution available"
    )
  })
  expect_null(selected)
})

test_that("bqs_select always refits selected rank-1 solutions on full data", {
  ctr <- 0L
  dat <- rankable_dat

  counting_method <- function(data) {
    ctr <<- ctr + 1L
    rankable_method(data)
  }

  res <- suppressMessages(
    bqs(dat, mbind(counting_method), B = 0, ncores = 1, rankby = "mean")
  )
  expect_equal(ctr, 2L)

  selected <- suppressMessages(bqs_select(res, rank = 1, type = "smooth"))
  expect_equal(ctr, 3L)
  expect_true("user_function_1" %in% names(selected))
  expect_equal(selected$user_function_1$K, 2)

  selected_rerank <- suppressWarnings(
    suppressMessages(bqs_select(res, rank = 1, type = "smooth", rankby = "mean"))
  )
  expect_equal(ctr, 5L)
  expect_true("user_function_1" %in% names(selected_rerank))
  expect_equal(selected_rerank$user_function_1$K, 2)
})

test_that("bqs_rank does not fail on small bootstrap sizes", {
  dat <- iris[1:20, 1:4]

  good_method <- function(data) {
    list(params = clust2params(data, rep(1L, nrow(data))))
  }

  res_lq <- capture_warnings(
    bqs(dat, mbind(good_method), B = 1, ncores = 1, rankby = "lq")
  )
  expect_equal(res_lq$value$rankby, "lq")
  expect_true(length(res_lq$warnings) > 0)

  res_1se <- capture_warnings(
    bqs(dat, mbind(good_method), B = 1, ncores = 1, rankby = "1se")
  )
  expect_equal(res_1se$value$rankby, "1se")
  expect_true(length(res_1se$warnings) > 0)
  expect_true(all(is.na(res_1se$value$smooth$rank)))

  res_1se_b4 <- capture_warnings(
    bqs(dat, mbind(good_method), B = 4, ncores = 1, rankby = "1se")
  )
  expect_equal(res_1se_b4$value$rankby, "1se")
  expect_true(length(res_1se_b4$warnings) > 0)
})

test_that("bqs_rank keeps all-NA 1se criteria unrated", {
  data("banknote", package = "qcluster")
  dat <- banknote[, -1]
  met <- mset_gmix(K = 2:5)

  res <- capture_warnings(
    bqs(dat, methodset = met, B = 1, ncores = 1, rankby = "1se")
  )

  expect_equal(res$value$rankby, "1se")
  expect_true(length(res$warnings) > 0)
  expect_true(all(is.na(res$value$smooth$sterr)))
  expect_true(all(is.na(res$value$smooth$rank)))
})

test_that("bqs_rank removes stale best_* when a new ranking has no rank-1 solution", {
  dat <- rankable_dat
  met <- mbind(rankable_method)

  ranked_mean <- bqs(dat, methodset = met, B = 1, ncores = 1, rankby = "mean")
  expect_false(is.null(ranked_mean$best_smooth))

  ranked_1se <- suppressWarnings(bqs_rank(ranked_mean, "1se"))
  expect_true(all(is.na(ranked_1se$smooth$rank)))
  expect_null(ranked_1se$best_smooth)
})

test_that("bqs_select records refit failures as structured list entries", {
  dat <- rankable_dat
  res <- bqs(dat, mbind(list(rankable_method, rankable_method)), B = 1, ncores = 1, rankby = "mean")
  res$methodset[[1]]$fn <- function(data, only_params = FALSE) {
    stop("full fit fails")
  }

  selected <- suppressMessages(bqs_select(res, rank = 1, type = "smooth"))

  expect_true("user_function_1" %in% names(selected))
  expect_true("user_function_2" %in% names(selected))
  expect_s3_class(selected$user_function_1, "bqs_select_error")
  expect_equal(selected$user_function_1$status, "error")
  expect_match(selected$user_function_1$message, "full fit fails")
  expect_false(inherits(selected$user_function_2, "bqs_select_error"))
})