tests/testthat/test-batch-processing.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests for batch processing (lap_solve_batch)
# ==============================================================================

test_that("lap_solve_batch works with list of matrices", {
  costs <- list(
    matrix(c(1, 2, 3, 4), 2, 2),
    matrix(c(5, 6, 7, 8), 2, 2),
    matrix(c(1, 9, 9, 1), 2, 2)
  )

  result <- lap_solve_batch(costs)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_true("problem_id" %in% names(result))
  expect_true("source" %in% names(result))
  expect_true("target" %in% names(result))
  expect_true("cost" %in% names(result))
  expect_true("total_cost" %in% names(result))
  expect_true("method_used" %in% names(result))
  expect_equal(length(unique(result$problem_id)), 3)
})

test_that("lap_solve_batch works with 3D array", {
  arr <- array(runif(2 * 2 * 5), dim = c(2, 2, 5))

  result <- lap_solve_batch(arr)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_equal(length(unique(result$problem_id)), 5)
})

test_that("lap_solve_batch respects maximize parameter", {
  costs <- list(
    matrix(c(1, 100, 100, 1), 2, 2)
  )

  result_min <- lap_solve_batch(costs, maximize = FALSE)
  result_max <- lap_solve_batch(costs, maximize = TRUE)

  # Minimum should be 2, maximum should be 200
  expect_equal(unique(result_min$total_cost), 2)
  expect_equal(unique(result_max$total_cost), 200)
})

test_that("lap_solve_batch respects method parameter", {
  costs <- list(matrix(c(1, 2, 3, 4), 2, 2))

  result <- lap_solve_batch(costs, method = "hungarian")

  expect_equal(unique(result$method_used), "hungarian")
})

test_that("lap_solve_batch handles single problem", {
  costs <- list(matrix(c(4, 2, 3, 1), 2, 2))

  result <- lap_solve_batch(costs)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_equal(length(unique(result$problem_id)), 1)
})

test_that("lap_solve_batch handles rectangular matrices", {
  costs <- list(
    matrix(1:6, 2, 3),
    matrix(1:12, 3, 4)
  )

  result <- lap_solve_batch(costs)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_equal(length(unique(result$problem_id)), 2)
})

test_that("lap_solve_batch handles NA as forbidden", {
  costs <- list(
    matrix(c(1, NA, NA, 1), 2, 2)
  )

  result <- lap_solve_batch(costs)

  expect_s3_class(result, "lap_solve_batch_result")
  # Should match 1->1, 2->2 with total cost 2
  expect_equal(unique(result$total_cost), 2)
})

test_that("lap_solve_batch errors on empty input", {
  expect_error(
    lap_solve_batch(list()),
    "at least one problem"
  )
})

test_that("lap_solve_batch errors on invalid input type", {
  expect_error(
    lap_solve_batch("not a list or array"),
    "must be a list"
  )
})

test_that("lap_solve_batch errors on ungrouped data frame without columns", {
  df <- data.frame(x = 1:5, y = 1:5, z = 1:5)

  expect_error(
    lap_solve_batch(df, source = "x"),
    "use group_by"
  )
})

test_that("lap_solve_batch with n_threads handles sequential fallback", {
  costs <- list(
    matrix(c(1, 2, 3, 4), 2, 2),
    matrix(c(5, 6, 7, 8), 2, 2)
  )

  # With n_threads = 1 (explicit sequential)
  result <- lap_solve_batch(costs, n_threads = 1)
  expect_s3_class(result, "lap_solve_batch_result")
})

test_that("lap_solve_batch with n_threads = NULL uses available cores", {
  skip_on_cran()

  costs <- list(
    matrix(c(1, 2, 3, 4), 2, 2),
    matrix(c(5, 6, 7, 8), 2, 2)
  )

  # Should not error
  expect_no_error(lap_solve_batch(costs, n_threads = NULL))
})

test_that("lap_solve_batch print method works", {
  costs <- list(
    matrix(c(1, 2, 3, 4), 2, 2),
    matrix(c(5, 6, 7, 8), 2, 2)
  )

  result <- lap_solve_batch(costs)

  expect_output(print(result), "Batch Assignment Results")
  expect_output(print(result), "Number of problems solved")
  expect_output(print(result), "Total cost range")
})

test_that("lap_solve_batch works with grouped data frame", {
  skip_if_not_installed("dplyr")

  df <- tibble::tibble(
    sim = rep(1:3, each = 4),
    source = rep(1:2, times = 6),
    target = rep(1:2, each = 2, times = 3),
    cost = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
  )

  grouped_df <- dplyr::group_by(df, sim)

  result <- lap_solve_batch(grouped_df, source, target, cost)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_true("sim" %in% names(result))
  expect_equal(length(unique(result$sim)), 3)
})

test_that("lap_solve_batch grouped requires all columns", {
  skip_if_not_installed("dplyr")

  df <- tibble::tibble(
    sim = rep(1:2, each = 4),
    source = rep(1:2, times = 4),
    target = rep(1:2, each = 2, times = 2),
    cost = 1:8
  )

  grouped_df <- dplyr::group_by(df, sim)

  expect_error(
    lap_solve_batch(grouped_df),
    "must specify"
  )
})

test_that("lap_solve_batch handles 1x1 matrices", {
  costs <- list(
    matrix(5, 1, 1),
    matrix(10, 1, 1)
  )

  result <- lap_solve_batch(costs)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_equal(result$total_cost[result$problem_id == 1][1], 5)
  expect_equal(result$total_cost[result$problem_id == 2][1], 10)
})

test_that("lap_solve_batch handles large batch", {
  skip_on_cran()

  costs <- lapply(1:100, function(i) matrix(runif(16), 4, 4))

  result <- lap_solve_batch(costs)

  expect_s3_class(result, "lap_solve_batch_result")
  expect_equal(length(unique(result$problem_id)), 100)
})