tests/testthat/test-assignment-bottleneck.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# test-assignment-bottleneck.R
# Tests for Bottleneck Assignment Problem (BAP) solver

# ==============================================================================
# Basic Functionality
# ==============================================================================

test_that("bottleneck_assignment returns correct structure", {
  cost <- matrix(c(1, 2, 3, 4), nrow = 2)
  result <- bottleneck_assignment(cost)

  expect_type(result, "list")
  expect_s3_class(result, "bottleneck_result")
  expect_true("match" %in% names(result))
  expect_true("bottleneck" %in% names(result))
  expect_true("status" %in% names(result))
  expect_equal(result$status, "optimal")
})

test_that("bottleneck_assignment minimizes maximum edge cost", {
  # Cost matrix where optimal LAP and optimal BAP differ
  # LAP sum-optimal: 1->1 (1) + 2->2 (5) = 6, max = 5

  # BAP optimal: 1->2 (3) + 2->1 (2) = 5, max = 3
  cost <- matrix(c(1, 3,
                   2, 5), nrow = 2, byrow = TRUE)

  result <- bottleneck_assignment(cost)

  # Bottleneck should be 3 (the minimax)
  expect_equal(result$bottleneck, 3)

  # Verify the assignment achieves this bottleneck
  edges <- sapply(seq_along(result$match), function(i) cost[i, result$match[i]])
  expect_equal(max(edges), result$bottleneck)
})

test_that("bottleneck_assignment handles single element", {
  cost <- matrix(7, nrow = 1, ncol = 1)
  result <- bottleneck_assignment(cost)

  expect_equal(result$match, 1L)
  expect_equal(result$bottleneck, 7)
})

test_that("bottleneck_assignment handles 1x1 matrix", {
  cost <- matrix(42.5, nrow = 1, ncol = 1)
  result <- bottleneck_assignment(cost)

  expect_equal(result$match, 1L)
  expect_equal(result$bottleneck, 42.5)
})

# ==============================================================================
# Rectangular Matrices
# ==============================================================================

test_that("bottleneck_assignment handles rectangular matrix (more cols)", {
  # 2x4 matrix
  cost <- matrix(c(5, 2, 8, 1,
                   3, 6, 1, 4), nrow = 2, byrow = TRUE)

  result <- bottleneck_assignment(cost)

  expect_length(result$match, 2)
  expect_true(all(result$match >= 1 & result$match <= 4))
  expect_true(length(unique(result$match)) == 2)  # No duplicates

  # Verify bottleneck
  edges <- sapply(1:2, function(i) cost[i, result$match[i]])
  expect_equal(max(edges), result$bottleneck)
})

test_that("bottleneck_assignment rejects more rows than cols",
{
  cost <- matrix(1:6, nrow = 3, ncol = 2)
  expect_error(bottleneck_assignment(cost), "nrow <= ncol")
})

# ==============================================================================
# NA and Inf Handling
# ==============================================================================

test_that("bottleneck_assignment handles NA (forbidden edges)", {
  cost <- matrix(c(1, NA, 3,
                   2, 4, NA,
                   NA, 1, 2), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)

  # Should find valid assignment avoiding NA

  expect_length(result$match, 3)
  expect_true(all(result$match >= 1 & result$match <= 3))

  # Verify no NA edges selected
  for (i in 1:3) {
    expect_false(is.na(cost[i, result$match[i]]))
  }
})

test_that("bottleneck_assignment handles Inf (forbidden edges)", {
  cost <- matrix(c(1, Inf, 3,
                   2, 4, Inf,
                   Inf, 1, 2), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)

  # Verify no Inf edges selected
  for (i in 1:3) {
    expect_true(is.finite(cost[i, result$match[i]]))
  }
})

test_that("bottleneck_assignment fails on infeasible (all NA)", {
  cost <- matrix(NA_real_, nrow = 2, ncol = 2)
  expect_error(bottleneck_assignment(cost), "Infeasible|no finite")
})

