tests/testthat/test-matching-join-coverage.R

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Tests for matching_join.R coverage
# ==============================================================================

# ------------------------------------------------------------------------------
# join_matched parameter tests
# ------------------------------------------------------------------------------

test_that("join_matched with custom suffix", {
  left <- data.frame(id = 1:3, x = 1:3, y = 10:12)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1), y = c(10.1, 11.1, 12.1))

  result <- match_couples(left, right, vars = c("x", "y"))

  joined <- join_matched(result, left, right, suffix = c(".L", ".R"))

  expect_true("x.L" %in% names(joined))
  expect_true("x.R" %in% names(joined))
  expect_true("y.L" %in% names(joined))
  expect_true("y.R" %in% names(joined))
})

test_that("join_matched with specific left_vars and right_vars", {
  left <- data.frame(id = 1:3, x = 1:3, extra_left = letters[1:3])
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1), extra_right = letters[4:6])

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

  # Only include extra columns
  joined <- join_matched(
    result, left, right,
    left_vars = "extra_left",
    right_vars = "extra_right"
  )

  expect_true("extra_left_left" %in% names(joined))
  expect_true("extra_right_right" %in% names(joined))
  expect_false("x_left" %in% names(joined))
  expect_false("x_right" %in% names(joined))
})

test_that("join_matched with include_distance = FALSE", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  joined <- join_matched(result, left, right, include_distance = FALSE)

  expect_false("distance" %in% names(joined))
})

test_that("join_matched with include_pair_id = FALSE", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  joined <- join_matched(result, left, right, include_pair_id = FALSE)

  expect_false("pair_id" %in% names(joined))
})

test_that("join_matched with include_block_id = FALSE for blocked matching", {
  left <- data.frame(id = 1:6, x = 1:6, block = rep(c("A", "B"), each = 3))
  right <- data.frame(id = 7:12, x = c(1.1, 2.1, 3.1, 4.1, 5.1, 6.1),
                      block = rep(c("A", "B"), each = 3))

  result <- match_couples(left, right, vars = "x", block_id = "block")

  joined <- join_matched(result, left, right, include_block_id = FALSE)

  expect_false("block_id" %in% names(joined))
})

test_that("join_matched with custom ID columns", {
  left <- data.frame(my_id = 1:3, x = 1:3)
  right <- data.frame(other_id = 4:6, x = c(1.1, 2.1, 3.1))

  # Use compute_distances to specify custom ID columns
  dist_obj <- compute_distances(left, right, vars = "x", left_id = "my_id", right_id = "other_id")
  result <- match_couples(dist_obj)

  joined <- join_matched(result, left, right, left_id = "my_id", right_id = "other_id")

  expect_equal(nrow(joined), 3)
})

test_that("join_matched errors on non-matching_result", {
  expect_error(
    join_matched(list(), data.frame(), data.frame()),
    "must be a matching_result"
  )
})

test_that("join_matched errors on missing left_vars", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  expect_error(
    join_matched(result, left, right, left_vars = c("nonexistent")),
    "Variables not found in left"
  )
})

test_that("join_matched errors on missing right_vars", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  expect_error(
    join_matched(result, left, right, right_vars = c("nonexistent")),
    "Variables not found in right"
  )
})

test_that("join_matched errors on invalid suffix length", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  expect_error(
    join_matched(result, left, right, suffix = c("_only_one")),
    "suffix must be a character vector of length 2"
  )
})

test_that("join_matched errors on missing left_id column", {
  left <- data.frame(wrong_id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

  result <- match_couples(
    data.frame(id = 1:3, x = 1:3),
    right,
    vars = "x"
  )

  expect_error(
    join_matched(result, left, right),
    "left_id column.*not found"
  )
})

test_that("join_matched errors on missing right_id column", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(wrong_id = 4:6, x = c(1.1, 2.1, 3.1))

  result <- match_couples(
    left,
    data.frame(id = 4:6, x = c(1.1, 2.1, 3.1)),
    vars = "x"
  )

  expect_error(
    join_matched(result, left, right),
    "right_id column.*not found"
  )
})

test_that("join_matched warns on empty result", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.5, 2.5, 3.5))

  # Get a valid result first
  result <- match_couples(left, right, vars = "x")

  # Create a result with no pairs by manually emptying it
  empty_result <- result
  empty_result$pairs <- result$pairs[0, ]

  expect_warning(
    joined <- join_matched(empty_result, left, right),
    "No matched pairs"
  )

  expect_equal(nrow(joined), 0)
})

test_that("join_matched handles non-overlapping variables", {
  left <- data.frame(id = 1:3, only_in_left = 1:3)
  right <- data.frame(id = 4:6, only_in_right = 4:6, x = c(1.1, 2.1, 3.1))

  left_for_match <- data.frame(id = 1:3, x = 1:3)
  result <- match_couples(left_for_match, right[, c("id", "x")], vars = "x")

  joined <- join_matched(result, left, right)

  expect_true("only_in_left_left" %in% names(joined))
  expect_true("only_in_right_right" %in% names(joined))
})

# ------------------------------------------------------------------------------
# augment tests
# ------------------------------------------------------------------------------

test_that("augment.matching_result works", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  # Using couplr::augment
  augmented <- couplr::augment(result, left, right)

  expect_s3_class(augmented, "tbl_df")
  expect_equal(nrow(augmented), 3)
})

test_that("augment passes additional arguments to join_matched", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  augmented <- couplr::augment(result, left, right, include_distance = FALSE)

  expect_false("distance" %in% names(augmented))
})

test_that("augment generic dispatches correctly", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  # Should dispatch to augment.matching_result
  augmented <- augment(result, left, right)

  expect_s3_class(augmented, "tbl_df")
})

# ------------------------------------------------------------------------------
# Type conversion edge cases
# ------------------------------------------------------------------------------

test_that("join_matched handles character IDs", {
  left <- data.frame(id = letters[1:3], x = 1:3, stringsAsFactors = FALSE)
  right <- data.frame(id = letters[4:6], x = c(1.1, 2.1, 3.1), stringsAsFactors = FALSE)

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

  joined <- join_matched(result, left, right)

  expect_equal(nrow(joined), 3)
  expect_type(joined$left_id, "character")
  expect_type(joined$right_id, "character")
})

test_that("join_matched handles numeric IDs", {
  left <- data.frame(id = 1:3, x = 1:3)
  right <- data.frame(id = 4:6, x = c(1.1, 2.1, 3.1))

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

  joined <- join_matched(result, left, right)

  expect_equal(nrow(joined), 3)
})

test_that("join_matched handles factor IDs by converting to character", {
  # Factor IDs are converted to character during matching
  # so we test that the join still works
  left <- data.frame(id = letters[1:3], x = 1:3, stringsAsFactors = FALSE)
  right <- data.frame(id = letters[4:6], x = c(1.1, 2.1, 3.1), stringsAsFactors = FALSE)

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

  joined <- join_matched(result, left, right)

  expect_equal(nrow(joined), 3)
})

# ------------------------------------------------------------------------------
# Column ordering tests
# ------------------------------------------------------------------------------

test_that("join_matched orders columns correctly", {
  left <- data.frame(id = 1:3, a = 1:3, b = 4:6, c = 7:9)
  right <- data.frame(id = 4:6, a = c(1.1, 2.1, 3.1), d = 10:12, e = 13:15)

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

  joined <- join_matched(result, left, right)

  # Check column order: pair_id, left_id, right_id, distance should come first
  first_cols <- names(joined)[1:4]
  expect_equal(first_cols, c("pair_id", "left_id", "right_id", "distance"))
})