tests/testthat/test-matching-ratio.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# Tests for k:1 matching (Feature 4)

test_that("ratio = 1 gives standard 1:1 matching", {
  left <- data.frame(id = 1:5, x = c(1, 2, 3, 4, 5))
  right <- data.frame(id = 6:15, x = seq(1, 5, length.out = 10))
  result <- match_couples(left, right, vars = "x", ratio = 1L)

  # Each left matched exactly once
  left_counts <- table(result$pairs$left_id)
  expect_true(all(left_counts == 1))
  expect_equal(nrow(result$pairs), 5)
})

test_that("ratio = 2 produces more matches than ratio = 1", {
  set.seed(42)
  left <- data.frame(id = 1:5, x = c(1, 2, 3, 4, 5))
  right <- data.frame(id = 6:25, x = seq(0.5, 5.5, length.out = 20))

  result_1 <- match_couples(left, right, vars = "x", ratio = 1L)
  result_2 <- match_couples(left, right, vars = "x", ratio = 2L)

  # k:1 should produce more pairs (up to 2x)
  expect_true(nrow(result_2$pairs) > nrow(result_1$pairs))

  # Left units can appear up to 2 times
  left_counts <- table(result_2$pairs$left_id)
  expect_true(all(left_counts <= 2))
})

test_that("ratio stores in info", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:9, x = c(1.1, 1.9, 2.1, 2.9, 3.1, 3.9))
  result <- match_couples(left, right, vars = "x", ratio = 2L,
                          return_diagnostics = TRUE)

  expect_equal(result$info$ratio, 2L)
})

test_that("ratio with greedy_couples produces more pairs", {
  set.seed(42)
  left <- data.frame(id = 1:5, x = c(1, 2, 3, 4, 5))
  right <- data.frame(id = 6:25, x = seq(0.5, 5.5, length.out = 20))

  result_1 <- greedy_couples(left, right, vars = "x", ratio = 1L)
  result_2 <- greedy_couples(left, right, vars = "x", ratio = 2L)

  expect_true(nrow(result_2$pairs) > nrow(result_1$pairs))
})

test_that("ratio without replacement: each right used at most once", {
  set.seed(42)
  left <- data.frame(id = 1:3, x = c(1, 2, 3))
  right <- data.frame(id = 4:9, x = c(1.1, 1.9, 2.1, 2.9, 3.1, 3.9))
  result <- match_couples(left, right, vars = "x", ratio = 2L)

  # In k:1 without replacement, each right unit used at most once
  right_counts <- table(result$pairs$right_id)
  expect_true(all(right_counts <= 1))
})

test_that("invalid ratio errors", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = 4:6)
  expect_error(match_couples(left, right, vars = "x", ratio = 0),
               "ratio must be a positive integer")
  expect_error(match_couples(left, right, vars = "x", ratio = -1),
               "ratio must be a positive integer")
})

test_that("ratio = 3 with replacement", {
  left <- data.frame(id = 1:2, x = c(1, 10))
  right <- data.frame(id = 3:7, x = c(0.5, 1.0, 1.5, 9.5, 10.5))
  result <- match_couples(left, right, vars = "x",
                          replace = TRUE, ratio = 3L,
                          return_diagnostics = TRUE)

  # Each left can get up to 3 matches
  left_counts <- table(result$pairs$left_id)
  expect_true(all(left_counts <= 3))
  expect_true(nrow(result$pairs) >= 2)
})