tests/testthat/test-assignment-ramshaw_tarjan.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# tests/testthat/test-assignment-ramshaw_tarjan.R
# Tests for Ramshaw-Tarjan rectangular assignment solver

test_that("ramshaw_tarjan solves square 3x3 correctly", {
  cost <- matrix(c(4, 2, 5, 3, 3, 6, 7, 5, 4), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 3)
  expect_true(all(res$match >= 1 & res$match <= 3))
  expect_equal(length(unique(res$match)), 3)

  # Verify cost matches JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan solves rectangular 3x5 (n < m)", {
  cost <- matrix(c(
    1, 5, 9, 2, 6,
    3, 7, 1, 4, 8,
    5, 2, 6, 3, 7
  ), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 3)
  expect_true(all(res$match >= 1 & res$match <= 5))
  expect_equal(length(unique(res$match)), 3)  # All different columns

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles wide rectangular 3x10", {
  set.seed(42)
  cost <- matrix(runif(30), nrow = 3, ncol = 10)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 3)
  expect_true(all(res$match >= 1 & res$match <= 10))
  expect_equal(length(unique(res$match)), 3)

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost, tolerance = 1e-9)
})

test_that("ramshaw_tarjan handles tall rectangular (transposed)", {
  # 5 rows, 3 cols - will be auto-transposed
  cost <- matrix(c(
    1, 5, 9,
    3, 7, 1,
    5, 2, 6,
    4, 8, 2,
    6, 3, 5
  ), nrow = 5, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  # Match vector has length nrow, with 0s for unmatched rows
  expect_equal(length(res$match), 5)
  # Only 3 rows can be matched (to 3 columns)
  expect_equal(sum(res$match > 0), 3)

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles NA entries", {
  cost <- matrix(c(
    1, NA, 3, 4,
    5, 6, NA, 8,
    9, 10, 11, 12
  ), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 3)

  # Check no forbidden assignments
  for (i in 1:3) {
    j <- res$match[i]
    expect_true(is.finite(cost[i, j]))
  }

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles Inf entries", {
  cost <- matrix(c(
    1, Inf, 3, 4,
    5, 6, Inf, 8,
    9, 10, 11, 12
  ), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")

  # Check no forbidden assignments
  for (i in seq_along(res$match)) {
    j <- res$match[i]
    if (j > 0) {
      expect_true(is.finite(cost[i, j]))
    }
  }

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles maximization", {
  cost <- matrix(c(4, 2, 5, 3, 3, 6, 7, 5, 4), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan", maximize = TRUE)

  expect_equal(res$status, "optimal")

  # Verify against JV
  res_jv <- assignment(cost, method = "jv", maximize = TRUE)
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles single row", {
  cost <- matrix(c(5, 2, 8, 1), nrow = 1)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(res$match, 4)  # min is at col 4
  expect_equal(res$total_cost, 1)
})

test_that("ramshaw_tarjan handles 1x1", {
  cost <- matrix(42, nrow = 1)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$match, 1)
  expect_equal(res$total_cost, 42)
})

test_that("ramshaw_tarjan handles larger square matrix", {
  set.seed(123)
  n <- 20
  cost <- matrix(runif(n * n, 1, 100), nrow = n)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), n)
  expect_equal(length(unique(res$match)), n)

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost, tolerance = 1e-6)
})

test_that("ramshaw_tarjan handles very rectangular 5x50", {
  set.seed(456)
  cost <- matrix(runif(250), nrow = 5, ncol = 50)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 5)
  expect_equal(length(unique(res$match)), 5)

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost, tolerance = 1e-9)
})

test_that("ramshaw_tarjan handles negative costs", {
  cost <- matrix(c(-4, -2, -5, -3, -3, -6, -7, -5, -4), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles mixed positive/negative costs", {
  cost <- matrix(c(-4, 2, -5, 3, -3, 6, -7, 5, -4), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles sparse rectangular", {
  # 4x8 with many Infs
  cost <- matrix(Inf, nrow = 4, ncol = 8)
  cost[1, c(1, 3)] <- c(1, 5)
  cost[2, c(2, 4, 6)] <- c(2, 6, 10)
  cost[3, c(3, 5, 7)] <- c(3, 7, 11)
  cost[4, c(4, 6, 8)] <- c(4, 8, 12)

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

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 4)

  # All assignments must be finite
  for (i in 1:4) {
    expect_true(is.finite(cost[i, res$match[i]]))
  }

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles all same costs", {
  cost <- matrix(5, nrow = 3, ncol = 5)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(res$total_cost, 15)  # 3 rows * 5 each
  expect_equal(length(unique(res$match)), 3)
})

test_that("ramshaw_tarjan handles diagonal optimal", {
  cost <- diag(1, 4, 6)  # 4x6 with 1s on diagonal, 0s elsewhere
  cost[cost == 0] <- 10  # Make off-diagonal expensive
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  # Should pick diagonal (cost 1 each)
  expect_equal(res$total_cost, 4)
  expect_equal(res$match, c(1, 2, 3, 4))
})

test_that("ramshaw_tarjan computes correct assignment cost", {
  cost <- matrix(c(
    3, 7, 2, 9,
    5, 1, 8, 4,
    9, 3, 6, 2
  ), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  # Manually verify the cost
  computed_cost <- sum(cost[cbind(1:3, res$match)])
  expect_equal(res$total_cost, computed_cost)

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan errors on infeasible problem", {
  # Row 1 has no valid assignments
  cost <- matrix(c(Inf, Inf, Inf, 1, 2, 3, 4, 5, 6), nrow = 3, byrow = TRUE)

  expect_error(assignment(cost, method = "ramshaw_tarjan"), "no valid")
})

test_that("ramshaw_tarjan handles integer costs", {
  cost <- matrix(as.integer(c(4, 2, 5, 3, 3, 6, 7, 5, 4)), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")

  # Verify against JV
  res_jv <- assignment(cost, method = "jv")
  expect_equal(res$total_cost, res_jv$total_cost)
})

test_that("ramshaw_tarjan handles 2x2 matrix", {
  cost <- matrix(c(1, 3, 2, 4), nrow = 2)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  # Optimal: (1,1)=1 and (2,2)=4 -> 5
  # Or: (1,2)=2 and (2,1)=3 -> 5
  expect_equal(res$total_cost, 5)
})

test_that("ramshaw_tarjan benchmark vs JV on 10x100", {
  set.seed(789)
  cost <- matrix(runif(1000, 1, 100), nrow = 10, ncol = 100)

  res_rt <- assignment(cost, method = "ramshaw_tarjan")
  res_jv <- assignment(cost, method = "jv")

  expect_equal(res_rt$total_cost, res_jv$total_cost, tolerance = 1e-6)
})

test_that("ramshaw_tarjan handles repeated values in row", {
  cost <- matrix(c(1, 1, 1, 2, 2, 2, 3, 3, 3), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(res$total_cost, 6)  # 1+2+3
  expect_equal(length(unique(res$match)), 3)
})

test_that("ramshaw_tarjan method is reported correctly", {
  cost <- matrix(c(1, 2, 3, 4), nrow = 2)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$method_used, "ramshaw_tarjan")
})

test_that("ramshaw_tarjan handles zero costs", {
  cost <- matrix(c(0, 1, 2, 3, 0, 4, 5, 6, 0), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "ramshaw_tarjan")

  expect_equal(res$status, "optimal")
  expect_equal(res$total_cost, 0)  # Can pick all zeros on diagonal
  expect_equal(res$match, c(1, 2, 3))
})