test_that("bottleneck_assignment fails on infeasible (no perfect matching)", {
  # Only one finite entry per row, but they conflict
  cost <- matrix(c(1, Inf,
                   2, Inf), nrow = 2, byrow = TRUE)
  expect_error(bottleneck_assignment(cost), "Infeasible|no perfect matching")
})

test_that("bottleneck_assignment rejects NaN", {
  cost <- matrix(c(1, NaN, 3, 4), nrow = 2)
  expect_error(bottleneck_assignment(cost), "NaN")
})

# ==============================================================================
# Maximize Mode (Maximin)
# ==============================================================================

test_that("bottleneck_assignment maximize mode works", {
  # Maximize minimum profit
  profit <- matrix(c(10, 5, 3,
                     2, 8, 6,
                     4, 1, 9), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(profit, maximize = TRUE)

  # Verify bottleneck is minimum among selected edges
  edges <- sapply(1:3, function(i) profit[i, result$match[i]])
  expect_equal(min(edges), result$bottleneck)
})

test_that("maximize gives different result than minimize", {
  cost <- matrix(c(1, 10,
                   10, 1), nrow = 2, byrow = TRUE)

  result_min <- bottleneck_assignment(cost, maximize = FALSE)
  result_max <- bottleneck_assignment(cost, maximize = TRUE)

  # Both should have valid matchings
  expect_length(result_min$match, 2)
  expect_length(result_max$match, 2)

  # Min should achieve bottleneck of 1 (diagonal assignment)
  expect_equal(result_min$bottleneck, 1)

  # Max should achieve bottleneck of 10 (anti-diagonal assignment)
  expect_equal(result_max$bottleneck, 10)
})

# ==============================================================================
# Comparison with LAP
# ==============================================================================

test_that("bottleneck differs from LAP sum-optimal", {
  # Classic example where BAP and LAP optima differ
  cost <- matrix(c(1, 100,
                   2, 3), nrow = 2, byrow = TRUE)

  bap <- bottleneck_assignment(cost)
  lap <- assignment(cost)

  # LAP optimal: 1->1 (1) + 2->2 (3) = 4, max = 3
  # BAP optimal: 1->1 (1) + 2->2 (3), max = 3
  # Actually same here, let's try another

  cost2 <- matrix(c(10, 1,
                    1, 10), nrow = 2, byrow = TRUE)

  bap2 <- bottleneck_assignment(cost2)
  lap2 <- assignment(cost2)

  # LAP: 1->2 (1) + 2->1 (1) = 2
  # BAP: same assignment, bottleneck = 1
  expect_equal(bap2$bottleneck, 1)
})

# ==============================================================================
# Edge Cases
# ==============================================================================

test_that("bottleneck_assignment handles all equal costs", {
  cost <- matrix(5, nrow = 3, ncol = 3)
  result <- bottleneck_assignment(cost)

  expect_equal(result$bottleneck, 5)
  expect_length(result$match, 3)
  expect_equal(length(unique(result$match)), 3)  # Valid permutation
})

test_that("bottleneck_assignment handles negative costs", {
  cost <- matrix(c(-5, -2, -3,
                   -1, -4, -6,
                   -7, -8, -9), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)

  # Should minimize max (closest to 0 for negatives)
  edges <- sapply(1:3, function(i) cost[i, result$match[i]])
  expect_equal(max(edges), result$bottleneck)
})

test_that("bottleneck_assignment handles mixed pos/neg costs", {
  cost <- matrix(c(-5, 2, -3,
                   1, -4, 6,
                   -7, 8, -9), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)
  expect_type(result$bottleneck, "double")
})

test_that("bottleneck_assignment handles large integers", {
  cost <- matrix(c(1e9, 1e8, 1e7,
                   1e6, 1e9, 1e5,
                   1e4, 1e3, 1e9), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)
  expect_true(is.finite(result$bottleneck))
})

test_that("bottleneck_assignment handles very small costs", {
  cost <- matrix(c(1e-10, 1e-9, 1e-8,
                   1e-7, 1e-10, 1e-6,
                   1e-5, 1e-4, 1e-10), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)
  expect_true(result$bottleneck >= 1e-10)
})

# ==============================================================================
# Larger Problems
# ==============================================================================

test_that("bottleneck_assignment handles medium-size problems", {
  set.seed(42)
  n <- 20
  cost <- matrix(runif(n * n, 0, 100), nrow = n)

  result <- bottleneck_assignment(cost)

  expect_length(result$match, n)
  expect_equal(length(unique(result$match)), n)
  expect_true(all(result$match >= 1 & result$match <= n))

  # Verify bottleneck
  edges <- sapply(1:n, function(i) cost[i, result$match[i]])
  expect_equal(max(edges), result$bottleneck)
})

test_that("bottleneck_assignment scales to larger problems", {
  skip_on_cran()

  set.seed(123)
  n <- 50
  cost <- matrix(sample(1:1000, n * n, replace = TRUE), nrow = n)

  result <- bottleneck_assignment(cost)

  expect_length(result$match, n)
  expect_equal(result$status, "optimal")

  # Verify optimality: bottleneck should equal max edge in matching
  edges <- sapply(1:n, function(i) cost[i, result$match[i]])
  expect_equal(max(edges), result$bottleneck)
})

# ==============================================================================
# Correctness Verification
# ==============================================================================

test_that("bottleneck optimality verified by exhaustive check (small)", {
  skip_if_not_installed("combinat")

  # For small n, verify by checking all permutations
  cost <- matrix(c(3, 1, 4,
                   1, 5, 9,
                   2, 6, 5), nrow = 3, byrow = TRUE)

  result <- bottleneck_assignment(cost)

  # Generate all permutations and find true minimum bottleneck
  perms <- combinat::permn(3)
  min_bottleneck <- Inf
  for (perm in perms) {
    edges <- sapply(1:3, function(i) cost[i, perm[i]])
    bn <- max(edges)
    if (bn < min_bottleneck) min_bottleneck <- bn
  }

  expect_equal(result$bottleneck, min_bottleneck)
})

test_that("bottleneck matches brute force on random small problems", {
  skip_if_not_installed("combinat")

  set.seed(999)
  for (trial in 1:5) {
    n <- 4
    cost <- matrix(sample(1:20, n * n, replace = TRUE), nrow = n)

    result <- bottleneck_assignment(cost)

    # Brute force
    perms <- combinat::permn(n)
    min_bn <- Inf
    for (perm in perms) {
      edges <- sapply(1:n, function(i) cost[i, perm[i]])
      bn <- max(edges)
      if (bn < min_bn) min_bn <- bn
    }

    expect_equal(result$bottleneck, min_bn,
                 info = paste("Trial", trial, "failed"))
  }
})

# ==============================================================================
# Print Method
# ==============================================================================

test_that("print.bottleneck_result works", {
  cost <- matrix(c(1, 2, 3, 4), nrow = 2)
  result <- bottleneck_assignment(cost)

  # Capture output
  output <- capture.output(print(result))

  expect_true(any(grepl("Bottleneck Assignment", output)))
  expect_true(any(grepl("Bottleneck value:", output)))
  expect_true(any(grepl("Status:", output)))
})

# ==============================================================================
# Input Validation
# ==============================================================================

test_that("bottleneck_assignment validates empty matrix", {
  expect_error(bottleneck_assignment(matrix(nrow = 0, ncol = 0)),
               "at least one row")
})

test_that("bottleneck_assignment converts data frame to matrix", {
  df <- data.frame(a = c(1, 2), b = c(3, 4))
  result <- bottleneck_assignment(df)
  expect_s3_class(result, "bottleneck_result")
})