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

In couplr: Optimal Pairing and Matching via Linear Assignment

# ==============================================================================
# Additional tests for matching distance functions to increase coverage
# ==============================================================================

# ------------------------------------------------------------------------------
# compute_distance_matrix tests
# ------------------------------------------------------------------------------

test_that("compute_distance_matrix validates column count", {
  left <- matrix(1:6, nrow = 2, ncol = 3)
  right <- matrix(1:4, nrow = 2, ncol = 2)  # Different column count

  expect_error(
    couplr:::compute_distance_matrix(left, right),
    "same number of columns"
  )
})

test_that("compute_distance_matrix computes euclidean distance", {
  left <- matrix(c(0, 0, 3, 0), nrow = 2, ncol = 2, byrow = TRUE)
  right <- matrix(c(0, 4, 0, 0), nrow = 2, ncol = 2, byrow = TRUE)

  result <- couplr:::compute_distance_matrix(left, right, distance = "euclidean")

  expect_equal(dim(result), c(2, 2))
  expect_equal(result[1, 1], 4)  # (0,0) to (0,4)
  expect_equal(result[2, 2], 3)  # (3,0) to (0,0)
})

test_that("compute_distance_matrix computes L2 distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 4), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "l2")

  expect_equal(result[1, 1], 5)  # 3-4-5 triangle
})

test_that("compute_distance_matrix computes manhattan distance", {
  left <- matrix(c(0, 0, 1, 1), nrow = 2, ncol = 2, byrow = TRUE)
  right <- matrix(c(2, 3, 0, 0), nrow = 2, ncol = 2, byrow = TRUE)

  result <- couplr:::compute_distance_matrix(left, right, distance = "manhattan")

  expect_equal(result[1, 1], 5)  # |0-2| + |0-3| = 5
  expect_equal(result[2, 1], 3)  # |1-2| + |1-3| = 3
  expect_equal(result[1, 2], 0)  # |0-0| + |0-0| = 0
})

test_that("compute_distance_matrix computes L1 distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 4), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "l1")

  expect_equal(result[1, 1], 7)  # |3| + |4|
})

test_that("compute_distance_matrix computes cityblock distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 4), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "cityblock")

  expect_equal(result[1, 1], 7)
})

test_that("compute_distance_matrix computes squared euclidean distance", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 4), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "squared_euclidean")

  expect_equal(result[1, 1], 25)  # 9 + 16
})

test_that("compute_distance_matrix computes sqeuclidean distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 4), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "sqeuclidean")

  expect_equal(result[1, 1], 25)
})

test_that("compute_distance_matrix computes sq distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 4), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "sq")

  expect_equal(result[1, 1], 25)
})

test_that("compute_distance_matrix computes chebyshev distance", {
  left <- matrix(c(0, 0, 5, 5), nrow = 2, ncol = 2, byrow = TRUE)
  right <- matrix(c(3, 10, 2, 2), nrow = 2, ncol = 2, byrow = TRUE)

  result <- couplr:::compute_distance_matrix(left, right, distance = "chebyshev")

  expect_equal(result[1, 1], 10)  # max(|0-3|, |0-10|) = 10
  expect_equal(result[2, 2], 3)   # max(|5-2|, |5-2|) = 3
})

test_that("compute_distance_matrix computes chebychev distance (alternate spelling)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 10), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "chebychev")

  expect_equal(result[1, 1], 10)
})

test_that("compute_distance_matrix computes maximum distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 10), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "maximum")

  expect_equal(result[1, 1], 10)
})

test_that("compute_distance_matrix computes max distance (alias)", {
  left <- matrix(c(0, 0), nrow = 1)
  right <- matrix(c(3, 10), nrow = 1)

  result <- couplr:::compute_distance_matrix(left, right, distance = "max")

  expect_equal(result[1, 1], 10)
})

test_that("compute_distance_matrix computes mahalanobis distance", {
  set.seed(123)
  left <- matrix(rnorm(20), nrow = 5, ncol = 4)
  right <- matrix(rnorm(20), nrow = 5, ncol = 4)

  result <- couplr:::compute_distance_matrix(left, right, distance = "mahalanobis")

  expect_equal(dim(result), c(5, 5))
  expect_true(all(result >= 0))
  expect_true(all(is.finite(result)))
})

test_that("compute_distance_matrix computes maha distance (alias)", {
  set.seed(123)
  left <- matrix(rnorm(20), nrow = 5, ncol = 4)
  right <- matrix(rnorm(20), nrow = 5, ncol = 4)

  result <- couplr:::compute_distance_matrix(left, right, distance = "maha")

  expect_equal(dim(result), c(5, 5))
})

