tests/testthat/test-cpp-solvers-coverage.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests to increase C++ solver coverage
# ==============================================================================

# ------------------------------------------------------------------------------
# Gabow-Tarjan solver tests
# ------------------------------------------------------------------------------

test_that("gabow_tarjan solver works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "gabow_tarjan")

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

test_that("gabow_tarjan solver handles rectangular matrices", {
  cost <- matrix(runif(12), 3, 4)
  result <- assignment(cost, method = "gabow_tarjan")

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

test_that("gabow_tarjan solver handles maximize", {
  cost <- matrix(c(1, 10, 10, 1), 2, 2)
  result <- assignment(cost, method = "gabow_tarjan", maximize = TRUE)

  expect_equal(result$status, "optimal")
  expect_true(result$total_cost >= 10)
})

test_that("gabow_tarjan handles sparse matrix with NA", {
  cost <- matrix(c(1, NA, 3, NA, 5, NA, NA, 8, 9), 3, 3)
  result <- assignment(cost, method = "gabow_tarjan")

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

# ------------------------------------------------------------------------------
# Network Simplex solver tests
# ------------------------------------------------------------------------------

test_that("network_simplex solver works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "network_simplex")

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

test_that("network_simplex handles rectangular matrices", {
  cost <- matrix(runif(15), 3, 5)
  result <- assignment(cost, method = "network_simplex")

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

test_that("network_simplex handles larger matrices", {
  set.seed(123)
  cost <- matrix(runif(100), 10, 10)
  result <- assignment(cost, method = "network_simplex")

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

test_that("network_simplex with some forbidden entries", {
  cost <- matrix(c(1, NA, 3, 4, NA, 6, 7, 8, NA), 3, 3)
  result <- assignment(cost, method = "network_simplex")

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

# ------------------------------------------------------------------------------
# Cycle Canceling solver tests
# ------------------------------------------------------------------------------

test_that("cycle_cancel solver works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "cycle_cancel")

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

test_that("cycle_cancel handles maximize", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- assignment(cost, method = "cycle_cancel", maximize = TRUE)

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

test_that("cycle_cancel handles rectangular matrices", {
  cost <- matrix(runif(20), 4, 5)
  result <- assignment(cost, method = "cycle_cancel")

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

test_that("cycle_cancel with sparse matrix", {
  cost <- matrix(c(1, NA, NA, 4, 5, NA, 7, NA, 9), 3, 3)
  result <- assignment(cost, method = "cycle_cancel")

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

# ------------------------------------------------------------------------------
# Orlin-Ahuja (csa) solver tests
# ------------------------------------------------------------------------------

test_that("csa solver works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "csa")

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

test_that("csa solver handles maximize", {
  cost <- matrix(c(1, 10, 10, 1), 2, 2)
  result <- assignment(cost, method = "csa", maximize = TRUE)

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

test_that("csa handles larger matrices efficiently", {
  set.seed(456)
  cost <- matrix(runif(400), 20, 20)
  result <- assignment(cost, method = "csa")

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

test_that("csa handles rectangular matrices", {
  cost <- matrix(runif(24), 4, 6)
  result <- assignment(cost, method = "csa")

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

# ------------------------------------------------------------------------------
# Push-Relabel solver tests
# ------------------------------------------------------------------------------

test_that("push_relabel solver works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "push_relabel")

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

test_that("push_relabel handles maximize", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- assignment(cost, method = "push_relabel", maximize = TRUE)

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

test_that("push_relabel handles rectangular matrices", {
  cost <- matrix(runif(18), 3, 6)
  result <- assignment(cost, method = "push_relabel")

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

# ------------------------------------------------------------------------------
# Ramshaw-Tarjan solver tests
# ------------------------------------------------------------------------------

test_that("ramshaw_tarjan solver works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "ramshaw_tarjan")

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

test_that("ramshaw_tarjan handles rectangular matrices", {
  cost <- matrix(runif(15), 3, 5)
  result <- assignment(cost, method = "ramshaw_tarjan")

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

test_that("ramshaw_tarjan handles highly rectangular matrices", {
  cost <- matrix(runif(20), 2, 10)
  result <- assignment(cost, method = "ramshaw_tarjan")

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

# ------------------------------------------------------------------------------
# SSP and SAP solver tests
# ------------------------------------------------------------------------------

test_that("ssp solver works", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "ssp")

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

test_that("sap solver works", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "sap")

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

test_that("ssp handles rectangular", {
  cost <- matrix(runif(12), 3, 4)
  result <- assignment(cost, method = "ssp")

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

# ------------------------------------------------------------------------------
# SSAP Bucket solver tests
# ------------------------------------------------------------------------------

test_that("ssap_bucket solver works", {
  # Integer costs work best for bucket-based algorithm
  cost <- matrix(as.integer(c(1, 2, 3, 4, 5, 6, 7, 8, 9)), 3, 3)
  result <- assignment(cost, method = "ssap_bucket")

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

test_that("ssap_bucket handles larger matrices", {
  set.seed(789)
  cost <- matrix(sample(1:100, 64, replace = TRUE), 8, 8)
  result <- assignment(cost, method = "ssap_bucket")

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

# ------------------------------------------------------------------------------
# CSFlow solver tests
# ------------------------------------------------------------------------------

test_that("csflow solver works", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)
  result <- assignment(cost, method = "csflow")

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

test_that("csflow handles maximize", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  result <- assignment(cost, method = "csflow", maximize = TRUE)

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

# ------------------------------------------------------------------------------
# HK01 solver tests
# ------------------------------------------------------------------------------

test_that("hk01 solver works on binary costs", {
  cost <- matrix(c(0, 1, 1, 0, 1, 1, 0, 1, 1), 3, 3)
  result <- assignment(cost, method = "hk01")

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

test_that("hk01 handles larger binary matrices", {
  set.seed(111)
  cost <- matrix(sample(0:1, 100, replace = TRUE), 10, 10)
  result <- assignment(cost, method = "hk01")

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

# ------------------------------------------------------------------------------
# Lapmod solver tests (sparse matrices)
# ------------------------------------------------------------------------------

test_that("lapmod solver works on sparse matrices", {
  # Create sparse matrix (>50% NA)
  cost <- matrix(NA, 5, 5)
  cost[1, 1] <- 1
  cost[1, 2] <- 2
  cost[2, 2] <- 1
  cost[2, 3] <- 3
  cost[3, 3] <- 1
  cost[3, 4] <- 2
  cost[4, 4] <- 1
  cost[4, 5] <- 3
  cost[5, 5] <- 1

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

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

test_that("lapmod handles medium-sized sparse matrices", {
  set.seed(222)
  n <- 15
  cost <- matrix(NA, n, n)
  # Fill about 30% of entries
  for (i in 1:n) {
    idx <- sample(1:n, 4)
    cost[i, idx] <- runif(4, 1, 10)
  }

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

  expect_true(result$status %in% c("optimal", "infeasible"))
})

# ------------------------------------------------------------------------------
# Bottleneck assignment tests
# ------------------------------------------------------------------------------

test_that("bottleneck_assignment works", {
  cost <- matrix(c(1, 5, 3, 2, 4, 6, 7, 1, 2), 3, 3)
  result <- bottleneck_assignment(cost)

  expect_s3_class(result, "bottleneck_result")
  expect_true(result$bottleneck >= 0)
})

test_that("bottleneck_assignment maximize works", {
  cost <- matrix(c(1, 5, 3, 2, 4, 6, 7, 1, 2), 3, 3)
  result <- bottleneck_assignment(cost, maximize = TRUE)

  expect_s3_class(result, "bottleneck_result")
})

test_that("bottleneck_assignment on larger matrices", {
  set.seed(333)
  cost <- matrix(runif(64), 8, 8)
  result <- bottleneck_assignment(cost)

  expect_s3_class(result, "bottleneck_result")
})

# ------------------------------------------------------------------------------
# Line metric solver tests
# ------------------------------------------------------------------------------

test_that("lap_solve_line_metric with L1 cost works", {
  x <- c(1, 3, 5, 7)
  y <- c(2, 4, 6, 8)

  result <- lap_solve_line_metric(x, y, cost = "L1")

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

test_that("lap_solve_line_metric with L2 cost works", {
  x <- c(1, 3, 5)
  y <- c(2, 4, 6, 8)

  result <- lap_solve_line_metric(x, y, cost = "L2")

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

test_that("lap_solve_line_metric handles unsorted inputs", {
  x <- c(5, 1, 3)
  y <- c(6, 2, 4, 8)

  result <- lap_solve_line_metric(x, y)

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

# ------------------------------------------------------------------------------
# Sinkhorn solver tests
# ------------------------------------------------------------------------------

test_that("sinkhorn works on small matrices", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)
  result <- sinkhorn(cost, lambda = 1)

  expect_true(is.matrix(result$transport_plan))
  expect_true(all(result$transport_plan >= 0))
})

test_that("sinkhorn with different lambda values", {
  cost <- matrix(runif(9), 3, 3)

  result1 <- sinkhorn(cost, lambda = 0.1)
  result2 <- sinkhorn(cost, lambda = 10)

  expect_true(all(result1$transport_plan >= 0))
  expect_true(all(result2$transport_plan >= 0))
})

test_that("sinkhorn_to_assignment works", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)
  sink_result <- sinkhorn(cost, lambda = 10)

  assignment <- sinkhorn_to_assignment(sink_result)

  expect_equal(length(assignment), 2)
})

# ------------------------------------------------------------------------------
# K-best solutions tests
# ------------------------------------------------------------------------------

test_that("lap_solve_kbest returns multiple solutions", {
  cost <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), 3, 3)

  result <- lap_solve_kbest(cost, k = 3)

  expect_s3_class(result, "lap_solve_kbest_result")
  expect_true(nrow(result) >= 1)
})

test_that("lap_solve_kbest with murty method", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result_murty <- lap_solve_kbest(cost, k = 2, method = "murty")

  expect_s3_class(result_murty, "lap_solve_kbest_result")
})

# ------------------------------------------------------------------------------
# Edge cases that test error paths
# ------------------------------------------------------------------------------

test_that("solvers handle 1x1 matrices", {
  cost <- matrix(5, 1, 1)

  for (method in c("hungarian", "jv", "auction", "ssp", "csflow")) {
    result <- assignment(cost, method = method)
    expect_equal(result$total_cost, 5)
  }
})

test_that("solvers handle 2x2 identity cost", {
  cost <- matrix(c(0, 1, 1, 0), 2, 2)

  for (method in c("hungarian", "jv", "gabow_tarjan", "csa")) {
    result <- assignment(cost, method = method)
    expect_equal(result$total_cost, 0)
  }
})

test_that("solvers agree on random matrices", {
  set.seed(444)
  cost <- matrix(runif(25), 5, 5)

  methods <- c("hungarian", "jv", "csa", "network_simplex")
  results <- lapply(methods, function(m) assignment(cost, method = m))

  costs <- sapply(results, function(r) r$total_cost)
  # All methods should find the same optimal cost
  expect_true(max(costs) - min(costs) < 1e-6)
})