tests/testthat/test-messages-extended.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Extended coverage tests for matching_messages.R
# ==============================================================================

# ------------------------------------------------------------------------------
# Helper functions
# ------------------------------------------------------------------------------

test_that("use_emoji respects option", {
  old <- getOption("couplr.emoji")
  on.exit(options(couplr.emoji = old), add = TRUE)

  options(couplr.emoji = FALSE)
  expect_false(couplr:::use_emoji())
})

test_that("couplr_emoji returns empty string when disabled", {
  old <- getOption("couplr.emoji")
  on.exit(options(couplr.emoji = old), add = TRUE)

  options(couplr.emoji = FALSE)
  expect_equal(couplr:::couplr_emoji("error"), "")
})

# ------------------------------------------------------------------------------
# Error message functions
# ------------------------------------------------------------------------------

test_that("err_missing_data stops with message", {
  expect_error(couplr:::err_missing_data("left"), "No matches made")
})

test_that("err_missing_vars stops with message", {
  expect_error(couplr:::err_missing_vars(c("x", "y"), "left"), "Missing variables")
})

test_that("err_invalid_param stops with message", {
  expect_error(couplr:::err_invalid_param("method", "bad", "auto or jv"), "invalid value")
})

test_that("err_no_valid_pairs stops with message", {
  expect_error(couplr:::err_no_valid_pairs(), "No valid pairs")
  expect_error(couplr:::err_no_valid_pairs("all infinite"), "Reason")
})

# ------------------------------------------------------------------------------
# Warning message functions
# ------------------------------------------------------------------------------

test_that("warn_constant_var issues warning", {
  expect_warning(couplr:::warn_constant_var("x"), "constant")
})

test_that("warn_many_zeros issues warning", {
  expect_warning(couplr:::warn_many_zeros(50.5, 100), "50.5%")
})

test_that("warn_extreme_costs issues warning", {
  expect_warning(couplr:::warn_extreme_costs(10, 100, 10), "highly skewed")
  expect_warning(couplr:::warn_extreme_costs(10, 100, 10, c("var1")), "extreme values")
})

test_that("warn_many_forbidden issues warning for different severities", {
  # Critical severity (>90%)
  expect_warning(couplr:::warn_many_forbidden(95, 5, 10), "forbidden")
  # Concerning severity (>75%)
  expect_warning(couplr:::warn_many_forbidden(80, 20, 10), "forbidden")
  # Moderate severity
  expect_warning(couplr:::warn_many_forbidden(60, 40, 10), "forbidden")
})

test_that("warn_constant_distance issues warning", {
  expect_warning(couplr:::warn_constant_distance(0.5), "identical")
})

test_that("warn_poor_quality issues warning", {
  expect_warning(couplr:::warn_poor_quality(25, 0.5), "exceed distance")
})

test_that("warn_parallel_unavailable issues warning", {
  expect_warning(couplr:::warn_parallel_unavailable(), "Parallel processing")
})

# ------------------------------------------------------------------------------
# Info/success message functions
# ------------------------------------------------------------------------------

test_that("couplr_inform outputs message", {
  expect_message(couplr:::couplr_inform("Test info"), "Test info")
})

test_that("couplr_success outputs message", {
  expect_message(couplr:::couplr_success("Success!"), "Success!")
})

test_that("info_low_match_rate handles different percentages", {
  # Very low match rate (<25%) - warning
  expect_warning(couplr:::info_low_match_rate(2, 10, 20), "Only")

  # Moderate match rate (25-50%) - message
  expect_message(couplr:::info_low_match_rate(4, 10, 40), "Moderate")

  # Good match rate (>50%) - no output
  expect_silent(couplr:::info_low_match_rate(6, 10, 60))
})

test_that("success_good_balance outputs message for excellent balance", {
  expect_message(couplr:::success_good_balance(0.05), "Excellent balance")
  expect_silent(couplr:::success_good_balance(0.15))
})

# ------------------------------------------------------------------------------
# check_cost_distribution
# ------------------------------------------------------------------------------

test_that("check_cost_distribution handles all infinite values", {
  cost <- matrix(Inf, 3, 3)
  expect_error(couplr:::check_cost_distribution(cost, warn = TRUE), "No valid pairs")

  result <- couplr:::check_cost_distribution(cost, warn = FALSE)
  expect_false(result$valid)
})

test_that("check_cost_distribution warns on many zeros", {
  cost <- matrix(c(0, 0, 0, 0, 0, 1, 2, 3, 4), 3, 3)
  expect_warning(result <- couplr:::check_cost_distribution(cost, warn = TRUE), "zero")
})

test_that("check_cost_distribution warns on constant distances", {
  cost <- matrix(1, 3, 3)
  expect_warning(result <- couplr:::check_cost_distribution(cost, warn = TRUE), "identical")
})

test_that("check_cost_distribution warns on extreme costs", {
  set.seed(123)
  # Create distribution with 99th percentile >> 95th percentile (needs > 10x ratio)
  # 95 values at 1, 5 values at 200 -> p95 ~ 1, p99 ~ 200, ratio = 200
  cost <- matrix(c(rep(1, 95), rep(200, 5)), nrow = 10)
  expect_warning(result <- couplr:::check_cost_distribution(cost, warn = TRUE), "skewed")
})

test_that("check_cost_distribution warns on many forbidden", {
  cost <- matrix(Inf, 10, 10)
  cost[1, 1:3] <- 1:3  # Only 30 valid pairs
  expect_warning(result <- couplr:::check_cost_distribution(cost, warn = TRUE), "forbidden")
})

# ------------------------------------------------------------------------------
# diagnose_distance_matrix
# ------------------------------------------------------------------------------

test_that("diagnose_distance_matrix runs without data", {
  cost <- matrix(runif(9), 3, 3)
  result <- diagnose_distance_matrix(cost, warn = FALSE)
  expect_type(result, "list")
  expect_true("distribution" %in% names(result))
  expect_true("quality" %in% names(result))
})

test_that("diagnose_distance_matrix detects constant variables", {
  cost <- matrix(runif(9), 3, 3)
  left <- data.frame(x = c(1, 1, 1), y = 1:3)
  right <- data.frame(x = c(2, 2, 2), y = 4:6)

  expect_warning(
    result <- diagnose_distance_matrix(cost, left, right, vars = c("x", "y"), warn = TRUE),
    "constant"
  )
  expect_true("x" %in% result$problem_variables)
})

test_that("diagnose_distance_matrix detects scale differences", {
  cost <- matrix(runif(9), 3, 3)
  left <- data.frame(x = c(1, 2, 3))  # range = 2
  right <- data.frame(x = c(1, 100, 1000))  # range = 999

  result <- diagnose_distance_matrix(cost, left, right, vars = "x", warn = FALSE)
  expect_true(length(result$variable_issues) > 0)
})

test_that("diagnose_distance_matrix generates suggestions", {
  # Matrix with many forbidden pairs
  cost <- matrix(Inf, 10, 10)
  cost[1:2, 1:2] <- runif(4)

  result <- diagnose_distance_matrix(cost, warn = FALSE)
  expect_true(length(result$suggestions) > 0)
})

test_that("diagnose_distance_matrix assesses quality", {
  # Good quality
  cost <- matrix(runif(100), 10, 10)
  result <- diagnose_distance_matrix(cost, warn = FALSE)
  expect_equal(result$quality, "good")

  # Fair quality (many forbidden)
  cost <- matrix(Inf, 10, 10)
  cost[1:5, 1:5] <- runif(25)
  result <- diagnose_distance_matrix(cost, warn = FALSE)
  expect_true(result$quality %in% c("fair", "poor"))
})