test_that("compute_distance_matrix errors on singular covariance", {
  # Create data with linearly dependent columns
  left <- matrix(c(1, 2, 3, 4, 2, 4, 6, 8), nrow = 2, ncol = 4, byrow = TRUE)
  right <- matrix(c(1, 2, 3, 4, 2, 4, 6, 8), nrow = 2, ncol = 4, byrow = TRUE)

  expect_error(
    couplr:::compute_distance_matrix(left, right, distance = "mahalanobis"),
    "singular"
  )
})

test_that("compute_distance_matrix rejects unknown metric", {
  left <- matrix(1:4, nrow = 2)
  right <- matrix(5:8, nrow = 2)

  expect_error(
    couplr:::compute_distance_matrix(left, right, distance = "unknown_metric"),
    "Unknown distance metric"
  )
})

test_that("compute_distance_matrix accepts custom function", {
  custom_dist <- function(left, right) {
    n <- nrow(left)
    m <- nrow(right)
    result <- matrix(1.0, n, m)  # Constant distance of 1
    result
  }

  left <- matrix(1:4, nrow = 2)
  right <- matrix(5:8, nrow = 2)

  result <- couplr:::compute_distance_matrix(left, right, distance = custom_dist)

  expect_equal(dim(result), c(2, 2))
  expect_true(all(result == 1.0))
})

# ------------------------------------------------------------------------------
# apply_scaling tests
# ------------------------------------------------------------------------------

test_that("apply_scaling returns originals when method is FALSE", {
  left <- matrix(1:6, nrow = 2)
  right <- matrix(7:12, nrow = 2)

  result <- couplr:::apply_scaling(left, right, method = FALSE)

  expect_equal(result$left, left)
  expect_equal(result$right, right)
  expect_null(result$params)
})

test_that("apply_scaling returns originals when method is 'none'", {
  left <- matrix(1:6, nrow = 2)
  right <- matrix(7:12, nrow = 2)

  result <- couplr:::apply_scaling(left, right, method = "none")

  expect_equal(result$left, left)
  expect_equal(result$right, right)
})

test_that("apply_scaling returns originals when method is NULL", {
  left <- matrix(1:6, nrow = 2)
  right <- matrix(7:12, nrow = 2)

  result <- couplr:::apply_scaling(left, right, method = NULL)

  expect_equal(result$left, left)
  expect_equal(result$right, right)
})

test_that("apply_scaling standardizes with method = TRUE", {
  left <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 3, ncol = 2)
  right <- matrix(c(7, 8, 9, 10, 11, 12), nrow = 3, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = TRUE)

  # Check that columns have mean ~0 and sd ~1
  combined <- rbind(result$left, result$right)
  expect_true(all(abs(colMeans(combined)) < 1e-10))
  expect_equal(result$params$method, "standardize")
})

test_that("apply_scaling standardizes with method = 'standardize'", {
  left <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 3, ncol = 2)
  right <- matrix(c(7, 8, 9, 10, 11, 12), nrow = 3, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = "standardize")

  expect_equal(result$params$method, "standardize")
  expect_true("means" %in% names(result$params))
  expect_true("sds" %in% names(result$params))
})

test_that("apply_scaling standardizes with method = 'scale'", {
  left <- matrix(c(1, 2), nrow = 2, ncol = 1)
  right <- matrix(c(3, 4), nrow = 2, ncol = 1)

  result <- couplr:::apply_scaling(left, right, method = "scale")

  expect_equal(result$params$method, "standardize")
})

test_that("apply_scaling handles constant columns in standardize", {
  left <- matrix(c(5, 5, 1, 2), nrow = 2, ncol = 2)  # First col constant
  right <- matrix(c(5, 5, 3, 4), nrow = 2, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = "standardize")

  # Should handle without error (sd = 1 for constant cols)
  expect_true(is.numeric(result$left))
  expect_true(all(is.finite(result$left)))
})

test_that("apply_scaling applies range scaling", {
  left <- matrix(c(0, 10, 0, 20), nrow = 2, ncol = 2)
  right <- matrix(c(5, 5, 10, 10), nrow = 2, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = "range")

  expect_equal(result$params$method, "range")
  expect_true("mins" %in% names(result$params))
  expect_true("maxs" %in% names(result$params))

  # Values should be in [0, 1]
  combined <- rbind(result$left, result$right)
  expect_true(all(combined >= 0))
  expect_true(all(combined <= 1))
})

test_that("apply_scaling applies minmax scaling (alias)", {
  left <- matrix(c(0, 100), nrow = 2, ncol = 1)
  right <- matrix(c(50, 50), nrow = 2, ncol = 1)

  result <- couplr:::apply_scaling(left, right, method = "minmax")

  expect_equal(result$params$method, "range")
})

