tests/testthat/test-utils-extended-2.R

In couplr: Optimal Pairing and Matching via Linear Assignment

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

# ------------------------------------------------------------------------------
# validate_cost_data
# ------------------------------------------------------------------------------

test_that("validate_cost_data errors on data frame", {
  df <- data.frame(x = 1:3, y = 1:3)
  expect_error(couplr:::validate_cost_data(df), "Data frame")
})

test_that("validate_cost_data errors on empty matrix", {
  m <- matrix(nrow = 0, ncol = 0)
  expect_error(couplr:::validate_cost_data(m), "at least one row")
})

test_that("validate_cost_data errors on non-numeric", {
  m <- matrix(letters[1:4], 2, 2)
  expect_error(couplr:::validate_cost_data(m), "numeric")
})

test_that("validate_cost_data errors on NaN", {
  m <- matrix(c(1, NaN, 3, 4), 2, 2)
  expect_error(couplr:::validate_cost_data(m), "NaN")
})

test_that("validate_cost_data returns matrix", {
  m <- matrix(1:4, 2, 2)
  result <- couplr:::validate_cost_data(m)
  expect_true(is.matrix(result))
})

# ------------------------------------------------------------------------------
# Type checking functions
# ------------------------------------------------------------------------------

test_that("is_lap_solve_result works", {
  expect_false(is_lap_solve_result(data.frame()))

  # Create proper result
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve(cost)
  expect_true(is_lap_solve_result(result))
})

test_that("is_lap_solve_batch_result works", {
  expect_false(is_lap_solve_batch_result(data.frame()))

  costs <- list(matrix(c(1, 2, 3, 4), 2, 2))
  result <- lap_solve_batch(costs)
  expect_true(is_lap_solve_batch_result(result))
})

test_that("is_lap_solve_kbest_result works", {
  expect_false(is_lap_solve_kbest_result(data.frame()))

  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve_kbest(cost, k = 2)
  expect_true(is_lap_solve_kbest_result(result))
})

# ------------------------------------------------------------------------------
# get_total_cost
# ------------------------------------------------------------------------------

test_that("get_total_cost works for lap_solve_result", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve(cost)
  tc <- get_total_cost(result)
  expect_true(is.numeric(tc))
})

test_that("get_total_cost works for batch result", {
  costs <- list(matrix(c(1, 5, 5, 1), 2, 2), matrix(c(2, 4, 4, 2), 2, 2))
  result <- lap_solve_batch(costs)
  tc <- get_total_cost(result)
  expect_true(is.numeric(tc))
  expect_length(tc, 2)
})

test_that("get_total_cost works for kbest result", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve_kbest(cost, k = 2)
  tc <- get_total_cost(result)
  expect_true(is.numeric(tc))
})

test_that("get_total_cost errors on invalid object", {
  expect_error(get_total_cost(data.frame()), "not a valid")
})

test_that("get_total_cost errors when attr missing", {
  result <- tibble::tibble(source = 1, target = 1, cost = 1)
  class(result) <- c("lap_solve_result", class(result))
  expect_error(get_total_cost(result), "not found")
})

# ------------------------------------------------------------------------------
# get_method_used
# ------------------------------------------------------------------------------

test_that("get_method_used works for lap_solve_result", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve(cost)
  m <- get_method_used(result)
  expect_true(is.character(m))
})

test_that("get_method_used works for batch result", {
  costs <- list(matrix(c(1, 5, 5, 1), 2, 2))
  result <- lap_solve_batch(costs)
  m <- get_method_used(result)
  expect_true(is.character(m))
})

test_that("get_method_used errors on invalid object", {
  expect_error(get_method_used(data.frame()), "not a valid")
})

test_that("get_method_used errors when attr missing", {
  result <- tibble::tibble(source = 1, target = 1, cost = 1)
  class(result) <- c("lap_solve_result", class(result))
  expect_error(get_method_used(result), "not found")
})

# ------------------------------------------------------------------------------
# as_assignment_matrix
# ------------------------------------------------------------------------------

test_that("as_assignment_matrix creates binary matrix", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve(cost)
  mat <- as_assignment_matrix(result)
  expect_true(is.matrix(mat))
  expect_true(all(mat %in% c(0L, 1L)))
})

test_that("as_assignment_matrix with explicit dimensions", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve(cost)
  mat <- as_assignment_matrix(result, n_sources = 3, n_targets = 3)
  expect_equal(dim(mat), c(3, 3))
})

test_that("as_assignment_matrix handles empty result", {
  result <- tibble::tibble(
    source = integer(0),
    target = integer(0),
    cost = numeric(0)
  )
  class(result) <- c("lap_solve_result", class(result))
  attr(result, "total_cost") <- 0

  mat <- as_assignment_matrix(result, n_sources = 2, n_targets = 2)
  expect_equal(dim(mat), c(2, 2))
  expect_true(all(mat == 0L))
})

test_that("as_assignment_matrix errors on non-result", {
  expect_error(as_assignment_matrix(data.frame()), "must be a lap_solve_result")
})

test_that("as_assignment_matrix errors on missing columns", {
  result <- tibble::tibble(x = 1, y = 2)
  class(result) <- c("lap_solve_result", class(result))
  expect_error(as_assignment_matrix(result), "source.*target")
})

test_that("as_assignment_matrix errors on negative dimensions", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- lap_solve(cost)
  expect_error(as_assignment_matrix(result, n_sources = -1), "non-negative")
})