tests/testthat/test-matching-interop.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests for Ecosystem Interop (as_matchit, balance_diagnostics generics)
# ==============================================================================

test_that("as_matchit works for matching_result", {
  set.seed(42)
  left <- data.frame(id = 1:5, age = c(25, 35, 45, 55, 65))
  right <- data.frame(id = 6:15, age = runif(10, 20, 70))

  result <- match_couples(left, right, vars = "age")
  mi <- as_matchit(result, left, right)

  expect_s3_class(mi, "matchit")
  expect_true(!is.null(mi$treat))
  expect_true(!is.null(mi$weights))
  expect_true(!is.null(mi$X))
  expect_true(all(mi$treat %in% c(0, 1)))
})


test_that("as_matchit works for full_matching_result", {
  set.seed(42)
  left <- data.frame(id = 1:5, age = c(25, 35, 45, 55, 65))
  right <- data.frame(id = 6:15, age = runif(10, 20, 70))

  result <- full_match(left, right, vars = "age")
  mi <- as_matchit(result, left, right)

  expect_s3_class(mi, "matchit")
  expect_equal(mi$method, "full")
})


test_that("as_matchit works for cem_result", {
  set.seed(42)
  left <- data.frame(id = 1:20, age = rnorm(20, 40, 10))
  right <- data.frame(id = 21:40, age = rnorm(20, 42, 10))

  result <- cem_match(left, right, vars = "age")
  mi <- as_matchit(result, left, right)

  expect_s3_class(mi, "matchit")
  expect_equal(mi$method, "cem")
})


test_that("balance_diagnostics.matching_result still works (backward compat)", {
  set.seed(123)
  left <- data.frame(
    id = 1:10,
    age = rnorm(10, 45, 10),
    income = rnorm(10, 50000, 15000)
  )
  right <- data.frame(
    id = 11:30,
    age = rnorm(20, 47, 10),
    income = rnorm(20, 52000, 15000)
  )

  result <- match_couples(left, right, vars = c("age", "income"))
  balance <- balance_diagnostics(result, left, right, vars = c("age", "income"))

  expect_s3_class(balance, "balance_diagnostics")
  expect_true(!is.null(balance$var_stats))
  expect_true(!is.null(balance$overall))
})


test_that("balance_diagnostics.full_matching_result works", {
  set.seed(42)
  left <- data.frame(id = 1:10, age = rnorm(10, 40, 10))
  right <- data.frame(id = 11:30, age = rnorm(20, 42, 10))

  result <- full_match(left, right, vars = "age")
  balance <- balance_diagnostics(result, left, right, vars = "age")

  expect_s3_class(balance, "balance_diagnostics")
  expect_equal(balance$method, "full")
})


test_that("balance_diagnostics.cem_result works", {
  set.seed(42)
  left <- data.frame(id = 1:20, age = rnorm(20, 40, 10))
  right <- data.frame(id = 21:40, age = rnorm(20, 42, 10))

  result <- cem_match(left, right, vars = "age")
  balance <- balance_diagnostics(result, left, right, vars = "age")

  expect_s3_class(balance, "balance_diagnostics")
  expect_equal(balance$method, "cem")
})


test_that("balance_diagnostics.subclass_result works", {
  set.seed(42)
  n <- 200
  data <- data.frame(id = 1:n, x = rnorm(n))
  data$treatment <- rbinom(n, 1, plogis(data$x))

  result <- subclass_match(treatment ~ x, data, treatment = "treatment")
  balance <- balance_diagnostics(result, data = data, vars = "x")

  expect_s3_class(balance, "balance_diagnostics")
  expect_equal(balance$method, "subclassification")
})


test_that("join_matched.matching_result still works (backward compat)", {
  left <- data.frame(id = 1:5, age = c(25, 30, 35, 40, 45))
  right <- data.frame(id = 6:10, age = c(24, 29, 36, 41, 44))

  result <- match_couples(left, right, vars = "age")
  joined <- join_matched(result, left, right)

  expect_s3_class(joined, "tbl_df")
  expect_true(nrow(joined) > 0)
})


test_that("join_matched.full_matching_result works", {
  set.seed(42)
  left <- data.frame(id = 1:5, age = c(25, 35, 45, 55, 65))
  right <- data.frame(id = 6:15, age = runif(10, 20, 70))

  result <- full_match(left, right, vars = "age")
  joined <- join_matched(result, left, right)

  expect_s3_class(joined, "tbl_df")
  expect_true(nrow(joined) > 0)
})


test_that("join_matched.cem_result works", {
  set.seed(42)
  left <- data.frame(id = 1:20, age = rnorm(20, 40, 10))
  right <- data.frame(id = 21:40, age = rnorm(20, 42, 10))

  result <- cem_match(left, right, vars = "age")
  joined <- join_matched(result, left, right)

  expect_s3_class(joined, "tbl_df")
})


test_that("cobalt bal.tab methods require cobalt package", {
  skip_if_not_installed("cobalt")

  set.seed(42)
  left <- data.frame(id = 1:10, age = rnorm(10, 40, 10))
  right <- data.frame(id = 11:20, age = rnorm(10, 42, 10))

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

  # If cobalt is installed, this should work
  bt <- bal.tab.matching_result(result, left, right)
  expect_true(!is.null(bt))
})