tests/testthat/utilities.R

In optmatch: Functions for Optimal Matching

# test whether two matches are the same. Uses all.equal on exceedances
# to ignore errors below some tolerance. After checking those, strips
# attributes that may differ but not break `identical` status.
# prices are often not the name, so it is often useful to ignore those
# other arguments passed to expect_equal
match_equal <- function(match1, match2, ignore.solver = TRUE, ignore.prices = TRUE, ...) {
  expect_true(all.equal(attr(match1, "exceedances"),
                        attr(match2, "exceedances")))

  attr(match1, "hashed.distance") <- NULL
  attr(match2, "hashed.distance") <- NULL
  attr(match1, "exceedances") <- NULL
  attr(match2, "exceedances") <- NULL
  attr(match1, "call") <- NULL
  attr(match2, "call") <- NULL
  if (!ignore.solver) {
    attr(match1, "solver") <- NULL
    attr(match2, "solver") <- NULL
  }

  if (ignore.prices) {
    attr(match1, "MCFSolutions")@nodes$price <- NULL
    attr(match2, "MCFSolutions")@nodes$price <- NULL
  }

  expect_equal(match1, match2, ...)
}

#' Similar to match_equal, but doesn't care about differences
#' among labels of matched sets.
match_equivalent <- function(match1, match2) {
  expect_true(all.equal(attr(match1, "exceedances"),
                        attr(match2, "exceedances")))

  attr(match1, "hashed.distance") <- NULL
  attr(match2, "hashed.distance") <- NULL
  attr(match1, "exceedances") <- NULL
  attr(match2, "exceedances") <- NULL
  attr(match1, "call") <- NULL
  attr(match2, "call") <- NULL

  m1labs <- as.character(match1[!is.na(match1) & !duplicated(match1)])
  levels(match1)[match(m1labs, levels(match1))] <- m1labs
  match1 <- factor(match1)

  m2labs <- as.character(match2[!is.na(match2) & !duplicated(match2)])
  levels(match2)[match(m2labs, levels(match2))] <- m2labs
  match2 <- factor(match2)

  expect_true(identical(match1, match2))
}