tests/testthat/test-line-metric.R

In couplr: Optimal Pairing and Matching via Linear Assignment

test_that("line_metric solves square problems correctly", {
  # For square problems (n == m), the optimal solution is to sort both
  # and match in order: sorted_x[i] -> sorted_y[i]
  
  set.seed(123)
  for (n in 2:6) {
    x <- runif(n, -10, 10)
    y <- runif(n, -10, 10)
    
    # Test L1
    result_l1 <- lap_solve_line_metric(x, y, cost = "L1", maximize = FALSE)
    
    # Verify it's a valid assignment
    expect_equal(length(result_l1$match), n)
    expect_true(all(result_l1$match >= 1 & result_l1$match <= n))
    expect_equal(length(unique(result_l1$match)), n)  # All different
    
    # Compute expected cost (sort and match)
    xs <- sort(x)
    ys <- sort(y)
    expected_cost_l1 <- sum(abs(xs - ys))
    expect_equal(result_l1$total_cost, expected_cost_l1, tolerance = 1e-10)
    
    # Test L2
    result_l2 <- lap_solve_line_metric(x, y, cost = "L2", maximize = FALSE)
    expected_cost_l2 <- sum((xs - ys)^2)
    expect_equal(result_l2$total_cost, expected_cost_l2, tolerance = 1e-10)
  }
})

test_that("line_metric handles rectangular problems (n < m)", {
  set.seed(456)
  
  # Small test case we can verify by hand
  x <- c(1.0, 3.0)
  y <- c(0.5, 2.0, 4.0)
  
  result <- lap_solve_line_metric(x, y, cost = "L1", maximize = FALSE)
  
  # The optimal solution is:
  # x[1]=1.0 -> y[1]=0.5 and x[2]=3.0 -> y[2]=2.0
  # Cost = |1.0 - 0.5| + |3.0 - 2.0| = 0.5 + 1.0 = 1.5
  # This is better than matching x[1]->y[2], x[2]->y[3] which would cost 2.0
  expect_equal(result$total_cost, 1.5, tolerance = 1e-10)
  
  # Test a few random cases
  for (trial in 1:5) {
    n <- sample(3:6, 1)
    m <- n + sample(1:3, 1)
    
    x <- runif(n, -5, 5)
    y <- runif(m, -5, 5)
    
    result <- lap_solve_line_metric(x, y, cost = "L1", maximize = FALSE)
    
    # Verify validity
    expect_equal(length(result$match), n)
    expect_true(all(result$match >= 1 & result$match <= m))
    expect_equal(length(unique(result$match)), n)
    
    # Cost should be positive (unless maximize)
    expect_true(result$total_cost >= 0)
  }
})

test_that("line_metric brute force verification on small problems", {
  # For very small problems, we can brute force all possible assignments
  # that respect the monotonicity constraint
  set.seed(789)
  
  for (cost_type in c("L1", "L2")) {
    n <- 3
    m <- 4
    x <- runif(n, -5, 5)
    y <- runif(m, -5, 5)
    
    result <- lap_solve_line_metric(x, y, cost = cost_type, maximize = FALSE)
    
    # Brute force: try all combinations of m choose n
    # BUT only those that respect monotonicity (sorted x maps to increasing y indices)
    xs <- sort(x)
    ys <- sort(y)
    
    best_cost <- Inf
    for (cols in combn(m, n, simplify = FALSE)) {
      cost <- 0
      for (i in 1:n) {
        diff <- abs(xs[i] - ys[cols[i]])
        if (cost_type == "L1") {
          cost <- cost + diff
        } else {
          cost <- cost + diff^2
        }
      }
      if (cost < best_cost) best_cost <- cost
    }
    
    expect_equal(result$total_cost, best_cost, tolerance = 1e-10)
  }
})

test_that("line_metric handles unsorted inputs correctly", {
  # The algorithm should sort internally
  x <- c(5.0, 1.0, 3.0)
  y <- c(4.5, 0.5, 6.0, 2.0, 3.5)
  
  result <- lap_solve_line_metric(x, y, cost = "L1", maximize = FALSE)
  
  # Verify it found a valid assignment
  expect_equal(length(result$match), 3)
  expect_true(all(result$match >= 1 & result$match <= 5))
  expect_equal(length(unique(result$match)), 3)
  
  # The result should match what we'd get with pre-sorted inputs
  x_sorted <- sort(x)
  y_sorted <- sort(y)
  
  # The matches in the result should respect the sorted order
  # i.e., if x[i] < x[j], then y[result$match[i]] < y[result$match[j]]
})

