tests/testthat/test.caliper.R

In markmfredrickson/optmatch: Functions for Optimal Matching

################################################################################
# Caliper Tests
################################################################################

context("Caliper")

test_that("Caliper return values", {
  m <- matrix(c(1,Inf, 2, 3), nrow = 2, ncol = 2,
              dimnames = list(treated = c("A", "B"),
                              control = c("C", "D")))
  A <- as.InfinitySparseMatrix(m)

  # use the Mahalanobis distance match_on method
  result <- caliper(A, 2)
  expect_true(validDistanceSpecification(result))

  expect_equal(result@.Data, c(0,0))

  # make sure that matrix input does same thing
  expect_equivalent(caliper(A, 2), caliper(m, 2))

  # values option returns the value from the object directly
  expect_equivalent(caliper(A,2) + A, caliper(A, 2, values = T))
})

test_that("Caliper exclusion", {
  m <- matrix(c(3,Inf, 1, 3), nrow = 2, ncol = 2,
              dimnames = list(treated = c("A", "B"),
                              control = c("C", "D")))
  A <- as.InfinitySparseMatrix(m)

  # use the Mahalanobis distance match_on method
  result <- caliper(A, 2, exclude = c("B"))


  m2 <- matrix(c(Inf,Inf, 0, 0), nrow = 2, ncol = 2,
              dimnames = list(treated = c("A", "B"),
                              control = c("C", "D")))

  expect_equal(as.matrix(result), m2)

})

test_that("Caliper respects groups", {

  # set up the exact match
  Z <- rep(c(T,F), each = 4)
  names(Z) <- c(LETTERS[1:4], letters[23:26])
  B <- c(T,T,F,F,T,T,F,F)
  em <- exactMatch(Z ~ B)

  expect_equal(length(findSubproblems(em)), 2)

  expect_equal(length(findSubproblems(caliper(em, 2))), 2)
  # f <- function(d) { fullmatch(d, min.controls = 1, omit.fraction = 0.75)}

  # expect_equal(sum(is.na(f(m))), 8) # should fail entirely
  # expect_equal(sum(is.na(f(em))), 0) # everything should work within strata

  # here is the real test, can we combine the two to firewall the failure?
  # expect_equal(sum(is.na(f(m + em))), 4)
})


test_that("update() caliper objects", {
  Z <- rep(c(0,1), each = 10)
  S <- rep(1:10 * 2, 2)
  names(Z) <- names(S) <- letters[1:20]

  basic <- caliper(match_on(S, z = Z), 2)
  expect_equal(length(basic), 28)

  S <- rep(1:10 * 3, 2)
  names(S) <- letters[1:20]
  updated <- update(basic)
  expect_equal(length(updated), 10)
})