tests/testthat/test-assignment-push_relabel.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# tests/testthat/test-assignment-push_relabel.R
# Tests for Push-Relabel assignment solver

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

  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("push_relabel 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 = "push_relabel")

  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)

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

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

  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("push_relabel 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 = "push_relabel")

  expect_equal(res$status, "optimal")
  expect_equal(length(res$match), 5)
  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("push_relabel 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 = "push_relabel")

  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("push_relabel 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 = "push_relabel")

  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("push_relabel handles maximization", {
  cost <- matrix(c(4, 2, 5, 3, 3, 6, 7, 5, 4), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "push_relabel", 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("push_relabel handles single row", {
  cost <- matrix(c(5, 2, 8, 1), nrow = 1)
  res <- assignment(cost, method = "push_relabel")

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

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

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

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

  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("push_relabel handles negative costs", {
  cost <- matrix(c(-4, -2, -5, -3, -3, -6, -7, -5, -4), nrow = 3, byrow = TRUE)
  res <- assignment(cost, method = "push_relabel")

  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("push_relabel 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 = "push_relabel")

  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("push_relabel 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 = "push_relabel")

  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("push_relabel handles all same costs", {
  cost <- matrix(5, nrow = 3, ncol = 5)
  res <- assignment(cost, method = "push_relabel")

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

test_that("push_relabel 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 = "push_relabel")

  expect_equal(res$status, "optimal")
  expect_equal(res$total_cost, 4)
  expect_equal(res$match, c(1, 2, 3, 4))
})

test_that("push_relabel 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 = "push_relabel")

  # 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("push_relabel 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 = "push_relabel"), "no valid")
})

test_that("push_relabel 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 = "push_relabel")

  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("push_relabel handles 2x2 matrix", {
  cost <- matrix(c(1, 3, 2, 4), nrow = 2)
  res <- assignment(cost, method = "push_relabel")

  expect_equal(res$status, "optimal")
  expect_equal(res$total_cost, 5)
})

test_that("push_relabel benchmark vs JV on 30x30", {
  set.seed(789)
  cost <- matrix(runif(900, 1, 100), nrow = 30, ncol = 30)

  res_pr <- assignment(cost, method = "push_relabel")
  res_jv <- assignment(cost, method = "jv")

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

test_that("push_relabel 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 = "push_relabel")

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

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

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

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

  expect_equal(res$status, "optimal")
  expect_equal(res$total_cost, 0)
  expect_equal(res$match, c(1, 2, 3))
})

test_that("push_relabel handles very small costs", {
  cost <- matrix(c(1e-10, 2e-10, 3e-10, 4e-10), nrow = 2)
  res <- assignment(cost, method = "push_relabel")

  expect_equal(res$status, "optimal")

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

test_that("push_relabel handles very large costs", {
  cost <- matrix(c(1e10, 2e10, 3e10, 4e10), nrow = 2)
  res <- assignment(cost, method = "push_relabel")

  expect_equal(res$status, "optimal")

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