test_that("line_metric cost aliases work correctly", {
  set.seed(321)
  x <- runif(4, -5, 5)
  y <- runif(6, -5, 5)
  
  # Test L1 aliases
  r1 <- lap_solve_line_metric(x, y, cost = "L1")
  r2 <- lap_solve_line_metric(x, y, cost = "abs")
  r3 <- lap_solve_line_metric(x, y, cost = "manhattan")
  
  expect_equal(r1$total_cost, r2$total_cost)
  expect_equal(r1$total_cost, r3$total_cost)
  
  # Test L2 aliases
  r4 <- lap_solve_line_metric(x, y, cost = "L2")
  r5 <- lap_solve_line_metric(x, y, cost = "sq")
  r6 <- lap_solve_line_metric(x, y, cost = "squared")
  r7 <- lap_solve_line_metric(x, y, cost = "quadratic")
  
  expect_equal(r4$total_cost, r5$total_cost)
  expect_equal(r4$total_cost, r6$total_cost)
  expect_equal(r4$total_cost, r7$total_cost)
})

test_that("line_metric maximize parameter works", {
  set.seed(654)
  x <- runif(4, -5, 5)
  y <- runif(4, -5, 5)
  
  r_min <- lap_solve_line_metric(x, y, cost = "L1", maximize = FALSE)
  r_max <- lap_solve_line_metric(x, y, cost = "L1", maximize = TRUE)
  
  # Maximizing should give the negative of minimizing the negated costs
  # For distance-based costs, this means we want the WORST matching
  expect_equal(r_min$total_cost, -r_max$total_cost, tolerance = 1e-10)
})

test_that("line_metric handles edge cases", {
  # Single element
  result <- lap_solve_line_metric(c(1.5), c(2.0), cost = "L1")
  expect_equal(result$match, 1L)
  expect_equal(result$total_cost, 0.5)
  
  # Two elements
  result <- lap_solve_line_metric(c(1.0, 3.0), c(0.5, 3.5), cost = "L1")
  expect_equal(length(result$match), 2)
  
  # Identical values
  result <- lap_solve_line_metric(c(1.0, 1.0, 1.0), c(1.0, 1.0, 1.0), cost = "L1")
  expect_equal(result$total_cost, 0.0)
})

test_that("line_metric input validation works", {
  # Empty vectors
  expect_error(lap_solve_line_metric(numeric(0), c(1, 2)), "non-empty")
  expect_error(lap_solve_line_metric(c(1, 2), numeric(0)), "non-empty")
  
  # n > m (more sources than targets)
  expect_error(lap_solve_line_metric(c(1, 2, 3), c(1, 2)), "must be <=")
  
  # Non-finite values
  expect_error(lap_solve_line_metric(c(1, NA, 3), c(1, 2, 3)), "finite")
  expect_error(lap_solve_line_metric(c(1, 2, 3), c(1, Inf, 3)), "finite")
  expect_error(lap_solve_line_metric(c(1, NaN, 3), c(1, 2, 3)), "finite")
  
  # Invalid cost type
  expect_error(lap_solve_line_metric(c(1, 2), c(1, 2), cost = "L3"), "must be one of")
  expect_error(lap_solve_line_metric(c(1, 2), c(1, 2), cost = "invalid"), "must be one of")
  
  # Non-numeric input
  expect_error(lap_solve_line_metric(c("a", "b"), c(1, 2)), "numeric")
  expect_error(lap_solve_line_metric(c(1, 2), c("a", "b")), "numeric")
})

test_that("line_metric is consistent with sorted inputs", {
  set.seed(999)
  
  # Generate random sorted sequences
  for (trial in 1:5) {
    n <- sample(3:6, 1)
    m <- n + sample(1:3, 1)
    
    x <- sort(runif(n, -10, 10))
    y <- sort(runif(m, -10, 10))
    
    result <- lap_solve_line_metric(x, y, cost = "L1", maximize = FALSE)
    
    # For sorted inputs, we can verify the monotonicity property:
    # If sources are sorted, matched targets should form an increasing sequence
    matched_targets <- result$match
    expect_true(all(diff(matched_targets) > 0))
  }
})

test_that("line_metric performance on larger problems", {
  skip_on_cran()
  
  # Test that it can handle reasonably large problems
  set.seed(2025)
  n <- 500
  m <- 750
  
  x <- runif(n, -100, 100)
  y <- runif(m, -100, 100)
  
  start_time <- Sys.time()
  result <- lap_solve_line_metric(x, y, cost = "L2", maximize = FALSE)
  elapsed <- as.numeric(Sys.time() - start_time, units = "secs")
  
  # Should complete in reasonable time (< 1 second for n=500, m=750)
  expect_true(elapsed < 1.0)
  
  # Verify result
  expect_equal(length(result$match), n)
  expect_true(all(result$match >= 1 & result$match <= m))
  expect_equal(length(unique(result$match)), n)
})