tests/testthat/test-cpp-interface.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests for C++ interface functions (rcpp_interface.cpp exports)
# ==============================================================================

# These tests cover the exported C++ functions that wrap LAP solvers

# ------------------------------------------------------------------------------
# lap_prepare_cost_matrix tests
# ------------------------------------------------------------------------------

test_that("lap_prepare_cost_matrix prepares matrix for minimization", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result <- lap_prepare_cost_matrix(cost, maximize = FALSE)

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

test_that("lap_prepare_cost_matrix prepares matrix for maximization", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result <- lap_prepare_cost_matrix(cost, maximize = TRUE)

  expect_type(result, "list")
})

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

  result <- lap_prepare_cost_matrix(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_jv tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_jv(cost, maximize = FALSE)

  expect_type(result, "list")
  expect_true("assignment" %in% names(result) ||
              "match" %in% names(result) ||
              "perm" %in% names(result))
})

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

  result <- lap_solve_jv(cost, maximize = TRUE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_auction tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_auction(cost, maximize = FALSE)

  expect_type(result, "list")
})

test_that("lap_solve_auction accepts custom epsilon", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- lap_solve_auction(cost, maximize = FALSE, eps = 0.01)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_auction_scaled tests
# ------------------------------------------------------------------------------

test_that("lap_solve_auction_scaled with alpha7 schedule", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- lap_solve_auction_scaled(cost, maximize = FALSE, schedule = "alpha7")

  expect_type(result, "list")
})

test_that("lap_solve_auction_scaled with pow2 schedule", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- lap_solve_auction_scaled(cost, maximize = FALSE, schedule = "pow2")

  expect_type(result, "list")
})

test_that("lap_solve_auction_scaled with halves schedule", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- lap_solve_auction_scaled(cost, maximize = FALSE, schedule = "halves")

  expect_type(result, "list")
})

test_that("lap_solve_auction_scaled errors on invalid schedule", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  expect_error(
    lap_solve_auction_scaled(cost, maximize = FALSE, schedule = "invalid"),
    "Invalid schedule"
  )
})

# ------------------------------------------------------------------------------
# lap_solve_auction_gauss_seidel tests
# ------------------------------------------------------------------------------

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

  # This uses the assignment wrapper with auction_gs method
  result <- assignment(cost, method = "auction_gs")

  expect_s3_class(result, "lap_solve_result")
})

# ------------------------------------------------------------------------------
# lap_solve_ssp tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_ssp(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_hungarian tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_hungarian(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_csflow tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_csflow(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_hk01 tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_hk01(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_ssap_bucket tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_ssap_bucket(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_cycle_cancel tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_cycle_cancel(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_gabow_tarjan tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_gabow_tarjan(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_lapmod tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_lapmod(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_bottleneck tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_bottleneck(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_csa tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_csa(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_ramshaw_tarjan tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_ramshaw_tarjan(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_push_relabel tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_push_relabel(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_jv_duals tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_jv_duals(cost, maximize = FALSE)

  expect_type(result, "list")
  expect_true("u" %in% names(result) || "assignment" %in% names(result))
})

# ------------------------------------------------------------------------------
# lap_kbest_murty tests
# ------------------------------------------------------------------------------

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

  result <- lap_kbest_murty(cost, k = 2, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_sinkhorn tests
# ------------------------------------------------------------------------------

test_that("lap_solve_sinkhorn computes transport plan", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result <- lap_solve_sinkhorn(cost, lambda = 1.0, tol = 1e-6, max_iter = 1000)

  expect_type(result, "list")
})

test_that("lap_solve_sinkhorn with custom weights", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)
  r_weights <- c(0.5, 0.5)
  c_weights <- c(0.5, 0.5)

  result <- lap_solve_sinkhorn(cost, lambda = 1.0, tol = 1e-6, max_iter = 1000,
                               r_weights = r_weights, c_weights = c_weights)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# sinkhorn_round tests
# ------------------------------------------------------------------------------

test_that("sinkhorn_round converts transport plan to assignment", {
  # Create a doubly-stochastic-like matrix
  P <- matrix(c(0.6, 0.2, 0.2, 0.4, 0.4, 0.2, 0.0, 0.4, 0.6), 3, 3)

  result <- sinkhorn_round(P)

  expect_type(result, "integer")
  expect_length(result, 3)
})

# ------------------------------------------------------------------------------
# lap_solve_line_metric tests
# ------------------------------------------------------------------------------

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

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

  expect_type(result, "list")
})

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

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

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_network_simplex tests
# ------------------------------------------------------------------------------

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

  result <- lap_solve_network_simplex(cost)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# greedy_matching tests
# ------------------------------------------------------------------------------

test_that("greedy_matching with row_best strategy", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- greedy_matching(cost, maximize = FALSE, strategy = "row_best")

  expect_type(result, "list")
})

test_that("greedy_matching with sorted strategy", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- greedy_matching(cost, maximize = FALSE, strategy = "sorted")

  expect_type(result, "list")
})

test_that("greedy_matching with pq strategy", {
  cost <- matrix(c(1, 5, 5, 1), 2, 2)

  result <- greedy_matching(cost, maximize = FALSE, strategy = "pq")

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# lap_solve_bruteforce tests
# ------------------------------------------------------------------------------

test_that("lap_solve_bruteforce solves small problem", {
  cost <- matrix(c(1, 2, 3, 4), 2, 2)

  result <- lap_solve_bruteforce(cost, maximize = FALSE)

  expect_type(result, "list")
})

# ------------------------------------------------------------------------------
# Consistency across C++ solvers
# ------------------------------------------------------------------------------

test_that("different C++ solvers produce same optimal cost", {
  set.seed(42)
  cost <- matrix(runif(16), 4, 4)

  result_jv <- lap_solve_jv(cost, maximize = FALSE)
  result_hungarian <- lap_solve_hungarian(cost, maximize = FALSE)
  result_ssp <- lap_solve_ssp(cost, maximize = FALSE)

  # Extract total costs
  get_cost <- function(res) {
    if (!is.null(res$total_cost)) return(res$total_cost)
    if (!is.null(res$cost)) return(res$cost)
    return(NA)
  }

  cost_jv <- get_cost(result_jv)
  cost_hun <- get_cost(result_hungarian)
  cost_ssp <- get_cost(result_ssp)

  # If costs are available, they should match
  if (!is.na(cost_jv) && !is.na(cost_hun)) {
    expect_equal(cost_jv, cost_hun, tolerance = 1e-6)
  }
  if (!is.na(cost_jv) && !is.na(cost_ssp)) {
    expect_equal(cost_jv, cost_ssp, tolerance = 1e-6)
  }
})