tests/testthat/test-solvers-additional.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests for additional LAP solvers
# ==============================================================================
# Tests for solvers that need more coverage

# Helper function to create test problems
make_test_cost <- function(n = 5, seed = 123) {
  set.seed(seed)
  matrix(runif(n * n), n, n)
}

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

test_that("gabow_tarjan solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
  expect_equal(result$status, "optimal")
})

test_that("gabow_tarjan handles larger problems", {
  cost <- make_test_cost(10)

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

  expect_equal(length(result$match), 10)
  expect_equal(sort(result$match), 1:10)
})

test_that("gabow_tarjan handles maximization", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- assignment(cost, method = "gabow_tarjan", maximize = TRUE)

  expect_equal(result$total_cost, 10)
})

test_that("gabow_tarjan handles NA entries", {
  cost <- matrix(c(1, NA, NA, 1), 2, 2)

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

  expect_equal(result$total_cost, 2)
})

# ------------------------------------------------------------------------------
# Cycle canceling solver tests
# ------------------------------------------------------------------------------

test_that("cycle_cancel solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("cycle_cancel handles larger problems", {
  cost <- make_test_cost(8)

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

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

test_that("cycle_cancel handles maximization", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_equal(result$total_cost, 10)
})

# ------------------------------------------------------------------------------
# Network simplex solver tests
# ------------------------------------------------------------------------------

test_that("network_simplex solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("network_simplex handles larger problems", {
  cost <- make_test_cost(15)

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

  expect_equal(length(result$match), 15)
  expect_equal(sort(result$match), 1:15)
})

test_that("network_simplex handles rectangular matrix", {
  cost <- matrix(runif(12), 3, 4)

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

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

# ------------------------------------------------------------------------------
# Push-relabel solver tests
# ------------------------------------------------------------------------------

test_that("push_relabel solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("push_relabel handles larger problems", {
  cost <- make_test_cost(12)

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

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

# ------------------------------------------------------------------------------
# Orlin-Ahuja solver tests
# ------------------------------------------------------------------------------

test_that("orlin solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("orlin handles larger problems", {
  cost <- make_test_cost(10)

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

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

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

test_that("ramshaw_tarjan solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("ramshaw_tarjan handles rectangular matrices well", {
  # Ramshaw-Tarjan is optimized for rectangular
  cost <- matrix(runif(20), 4, 5)

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

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

# ------------------------------------------------------------------------------
# LAPMOD solver tests (sparse JV variant)
# ------------------------------------------------------------------------------

test_that("lapmod solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("lapmod handles sparse matrices efficiently", {
  # Create sparse matrix (many Inf entries)
  cost <- matrix(Inf, 10, 10)
  diag(cost) <- runif(10)
  cost[1, 2] <- 0.5
  cost[2, 1] <- 0.5

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

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

# ------------------------------------------------------------------------------
# SSAP bucket solver tests
# ------------------------------------------------------------------------------

test_that("ssap_bucket solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("ssap_bucket handles integer costs", {
  cost <- matrix(c(1L, 5L, 5L, 1L), 2, 2)

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

  expect_equal(result$total_cost, 2)
})

# ------------------------------------------------------------------------------
# CS-Flow solver tests
# ------------------------------------------------------------------------------

test_that("csflow solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("csflow handles larger problems", {
  cost <- make_test_cost(8)

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

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

# ------------------------------------------------------------------------------
# SAP/SSP solver tests
# ------------------------------------------------------------------------------

test_that("sap solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2)
})

test_that("ssp is alias for sap", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_equal(result$total_cost, 2)
})

# ------------------------------------------------------------------------------
# Auction solver variants tests
# ------------------------------------------------------------------------------

test_that("auction solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2, tolerance = 1e-6)
})

test_that("auction_gs solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2, tolerance = 1e-6)
})

test_that("auction_scaled solves basic problem", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 2, tolerance = 1e-6)
})

test_that("auction handles larger problems", {
  cost <- make_test_cost(20)

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

  expect_equal(length(result$match), 20)
  expect_equal(sort(result$match), 1:20)
})

# ------------------------------------------------------------------------------
# HK01 solver tests (binary costs)
# ------------------------------------------------------------------------------

test_that("hk01 solves binary cost problem", {
  cost <- matrix(c(0, 1, 1, 0), 2, 2)

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

  expect_s3_class(result, "lap_solve_result")
  expect_equal(result$total_cost, 0)
})

test_that("hk01 handles all-ones matrix", {
  cost <- matrix(1, 3, 3)

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

  expect_equal(result$total_cost, 3)
})

# ------------------------------------------------------------------------------
# Cross-solver consistency tests
# ------------------------------------------------------------------------------

test_that("all solvers produce same optimal cost", {
  set.seed(999)
  cost <- matrix(runif(16), 4, 4)

  methods <- c("hungarian", "jv", "auction_scaled", "sap", "gabow_tarjan")

  results <- lapply(methods, function(m) {
    assignment(cost, method = m)$total_cost
  })

  # All should be equal (within tolerance)
  for (i in 2:length(results)) {
    expect_equal(results[[1]], results[[i]], tolerance = 1e-6,
                 info = paste("Comparing", methods[1], "vs", methods[i]))
  }
})

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

test_that("line_metric solver works", {
  result <- lap_solve_line_metric(
    x = c(1, 3, 5),
    y = c(2, 4, 6),
    cost = "L1"
  )

  expect_s3_class(result, "lap_line_metric_result")
  expect_equal(length(result$match), 3)
})

test_that("line_metric handles L2 cost", {
  result <- lap_solve_line_metric(
    x = c(1, 3, 5),
    y = c(2, 4, 6),
    cost = "L2"
  )

  expect_s3_class(result, "lap_line_metric_result")
})

# ------------------------------------------------------------------------------
# K-best solver tests (Murty)
# ------------------------------------------------------------------------------

test_that("lap_solve_kbest finds k best solutions", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result <- lap_solve_kbest(cost, k = 2)

  expect_s3_class(result, "data.frame")
  # Should have 2 solutions (2x2 has 2! = 2 possible assignments)
  expect_equal(length(unique(result$solution_id)), 2)
})

test_that("lap_kbest_lawler direct call works", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result <- lap_kbest_lawler(cost, k = 2)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# prepare_cost_matrix tests
# ------------------------------------------------------------------------------

test_that("lap_prepare_cost_matrix works", {
  cost <- matrix(c(1, NA, 3, 4), 2, 2)

  result <- lap_prepare_cost_matrix(cost, FALSE)

  expect_type(result, "list")
  expect_true("cost" %in% names(result))
  expect_true("mask" %in% names(result))
})