tests/testthat/test-constraints-coverage.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Coverage tests for matching_constraints.R
# ==============================================================================

test_that("apply_max_distance returns unchanged for NULL", {
  cost <- matrix(1:4, 2, 2)
  result <- couplr:::apply_max_distance(cost, max_distance = NULL)
  expect_equal(result, cost)
})

test_that("apply_max_distance returns unchanged for Inf", {
  cost <- matrix(1:4, 2, 2)
  result <- couplr:::apply_max_distance(cost, max_distance = Inf)
  expect_equal(result, cost)
})

test_that("apply_max_distance errors on non-numeric", {
  cost <- matrix(1:4, 2, 2)
  expect_error(
    couplr:::apply_max_distance(cost, max_distance = "not_numeric"),
    "single numeric"
  )
})

test_that("apply_max_distance errors on vector", {
  cost <- matrix(1:4, 2, 2)
  expect_error(
    couplr:::apply_max_distance(cost, max_distance = c(1, 2)),
    "single numeric"
  )
})

test_that("apply_max_distance errors on non-positive", {
  cost <- matrix(1:4, 2, 2)
  expect_error(
    couplr:::apply_max_distance(cost, max_distance = 0),
    "positive"
  )
  expect_error(
    couplr:::apply_max_distance(cost, max_distance = -1),
    "positive"
  )
})

test_that("apply_max_distance marks forbidden pairs", {
  # matrix(c(1, 5, 3, 2), 2, 2) fills by column:
  #      [,1] [,2]
  # [1,]    1    3
  # [2,]    5    2
  cost <- matrix(c(1, 5, 3, 2), 2, 2)
  result <- couplr:::apply_max_distance(cost, max_distance = 4)
  # Value 5 at [2,1] exceeds max_distance=4, should be marked BIG_COST
  expect_true(result[2, 1] > 1e10)
  expect_equal(result[1, 1], 1)
  expect_equal(result[1, 2], 3)
  expect_equal(result[2, 2], 2)
})

test_that("apply_calipers returns unchanged for NULL", {
  cost <- matrix(1:4, 2, 2)
  left <- data.frame(x = c(1, 2))
  right <- data.frame(x = c(3, 4))
  result <- couplr:::apply_calipers(cost, left, right, calipers = NULL, vars = "x")
  expect_equal(result, cost)
})

test_that("apply_calipers skips variables not in vars", {
  cost <- matrix(1:4, 2, 2)
  left <- data.frame(x = c(1, 2), y = c(10, 20))
  right <- data.frame(x = c(3, 4), y = c(100, 200))
  # Caliper on y, but y not in vars - should be skipped
  result <- couplr:::apply_calipers(cost, left, right, calipers = list(y = 0.1), vars = "x")
  expect_equal(result, cost)
})

test_that("apply_calipers marks forbidden pairs", {
  cost <- matrix(1, 2, 2)
  left <- data.frame(x = c(1, 10))
  right <- data.frame(x = c(2, 5))
  # Caliper of 3 on x
  result <- couplr:::apply_calipers(cost, left, right, calipers = list(x = 3), vars = "x")
  # |1-2|=1 OK, |1-5|=4 > 3 forbidden
  # |10-2|=8 > 3 forbidden, |10-5|=5 > 3 forbidden
  expect_equal(result[1, 1], 1)  # OK
  expect_true(result[1, 2] > 1e10)  # Forbidden
  expect_true(result[2, 1] > 1e10)  # Forbidden
  expect_true(result[2, 2] > 1e10)  # Forbidden
})

test_that("mark_forbidden_pairs returns unchanged for NULL", {
  cost <- matrix(1:4, 2, 2)
  result <- couplr:::mark_forbidden_pairs(cost, forbidden_indices = NULL)
  expect_equal(result, cost)
})

test_that("mark_forbidden_pairs returns unchanged for empty matrix", {
  cost <- matrix(1:4, 2, 2)
  result <- couplr:::mark_forbidden_pairs(cost, forbidden_indices = matrix(nrow = 0, ncol = 2))
  expect_equal(result, cost)
})

test_that("mark_forbidden_pairs marks specific pairs", {
  cost <- matrix(1:4, 2, 2)
  # Forbid pair (1, 2) and (2, 1)
  forbidden <- matrix(c(1, 2, 2, 1), ncol = 2, byrow = TRUE)
  result <- couplr:::mark_forbidden_pairs(cost, forbidden)
  expect_true(result[1, 2] > 1e10)
  expect_true(result[2, 1] > 1e10)
  expect_equal(result[1, 1], 1)
  expect_equal(result[2, 2], 4)
})

test_that("apply_all_constraints combines all constraints", {
  # matrix(c(1, 5, 3, 2), 2, 2) fills by column:
  #      [,1] [,2]
  # [1,]    1    3
  # [2,]    5    2
  cost <- matrix(c(1, 5, 3, 2), 2, 2)
  left <- data.frame(x = c(1, 10))
  right <- data.frame(x = c(2, 3))

  # max_distance = 4 forbids the 5 at [2,1]
  # caliper on x = 3 forbids pairs where diff > 3
  result <- couplr:::apply_all_constraints(
    cost, left, right, vars = "x",
    max_distance = 4, calipers = list(x = 3)
  )

  # Check that constraints were applied
  expect_true(result[2, 1] > 1e10)  # Was 5, exceeds max_distance AND |10-2|=8 > 3
  expect_true(result[2, 2] > 1e10)  # |10-3|=7 > 3
})

test_that("apply_all_constraints with forbidden pairs", {
  cost <- matrix(1, 2, 2)
  left <- data.frame(x = c(1, 2))
  right <- data.frame(x = c(1, 2))

  forbidden <- matrix(c(1, 1), ncol = 2)
  result <- couplr:::apply_all_constraints(
    cost, left, right, vars = "x",
    forbidden = forbidden
  )

  expect_true(result[1, 1] > 1e10)
  expect_equal(result[1, 2], 1)
  expect_equal(result[2, 1], 1)
  expect_equal(result[2, 2], 1)
})

test_that("has_valid_pairs returns TRUE when valid pairs exist", {
  cost <- matrix(c(1, couplr:::BIG_COST, 3, 4), 2, 2)
  expect_true(couplr:::has_valid_pairs(cost))
})

test_that("has_valid_pairs returns FALSE when no valid pairs", {
  cost <- matrix(couplr:::BIG_COST, 2, 2)
  expect_false(couplr:::has_valid_pairs(cost))
})

test_that("has_valid_pairs handles Inf", {
  cost <- matrix(Inf, 2, 2)
  expect_false(couplr:::has_valid_pairs(cost))
})

test_that("count_valid_pairs counts correctly", {
  cost <- matrix(c(1, couplr:::BIG_COST, Inf, 4), 2, 2)
  expect_equal(couplr:::count_valid_pairs(cost), 2)  # Only 1 and 4 are valid
})

test_that("count_valid_pairs returns 0 for all forbidden", {
  cost <- matrix(couplr:::BIG_COST, 3, 3)
  expect_equal(couplr:::count_valid_pairs(cost), 0)
})

test_that("BIG_COST is accessible", {
  expect_true(couplr:::BIG_COST > 1e10)
  expect_true(is.finite(couplr:::BIG_COST))
})