tests/testthat/test-cycle-cancel-coverage-2.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# More tests for cycle_cancel solver coverage - triggering cycle cancellation
# ==============================================================================

test_that("cycle_cancel handles transposed matrix (more rows than cols)", {
  # 5x3 matrix - more rows than columns triggers transpose
  cost <- matrix(runif(15), 5, 3)
  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(length(result$match), 5)
  expect_equal(result$status, "optimal")
  # Only 3 rows can be matched to 3 columns
  expect_equal(sum(result$match > 0), 3)
})

test_that("cycle_cancel handles large rectangular matrix", {
  cost <- matrix(runif(40), 8, 5)
  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(length(result$match), 8)
})

test_that("cycle_cancel handles matrix with negative costs", {
  cost <- matrix(c(-5, -1, -2, -10, -3, -8, -4, -6, -7), 3, 3)
  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(result$status, "optimal")
})

test_that("cycle_cancel handles maximize = TRUE", {
  cost <- matrix(c(1, 100, 100, 1, 50, 50, 50, 50, 25), 3, 3)

  result_min <- assignment(cost, method = "cycle_cancel", maximize = FALSE)
  result_max <- assignment(cost, method = "cycle_cancel", maximize = TRUE)

  expect_true(result_max$total_cost >= result_min$total_cost)
})

test_that("cycle_cancel handles matrix with many forbidden edges", {
  cost <- matrix(Inf, 4, 4)
  # Create a sparse pattern
  cost[1, 1] <- 1
  cost[2, 2] <- 2
  cost[3, 3] <- 3
  cost[4, 4] <- 4
  cost[1, 2] <- 5
  cost[2, 1] <- 5

  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(result$status, "optimal")
})

test_that("cycle_cancel handles 6x6 matrix", {
  set.seed(42)
  cost <- matrix(runif(36), 6, 6)
  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(length(result$match), 6)
  expect_equal(result$status, "optimal")
})

test_that("cycle_cancel handles cost matrix that might trigger cycles", {
  # A matrix where initial SSP solution might have negative cycles
  cost <- matrix(c(
    1, 9, 2, 8,
    8, 2, 9, 1,
    3, 7, 4, 6,
    6, 4, 7, 3
  ), 4, 4, byrow = TRUE)

  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(result$status, "optimal")
  expect_equal(length(result$match), 4)
})

test_that("cycle_cancel handles matrix with uniform costs except diagonal", {
  # This pattern can create interesting cycle structures
  cost <- matrix(10, 4, 4)
  diag(cost) <- 1

  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(result$status, "optimal")
  expect_equal(result$total_cost, 4)  # 4 * 1 = 4
})

test_that("cycle_cancel handles 2x5 rectangular (more cols)", {
  cost <- matrix(1:10, 2, 5)
  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(length(result$match), 2)
  expect_equal(sum(result$match > 0), 2)
})

test_that("cycle_cancel handles matrix with zero costs", {
  cost <- matrix(0, 3, 3)
  cost[1, 2] <- 1
  cost[2, 3] <- 1
  cost[3, 1] <- 1

  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(result$status, "optimal")
})

test_that("cycle_cancel correctly matches jv on various sizes", {
  set.seed(123)
  for (n in c(3, 5, 7, 10)) {
    cost <- matrix(runif(n * n), n, n)

    result_cc <- assignment(cost, method = "cycle_cancel")
    result_jv <- assignment(cost, method = "jv")

    expect_equal(result_cc$total_cost, result_jv$total_cost,
                 tolerance = 1e-9, info = sprintf("n=%d", n))
  }
})

test_that("cycle_cancel handles single element sparse pattern", {
  # Only one valid assignment per row/col
  cost <- matrix(Inf, 3, 3)
  cost[1, 2] <- 5
  cost[2, 3] <- 3
  cost[3, 1] <- 7

  result <- assignment(cost, method = "cycle_cancel")

  expect_equal(result$status, "optimal")
  expect_equal(result$total_cost, 15)  # 5 + 3 + 7
})