tests/testthat/test-coverage-final-push.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# Final coverage push tests - targeting specific uncovered code paths

# ---------- lap_utils edge cases ----------

test_that("lap_solve_kbest exercises has_valid_matching", {
  skip_on_cran()

  # Create matrix with sparse structure to exercise matching validation
  cost <- matrix(c(1, 2, Inf, 3, 4, 5, Inf, 6, 7), nrow = 3, ncol = 3)
  result <- lap_solve_kbest(cost, k = 3)

  expect_true(nrow(result) >= 1)
})

test_that("lap_solve_kbest with very sparse matrix", {
  skip_on_cran()

  # Only diagonal allowed
  cost <- matrix(Inf, nrow = 3, ncol = 3)
  diag(cost) <- c(1, 2, 3)

  result <- lap_solve_kbest(cost, k = 2)
  # Returns expanded format, so 3 edges per solution
  expect_true(nrow(result) >= 3)  # At least one valid solution with 3 edges
})

test_that("is_feasible path via infeasible matrix", {
  skip_on_cran()

  # Row with all Inf - triggers is_feasible = FALSE
  cost <- matrix(c(1, 2, Inf, Inf, Inf, Inf, 3, 4, 5), nrow = 3, ncol = 3)

  result <- tryCatch(
    assignment(cost, method = "jv"),
    error = function(e) list(error = TRUE)
  )

  expect_true(!is.null(result))
})

# ---------- More solver coverage ----------

