# ============================================================================== # Tests for matching constraints (matching_constraints.R) # ============================================================================== test_that("apply_max_distance leaves values below threshold unchanged", { cost <- matrix(c(1, 2, 3, 4), 2, 2) result <- couplr:::apply_max_distance(cost, max_distance = 5) expect_equal(result, cost) }) test_that("apply_max_distance marks values above threshold as forbidden", { cost <- matrix(c(1, 5, 10, 2), 2, 2) result <- couplr:::apply_max_distance(cost, max_distance = 3) expect_equal(result[1, 1], 1) expect_equal(result[2, 2], 2) expect_true(result[1, 2] > 1e15) # Forbidden expect_true(result[2, 1] > 1e15) # Forbidden }) test_that("apply_max_distance handles Inf threshold", { cost <- matrix(c(1, 100, 1000, 10000), 2, 2) result <- couplr:::apply_max_distance(cost, max_distance = Inf) expect_equal(result, cost) }) test_that("apply_max_distance handles NULL threshold", { cost <- matrix(c(1, 100, 1000, 10000), 2, 2) result <- couplr:::apply_max_distance(cost, max_distance = NULL) expect_equal(result, cost) }) test_that("apply_max_distance errors on negative threshold", { cost <- matrix(c(1, 2, 3, 4), 2, 2) expect_error( couplr:::apply_max_distance(cost, max_distance = -1), "must be positive" ) }) test_that("apply_max_distance errors on non-numeric threshold", { cost <- matrix(c(1, 2, 3, 4), 2, 2) expect_error( couplr:::apply_max_distance(cost, max_distance = "five"), "must be a single numeric" ) }) test_that("apply_max_distance errors on vector threshold", { cost <- matrix(c(1, 2, 3, 4), 2, 2) expect_error( couplr:::apply_max_distance(cost, max_distance = c(1, 2)), "must be a single numeric" ) }) test_that("apply_calipers marks violating pairs as forbidden", { left <- data.frame(x = c(1, 2, 3), y = c(10, 20, 30)) right <- data.frame(x = c(1.5, 2.5, 3.5), y = c(15, 25, 35)) cost <- matrix(1, 3, 3) vars <- c("x", "y") calipers <- list(y = 3) # Max difference of 3 on y result <- couplr:::apply_calipers(cost, left, right, calipers, vars) # Check diagonal should still be valid (y diffs: 5, 5, 5) # All pairs should be forbidden since y diff is always 5 > 3 expect_true(all(result > 1e15)) }) test_that("apply_calipers with NULL returns unchanged", { cost <- matrix(1, 3, 3) result <- couplr:::apply_calipers(cost, NULL, NULL, NULL, NULL) expect_equal(result, cost) }) test_that("apply_calipers skips variables not in vars", { left <- data.frame(x = c(1, 2, 3), z = c(100, 200, 300)) right <- data.frame(x = c(1.5, 2.5, 3.5), z = c(110, 210, 310)) cost <- matrix(1, 3, 3) vars <- c("x") # Only x, not z calipers <- list(z = 5) # Caliper on z, but z not in vars result <- couplr:::apply_calipers(cost, left, right, calipers, vars) # Should be unchanged since z is not in vars expect_equal(result, cost) }) test_that("apply_calipers works with multiple variables", { left <- data.frame(x = c(1, 10), y = c(1, 10)) right <- data.frame(x = c(1.5, 10.5), y = c(1.5, 10.5)) cost <- matrix(1, 2, 2) vars <- c("x", "y") calipers <- list(x = 1, y = 1) # Max diff of 1 on both result <- couplr:::apply_calipers(cost, left, right, calipers, vars) # Diagonal should be valid, off-diagonal should be forbidden expect_equal(result[1, 1], 1) expect_equal(result[2, 2], 1) expect_true(result[1, 2] > 1e15) expect_true(result[2, 1] > 1e15) }) test_that("mark_forbidden_pairs works with matrix input", { cost <- matrix(1, 3, 3) forbidden <- matrix(c(1, 2, 2, 3), ncol = 2, byrow = TRUE) result <- couplr:::mark_forbidden_pairs(cost, forbidden) expect_true(result[1, 2] > 1e15) expect_true(result[2, 3] > 1e15) expect_equal(result[1, 1], 1) expect_equal(result[2, 2], 1) expect_equal(result[3, 3], 1) }) test_that("mark_forbidden_pairs handles NULL", { cost <- matrix(1, 3, 3) result <- couplr:::mark_forbidden_pairs(cost, NULL) expect_equal(result, cost) }) test_that("mark_forbidden_pairs handles empty matrix", { cost <- matrix(1, 3, 3) forbidden <- matrix(nrow = 0, ncol = 2) result <- couplr:::mark_forbidden_pairs(cost, forbidden) expect_equal(result, cost) }) test_that("apply_all_constraints combines all constraints", { left <- data.frame(x = c(1, 10), y = c(1, 10)) right <- data.frame(x = c(2, 11), y = c(2, 11)) cost <- matrix(c(1, 5, 5, 1), 2, 2) vars <- c("x", "y") result <- couplr:::apply_all_constraints( cost, left, right, vars, max_distance = 3, calipers = list(x = 2) ) # (1,1) should be valid: cost=1 < 3, x diff = 1 < 2 expect_equal(result[1, 1], 1) # (2,2) should be valid: cost=1 < 3, x diff = 1 < 2 expect_equal(result[2, 2], 1) # (1,2) should be forbidden: cost=5 > 3 expect_true(result[1, 2] > 1e15) # (2,1) should be forbidden: cost=5 > 3 expect_true(result[2, 1] > 1e15) }) test_that("has_valid_pairs returns TRUE when valid pairs exist", { cost <- matrix(c(1, Inf, Inf, 1), 2, 2) expect_true(couplr:::has_valid_pairs(cost)) }) test_that("has_valid_pairs returns FALSE when no valid pairs", { cost <- matrix(couplr:::BIG_COST, 2, 2) expect_false(couplr:::has_valid_pairs(cost)) }) test_that("has_valid_pairs handles Inf values", { cost <- matrix(Inf, 2, 2) expect_false(couplr:::has_valid_pairs(cost)) }) test_that("count_valid_pairs counts correctly", { cost <- matrix(c(1, Inf, Inf, 1), 2, 2) expect_equal(couplr:::count_valid_pairs(cost), 2) }) test_that("count_valid_pairs returns 0 for all forbidden", { cost <- matrix(Inf, 2, 2) expect_equal(couplr:::count_valid_pairs(cost), 0) }) test_that("count_valid_pairs handles mixed values", { cost <- matrix(c(1, 2, couplr:::BIG_COST, 3), 2, 2) expect_equal(couplr:::count_valid_pairs(cost), 3) }) test_that("BIG_COST is very large", { expect_true(couplr:::BIG_COST > 1e100) }) test_that("constraints work end-to-end via match_couples", { left <- data.frame(id = 1:3, x = c(1, 2, 3)) right <- data.frame(id = 4:6, x = c(1.1, 5, 3.1)) result <- match_couples(left, right, vars = "x", max_distance = 0.5) expect_equal(nrow(result$pairs), 2) expect_true(all(result$pairs$distance <= 0.5)) }) test_that("calipers work end-to-end via match_couples", { left <- data.frame( id = 1:3, x = c(1, 2, 3), y = c(10, 20, 30) ) right <- data.frame( id = 4:6, x = c(1.1, 2.1, 3.1), y = c(10.5, 25, 30.5) ) result <- match_couples( left, right, vars = c("x", "y"), calipers = list(y = 2) ) # Middle pair should be excluded (y diff = 5 > 2) expect_equal(nrow(result$pairs), 2) })