test_that("apply_scaling handles constant columns in range", {
  left <- matrix(c(5, 5, 0, 10), nrow = 2, ncol = 2)  # First col constant
  right <- matrix(c(5, 5, 5, 5), nrow = 2, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = "range")

  expect_true(all(is.finite(result$left)))
})

test_that("apply_scaling applies robust scaling", {
  left <- matrix(c(1, 2, 3, 4, 100, 5, 6, 7, 8, 9), nrow = 5, ncol = 2)  # With outlier
  right <- matrix(c(10, 11, 12, 13, 14, 15, 16, 17, 18, 19), nrow = 5, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = "robust")

  expect_equal(result$params$method, "robust")
  expect_true("medians" %in% names(result$params))
  expect_true("mads" %in% names(result$params))
})

test_that("apply_scaling handles constant columns in robust", {
  left <- matrix(c(5, 5, 5, 1, 2, 3), nrow = 3, ncol = 2)  # First col constant
  right <- matrix(c(5, 5, 5, 4, 5, 6), nrow = 3, ncol = 2)

  result <- couplr:::apply_scaling(left, right, method = "robust")

  expect_true(all(is.finite(result$left)))
})

test_that("apply_scaling rejects unknown method", {
  left <- matrix(1:4, nrow = 2)
  right <- matrix(5:8, nrow = 2)

  expect_error(
    couplr:::apply_scaling(left, right, method = "unknown_method"),
    "Unknown scaling method"
  )
})

test_that("apply_scaling removes scale attributes", {
  left <- matrix(c(1, 2, 3, 4), nrow = 2)
  right <- matrix(c(5, 6, 7, 8), nrow = 2)

  result <- couplr:::apply_scaling(left, right, method = "standardize")

  expect_null(attr(result$left, "scaled:center"))
  expect_null(attr(result$left, "scaled:scale"))
  expect_null(attr(result$right, "scaled:center"))
  expect_null(attr(result$right, "scaled:scale"))
})

# ------------------------------------------------------------------------------
# apply_weights tests
# ------------------------------------------------------------------------------

test_that("apply_weights returns original when weights is NULL", {
  mat <- matrix(1:6, nrow = 2)

  result <- couplr:::apply_weights(mat, NULL)

  expect_equal(result, mat)
})

test_that("apply_weights returns original when all weights are 1", {
  mat <- matrix(1:6, nrow = 2)

  result <- couplr:::apply_weights(mat, c(1, 1, 1))

  expect_equal(result, mat)
})

test_that("apply_weights applies sqrt of weights", {
  mat <- matrix(c(1, 1, 1, 1), nrow = 2, ncol = 2)
  weights <- c(4, 9)  # sqrt(4) = 2, sqrt(9) = 3

  result <- couplr:::apply_weights(mat, weights)

  expect_equal(result[, 1], c(2, 2))  # 1 * sqrt(4)
  expect_equal(result[, 2], c(3, 3))  # 1 * sqrt(9)
})

test_that("apply_weights validates weight length", {
  mat <- matrix(1:6, nrow = 2, ncol = 3)
  weights <- c(1, 2)  # Wrong length

  expect_error(
    couplr:::apply_weights(mat, weights),
    "must match number of columns"
  )
})

# ------------------------------------------------------------------------------
# build_cost_matrix tests
# ------------------------------------------------------------------------------

test_that("build_cost_matrix integrates all components", {
  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.5, 2.5, 3.5), y = c(15, 25, 35))

  result <- couplr:::build_cost_matrix(left, right, vars = c("x", "y"),
                                        distance = "euclidean", scale = "standardize")

  expect_equal(dim(result), c(3, 3))
  expect_equal(attr(result, "distance"), "euclidean")
  expect_true(!is.null(attr(result, "scaling")))
})

test_that("build_cost_matrix works without scaling", {
  left <- data.frame(x = c(0, 3), y = c(0, 0))
  right <- data.frame(x = c(0, 0), y = c(4, 0))

  result <- couplr:::build_cost_matrix(left, right, vars = c("x", "y"),
                                        distance = "euclidean", scale = FALSE)

  expect_equal(result[1, 1], 4)  # (0,0) to (0,4)
  expect_null(attr(result, "scaling"))
})

test_that("build_cost_matrix applies weights", {
  left <- data.frame(x = c(0, 1), y = c(0, 1))
  right <- data.frame(x = c(1, 0), y = c(1, 0))

  # Weight x twice as much as y
  result <- couplr:::build_cost_matrix(left, right, vars = c("x", "y"),
                                        weights = c(x = 4, y = 1),
                                        distance = "euclidean", scale = FALSE)

  # With weights, x differences are multiplied by sqrt(4) = 2
  expect_true(is.numeric(result))
})