test_that("ramshaw_tarjan handles various inputs", {
  skip_on_cran()

  for (n in c(2, 3, 4, 5)) {
    set.seed(n * 111)
    cost <- matrix(sample(1:50, n * n, replace = TRUE), n, n)
    result <- assignment(cost, method = "ramshaw_tarjan")

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

test_that("csa handles various inputs", {
  skip_on_cran()

  for (n in c(2, 3, 4, 5, 6)) {
    set.seed(n * 222)
    cost <- matrix(sample(1:100, n * n, replace = TRUE), n, n)
    result <- assignment(cost, method = "csa")

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

test_that("ssap_bucket handles integer costs", {
  skip_on_cran()

  # ssap_bucket works with integer costs
  for (n in c(2, 3, 4, 5)) {
    set.seed(n * 333)
    cost <- matrix(sample(1:20, n * n, replace = TRUE), n, n)
    result <- assignment(cost, method = "ssap_bucket")

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

test_that("hk01 handles binary/uniform costs", {
  skip_on_cran()

  # Binary costs
  cost <- matrix(c(1, 0, 0, 1), nrow = 2, ncol = 2)
  result <- assignment(cost, method = "hk01")

  expect_equal(length(result$match), 2)
  expect_equal(result$total_cost, 0)  # Diagonal is 0
})

test_that("orlin handles various sizes", {
  skip_on_cran()

  for (n in c(3, 4, 5)) {
    set.seed(n * 444)
    cost <- matrix(sample(1:50, n * n, replace = TRUE), n, n)
    result <- assignment(cost, method = "orlin")

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

test_that("lapmod handles sparse costs", {
  skip_on_cran()

  # Matrix with many Inf (> 50% forbidden)
  cost <- matrix(Inf, nrow = 5, ncol = 5)
  diag(cost) <- 1:5
  cost[1, 2] <- 2
  cost[2, 1] <- 3

  result <- assignment(cost, method = "lapmod")
  expect_equal(length(result$match), 5)
})

# ---------- More morph coverage ----------

test_that("morph_utils helper functions", {
  skip_on_cran()
  skip_if_not_installed("magick")

  # Test .gif_delay_from_fps edge cases
  expect_equal(couplr:::.gif_delay_from_fps(10), 10L)
  expect_equal(couplr:::.gif_delay_from_fps(20), 5L)
  expect_equal(couplr:::.gif_delay_from_fps(50), 2L)

  # Test .clamp_rgb
  expect_equal(couplr:::.clamp_rgb(128), 128L)
  expect_equal(couplr:::.clamp_rgb(-50), 0L)
  expect_equal(couplr:::.clamp_rgb(500), 255L)
})

# ---------- balance_diagnostics coverage ----------

test_that("balance_diagnostics with various inputs", {
  skip_on_cran()

  set.seed(42)
  n <- 20
  left <- data.frame(id = 1:n, x = rnorm(n), y = rnorm(n))
  right <- data.frame(id = 1:n, x = rnorm(n) + 0.5, y = rnorm(n) - 0.3)

  result <- match_couples(left, right, vars = c("x", "y"), auto_scale = TRUE)

  # Various balance_diagnostics outputs
  balance <- balance_diagnostics(result, left, right, c("x", "y"))

  expect_true("var_stats" %in% names(balance))
  expect_true("overall" %in% names(balance))
})

test_that("balance_table formatting", {
  skip_on_cran()

  set.seed(42)
  n <- 15
  left <- data.frame(id = 1:n, x = rnorm(n))
  right <- data.frame(id = 1:n, x = rnorm(n))

  result <- match_couples(left, right, vars = "x")
  balance <- balance_diagnostics(result, left, right, "x")

  # balance_table should produce a tibble
  tbl <- balance_table(balance)
  expect_true(inherits(tbl, "tbl_df"))
})

# ---------- join_matched coverage ----------

test_that("join_matched with various options", {
  skip_on_cran()

  set.seed(42)
  n <- 10
  left <- data.frame(id = 1:n, x = rnorm(n), name = letters[1:n])
  right <- data.frame(id = 1:n, x = rnorm(n), name = LETTERS[1:n])

  result <- match_couples(left, right, vars = "x")

  # Test different suffix options
  joined1 <- join_matched(result, left, right)
  expect_true("name_left" %in% names(joined1) || "name.x" %in% names(joined1))

  joined2 <- join_matched(result, left, right, suffix = c("_A", "_B"))
  expect_true("name_A" %in% names(joined2) || ncol(joined2) > ncol(left))
})

# ---------- preprocessing coverage ----------

test_that("preprocess_matching_vars with various data types", {
  skip_on_cran()

  # Create data with numeric variables including constant
  left <- data.frame(
    id = 1:10,
    num1 = rnorm(10),
    num2 = rnorm(10, mean = 5, sd = 2),
    const = 5  # Constant variable
  )
  right <- data.frame(
    id = 1:10,
    num1 = rnorm(10),
    num2 = rnorm(10, mean = 5, sd = 2),
    const = 5
  )

  result <- suppressWarnings(preprocess_matching_vars(left, right, c("num1", "num2", "const")))

  # Should warn about or exclude constant variable
  expect_true(length(result$vars) >= 1)
  # Constant should be excluded
  expect_true(!("const" %in% result$vars) || length(result$excluded_vars) > 0)
})

# ---------- lap_solve_batch coverage ----------

test_that("lap_solve_batch with various methods", {
  skip_on_cran()

  cost <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2)
  costs <- list(cost, cost * 2, cost * 3)

  for (method in c("jv", "hungarian", "auction")) {
    result <- lap_solve_batch(costs, method = method)
    # Returns a tibble with expanded rows (2 matches per problem)
    expect_true(inherits(result, "data.frame"))
    expect_true(nrow(result) >= 3)  # At least 3 problems * 1 row each
  }
})

# ---------- Additional edge cases ----------

test_that("assignment with empty matrix", {
  skip_on_cran()

  # 0x0 matrix
  cost <- matrix(numeric(0), nrow = 0, ncol = 0)

  result <- tryCatch(
    assignment(cost, method = "jv"),
    error = function(e) list(error = TRUE)
  )

  expect_true(!is.null(result))
})

test_that("assignment auto method selection", {
  skip_on_cran()

  # Small matrix -> should auto-select appropriate method
  set.seed(42)
  cost <- matrix(sample(1:100, 16), nrow = 4, ncol = 4)
  result <- assignment(cost, method = "auto")

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

test_that("assignment_duals returns dual variables", {
  skip_on_cran()

  cost <- matrix(c(1, 5, 3, 2), nrow = 2, ncol = 2)
  result <- assignment_duals(cost)

  expect_true("u" %in% names(result))
  expect_true("v" %in% names(result))
  expect_equal(length(result$u), 2)
  expect_equal(length(result$v), 2)
})

test_that("bottleneck_assignment finds minimax", {
  skip_on_cran()

  cost <- matrix(c(1, 5, 3, 2, 4, 6, 7, 8, 9), nrow = 3, ncol = 3)
  result <- bottleneck_assignment(cost)

  expect_true("bottleneck" %in% names(result))
  expect_true(result$bottleneck >= 0)
})

test_that("sinkhorn optimal transport", {
  skip_on_cran()

  cost <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)
  result <- sinkhorn(cost)

  # Should return a transport plan
  expect_true("transport_plan" %in% names(result))
  expect_equal(nrow(result$transport_plan), 2)
  expect_equal(ncol(result$transport_plan), 2)
  expect_true(result$converged)
})