Nothing
################################################################################
# Tests for the optmatch object and basic methods
################################################################################
context("Optmatch object")
test_that("Object creation", {
dist <- diag(5)
dimnames(dist) <- list(letters[1:5], letters[6:10])
# recreate the result of running fullmatch. Must have err and cells fields
ms <- list(
list(err = 0, cells = c(a = 1, f = 1, b = 2, g = 2)),
list(err = 0, cells = c(c = 1, h = 1, d = 2, i = 2, e = 3, j = 3)))
res.opt <- makeOptmatch(dist, ms, NULL)
expect_equal(length(res.opt), 10)
expect_is(res.opt, "factor")
expect_is(res.opt, "optmatch")
# two levels of matches shouldn't be 1.NA, 2.NA, should just be NA
ms2 <- list(
list(err = 0, cells = c(a = 1, f = 1, b = 1, g = NA)),
list(err = 0, cells = c(c = 1, h = 1, d = 2, i = 2, e = 2, j = NA)))
res.opt2 <- makeOptmatch(dist, ms2, NULL)
expect_true(all(is.na(res.opt2[c("g", "j")])))
})
test_that("Object subsetting", {
dist <- diag(5)
dimnames(dist) <- list(letters[1:5], letters[6:10])
ms <- list(list(err = 0, cells = c(a = 1, f = 1, b = 2, g = 2)),
list(err = 0, cells = c(c = 1, h = 1, d = 2, i = 2, e = 3, j = 3)))
res.opt <- makeOptmatch(dist, ms, NULL)
expect_equal(names(res.opt[1:4]), c("a", "f", "b", "g"))
expect_equal(length(res.opt[c("a", "b")]), 2)
})
test_that("Subsetting preserves subproblem", {
data(nuclearplants)
# 1 subproblem
f <- fullmatch(pr ~ cost, data=nuclearplants)
ssf <- f[25:28]
spssf <- attr(ssf, "subproblem")
expect_true(all(spssf == attr(f, "subproblem")[25:28]))
expect_true(all.equal(names(spssf),names(ssf)))
# 2 subproblems
f <- fullmatch(pr ~ cost, within=exactMatch(pr ~ pt, data=nuclearplants), data=nuclearplants)
ssf <- f[25:28]
spssf <- attr(ssf, "subproblem")
expect_true(all(spssf == attr(f, "subproblem")[25:28]))
expect_true(all.equal(names(spssf),names(ssf)))
# no subproblems
f <- fullmatch(pr ~ cost, data=nuclearplants)
attr(f, "subproblem") <- NULL
ssf <- f[25:28]
spssf <- attr(ssf, "subproblem")
expect_true(is.null(spssf))
})
test_that("Matched distances", {
# see R/matched.distances.R for the function
# it is only called by makeOptmatch internally, so putting the tests here
# start with an easy case:
dist <- matrix(Inf, nrow = 5, ncol = 5)
diag(dist) <- 1:5
dimnames(dist) <- list(letters[1:5], letters[6:10])
dist.match <- as.factor(c(1.1,1.1,1.2,1.2,2.1,2.1,2.2,2.2,2.3,2.3))
names(dist.match) <- c("a","f","b","g","c","h","d","i","e","j")
class(dist.match) <- c("optmatch", "factor")
res.md <- matched.distances(dist.match, dist)
expect_equivalent(as.vector(res.md), 1:5)
# now an ISM version
dist.i <- as.InfinitySparseMatrix(dist)
res.mdi <- matched.distances(dist.match, dist.i)
expect_equivalent(as.vector(res.mdi), 1:5)
# proper names
res.names <- matched.distances(dist.match, dist, preserve.unit.names = TRUE)
expect_equal(names(res.names), c("1.1", "1.2", "2.1", "2.2", "2.3"))
res.names.i <- matched.distances(dist.match, dist.i, preserve.unit.names = TRUE)
expect_equal(names(res.names.i), c("1.1", "1.2", "2.1", "2.2", "2.3"))
# matches with more than one item in a strata
match.multiple <- as.factor(c(1.1,1.1,NA,1.1,2.1,2.1,2.2,2.2,2.3,2.3))
names(match.multiple) <- c("a","f","b","g","c","h","d","i","e","j")
class(match.multiple) <- c("optmatch", "factor")
dist.multiple <- dist
dist.multiple["a", "g"] <- 99
res.multiple <- matched.distances(match.multiple, dist.multiple, preserve.unit.names = T)
expect_equal(length(res.multiple), 4) # 4 matches, four item list
expect_equal(as.vector(unlist(res.multiple)), c(1, 99, 3, 4, 5))
expect_equal(as.vector(unlist(lapply(res.multiple, names))), c("f", "g", "h", "i", "j"))
})
test_that("Subsetting drops any matched.distances attributes", {
data(nuclearplants)
f1 <- fullmatch(glm(pr ~ t1 + ne, data=nuclearplants, family=binomial),
within=exactMatch(pr ~ ne, data=nuclearplants),
data=nuclearplants)
expect_true(is.null(attr(f1, "matched.distances")))
# Add the attribute (because it is no longer created by default)
attr(f1, "matched.distances") <- runif(length(levels(f1)))
expect_true(!is.null(attr(f1, "matched.distances")))
f2 <- f1[1:10]
f3 <- f1[1:10, drop=TRUE]
expect_true(is.null(attr(f2, "matched.distances")))
expect_true(is.null(attr(f3, "matched.distances")))
})
test_that("Summary properly handles matched.distances #106", {
data(nuclearplants)
dist <- match_on(glm(pr~.-(pr+cost), family=binomial(),
data=nuclearplants))
pm <- pairmatch(dist, data=nuclearplants)
s1 <- summary(pm)
expect_true(is.null(s1$total.distance))
# if we add matched.distances in manually, should re-appear in
# summary.
attr(pm, "matched.distances") <- matched.distances(pm, dist)
s2 <- summary(pm)
expect_true(!is.null(s2$total.distance))
expect_true(!is.null(s2$total.tolerance))
expect_true(!is.null(s2$matched.dist.quantiles))
# Double check that the match isn't getting affected.
expect_identical(s1$thematch[sort(names(s1$thematch))], s2$thematch[sort(names(s2$thematch))])
})
test_that("Match carries info about subproblems", {
Z <- rep(c(0,1), 8)
B <- as.factor(rep(c(1,2), each = 8))
names(Z) <- names(B) <- letters[1:16]
match <- pairmatch(exactMatch(Z ~ B), data = Z) # assure data order by passing Z
# subproblem attribute should be a factor indicating which group each item maps to
expect_equal(class(attr(match, "subproblem"))[1], "factor")
expect_equal(length(match), length(attr(match, "subproblem")))
expect_equivalent(B, attr(match, "subproblem"))
})
test_that("Indicating failing subproblems", {
Z <- rep(c(0,1), 8)
B <- as.factor(rep(c(1,2), each = 8))
names(Z) <- names(B) <- letters[1:16]
match <- pairmatch(exactMatch(Z ~ B), data = Z) # assure data order by passing Z
spS <- subproblemSuccess(match)
mf <- matchfailed(match)
expect_equal(sum(spS), 2)
expect_true(all(names(spS) %in% c("1", "2")))
expect_is(mf, "logical")
expect_length(mf, length(B))
expect_true(all(mf == FALSE))
Z[1] <- 1
match <- pairmatch(exactMatch(Z ~ B), data = Z)
spS <- subproblemSuccess(match)
mf <- matchfailed(match)
expect_equal(sum(spS), 2)
expect_true(all(names(spS) %in% c("1", "2")))
expect_is(mf, "logical")
expect_length(mf, length(B))
expect_true(all(mf == FALSE))
data(nuclearplants)
expect_warning(f1 <- fullmatch(pr ~ t1, data = nuclearplants,
min = 5, max = 5))
spS <- subproblemSuccess(f1)
mf <- matchfailed(f1)
expect_true(all(spS == FALSE))
expect_equal(names(spS), "1")
expect_is(mf, "logical")
expect_length(mf, nrow(nuclearplants))
expect_true(all(mf == TRUE))
expect_warning(f2 <-
fullmatch(pr ~ t1, data = nuclearplants,
min = 5, max = 5,
within =
exactMatch(pr ~ pt,
data = nuclearplants)))
spS <- subproblemSuccess(f2)
mf <- matchfailed(f2)
expect_true(all(spS == FALSE))
expect_is(mf, "logical")
expect_length(mf, nrow(nuclearplants))
expect_true(all(mf == TRUE))
expect_warning(f3 <-
fullmatch(pr ~ cost, data = nuclearplants,
min = 60, max = 60,
within =
exactMatch(pr ~ pt,
data = nuclearplants)))
spS <- subproblemSuccess(f3)
mf <- matchfailed(f3)
expect_true(all(spS == FALSE))
expect_is(mf, "logical")
expect_length(mf, nrow(nuclearplants))
expect_true(all(mf == TRUE))
})
test_that("optmatch_restrictions", {
d <- data.frame(Z = c(1,0,0,0,0,1,0,0),
B = rep(c('a', 'b'), times=c(5, 3)))
res.b <- exactMatch(Z ~ B, data=d)
f <- fullmatch(res.b, data=d)
o <- optmatch_restrictions(f)
expect_true(all(o$min.controls == 0))
expect_true(all(o$max.controls == Inf))
expect_true(all(is.na(o$omit.fraction)))
expect_true(all(is.null(o$mean.controls)))
f <- fullmatch(res.b, data=d, mean.controls = 1)
o <- optmatch_restrictions(f)
expect_true(all(o$min.controls == 0))
expect_true(all(o$max.controls == Inf))
expect_true(all(is.null(o$omit.fraction)))
expect_true(all(o$mean.controls == 1))
f <- fullmatch(res.b, data=d, mean.controls = 1, max.controls=c(1,2), min.controls=c(1, 1/2))
o <- optmatch_restrictions(f)
expect_true(all(o$min.controls == c(1, 1/2)))
expect_true(all(o$max.controls == c(1,2)))
expect_true(all(is.null(o$omit.fraction)))
expect_true(all(o$mean.controls == 1))
expect_true(all(names(o$min.controls) == c('a','b')))
expect_true(all(names(o$max.controls) == c('a','b')))
expect_true(all(names(o$mean.controls) == c('a','b')))
options("optmatch_verbose_messaging" = TRUE)
expect_warning(f <- fullmatch(res.b, data=d, max.controls=1),
"infeasible")
o <- optmatch_restrictions(f)
expect_true(all(o$min.controls == 0))
expect_true(all(o$max.controls == 1))
expect_true(all(o$omit.fraction == c(3/4, 1/2)))
expect_true(all(is.null(o$mean.controls)))
})
test_that("optmatch_same_distance", {
d <- data.frame(Z = c(1,0,0,0,0,1,0,0),
B = rep(c('a', 'b'), times=c(5, 3)))
res.b <- exactMatch(Z ~ B, data=d)
res.b2 <- res.b
res.b2@.Data[1] <- 1
f1 <- fullmatch(res.b, data=d)
f2 <- fullmatch(res.b2, data=d)
options("optmatch_verbose_messaging" = TRUE)
expect_warning(f3 <- fullmatch(res.b, data=d, max.controls=1),
"infeasible")
expect_true(optmatch_same_distance(f1, res.b))
expect_true(optmatch_same_distance(res.b, f1))
expect_true(optmatch_same_distance(f2, res.b2))
expect_true(optmatch_same_distance(res.b2, f2))
expect_true(optmatch_same_distance(f3, res.b))
expect_true(optmatch_same_distance(res.b, f3))
expect_true(!optmatch_same_distance(f1, res.b2))
expect_true(!optmatch_same_distance(f2, res.b))
expect_true(!optmatch_same_distance(f3, res.b2))
expect_true(optmatch_same_distance(f1, f3))
expect_true(!optmatch_same_distance(f1, f2))
expect_true(optmatch_same_distance(res.b, res.b))
expect_error(optmatch_same_distance(f1, as.matrix(res.b)), "both arguments")
})
test_that("update.optmatch basics", {
d <- data.frame(z = rep(0:1, each = 50),
b = rnorm(100))
# update without arguments shouldn't change anything
f1 <- fullmatch(z ~ b, data = d)
expect_is(update(f1), "optmatch")
expect_true(identical(f1, update(f1)))
})
test_that("update without changing distance", {
options("optmatch_verbose_messaging" = FALSE)
d <- data.frame(z = rep(0:1, each = 50),
b = rnorm(100))
f1 <- fullmatch(z ~ b, data = d)
f2 <- fullmatch(z ~ b, data = d, max.controls = 2)
f3 <- fullmatch(z ~ b, data = d, max.controls = 1)
f4 <- fullmatch(z ~ b, data = d, max.controls = 1,
min.controls = 1)
f5 <- fullmatch(z ~ b, data = d, omit.fraction = 1/7)
f6 <- fullmatch(z ~ b, data = d, mean.controls = 1)
f7 <- fullmatch(z ~ b, data = d, tol = .00001)
expect_true(identical(f2, update(f1, max.controls = 2)))
expect_true(identical(f3, update(f1, max.controls = 1)))
expect_true(identical(f4, update(f1, max.controls = 1,
min.controls = 1)))
expect_true(identical(f5, update(f1, omit.fraction = 1/7)))
expect_true(identical(f6, update(f1, mean.controls = 1)))
expect_true(identical(f7, update(f1, tol = .00001)))
})
test_that("upadate passing a different distance as x argument", {
options("optmatch_verbose_messaging" = FALSE)
# passing a difference distance
set.seed(9876)
d1 <- data.frame(x = rnorm(10),
y = runif(10),
z = c(rep(0,6), rep(1,4)))
res.b1 <- match_on(z ~ x, data = d1)
res.b2 <- match_on(z ~ y, data = d1)
f1 <- fullmatch(res.b1, data = d1)
f2 <- fullmatch(res.b2, data = d1)
expect_true(!identical(as.vector(f1),as.vector(f2)))
# When verbose messaging is off, this should produce no distance warning
options("optmatch_verbose_messaging" = FALSE)
u1 <- update(f2, x = res.b1)
u2 <- update(f1, x = res.b2)
expect_true(identical(f1,u1))
expect_true(identical(f2,u2))
expect_true(!identical(f2,u1))
expect_true(!identical(as.vector(f2),as.vector(u1)))
# If verbose messaing is enabled, should produce warning
options("optmatch_verbose_messaging" = TRUE)
expect_warning(update(f2, x = res.b1), "different than distance")
expect_warning(update(f1, x = res.b2), "different than distance")
options("optmatch_verbose_messaging" = FALSE)
# ensure changing distance + other arguments works
f3 <- fullmatch(res.b1, data = d1, max.controls = 2)
u3a <- update(f1, max.controls = 2)
u3b <- update(f2, x = res.b1, max.controls = 2)
expect_true(identical(f3, u3a))
expect_true(identical(f3, u3b))
})
test_that("update when distance is changed outside of update", {
options("optmatch_verbose_messaging" = FALSE)
set.seed(9876)
d1 <- data.frame(x = rnorm(10),
y = runif(10),
z = c(rep(0,6), rep(1,4)))
res.c <- match_on(z ~ x, data = d1)
fc <- fullmatch(res.c, data = d1)
res.c <- match_on(z ~ y, data = d1)
uc <- update(fc, x = res.c)
expect_true(!identical(as.vector(fc), as.vector(uc)))
# verbose should produce warning
options("optmatch_verbose_messaging" = TRUE)
expect_warning(update(fc, x = res.c), "different than distance")
})
test_that("Update arguments change be ordered differently", {
options("optmatch_verbose_messaging" = FALSE)
set.seed(9876)
d1 <- data.frame(x = rnorm(10),
y = runif(10),
z = c(rep(0,6), rep(1,4)))
res.c <- match_on(z ~ y, data = d1)
# odd ordering of parameters
fo <- fullmatch(data = d1, x = res.c)
uo <- update(fo, max.controls = 2)
fo <- fullmatch(data = d1, x = res.c, max.controls = 2)
expect_true(identical(fo, uo))
})
test_that("Update supporting new formula", {
data(nuclearplants)
f1 <- fullmatch(pr ~ cost, data = nuclearplants)
f2 <- fullmatch(pr ~ t1, data = nuclearplants)
options("optmatch_verbose_messaging" = FALSE)
expect_error(update(f2, pr ~ cost), "must be named")
f3 <- update(f2, x = pr ~ cost)
expect_identical(f1, f3)
expect_identical(update(f1, x = pr ~ cost + t1),
update(f2, x = pr ~ cost + t1))
})
test_that("update warning for implicit distance changes", {
data("nuclearplants")
p <- pairmatch(pr ~ cap, data = nuclearplants)
# Calipering
expect_warning(expect_is(up <- update(p, caliper = 1.5),
"optmatch"),
"different than distance")
pcal <- pairmatch(pr ~ cap, data = nuclearplants, caliper = 1.5)
expect_identical(up, pcal)
# Within
em <- exactMatch(pr ~ pt, data = nuclearplants)
expect_warning(uem <- update(p, within = em),
"different than distance")
pe <- pairmatch(pr ~ cap, data = nuclearplants, within = em)
expect_identical(pe, uem)
})
test_that("update producing errors properly", {
data(nuclearplants)
f <- fullmatch(pr ~ cost, data = nuclearplants)
call <- attr(f, "call")
attr(f, "call") <- NULL
expect_error(update(f), "must have a call")
attr(f, "call") <- 7
expect_error(update(f), "not a valid")
attr(f, "call") <- list(call, call)
expect_error(update(f), "combined optmatch")
})
test_that("num_eligible_matches", {
options("optmatch_verbose_messaging" = TRUE)
a <- matrix(rep(0,9), nrow=3)
class(a) <- c("DenseMatrix", class(a))
expect_true(num_eligible_matches(a) == 9)
a[1] <- Inf
expect_true(num_eligible_matches(a) == 8)
b <- makeInfinitySparseMatrix(1:4,
rows=c(1L,1L,2L,3L),
cols=c(1L,2L,3L,3L),
dimension=c(3L,3L),
colnames=letters[1:3],
rownames=LETTERS[1:3])
expect_true(num_eligible_matches(b) == 4)
c <- b
c[1] <- Inf
expect_true(num_eligible_matches(c) == 3)
d <- as(b, "BlockedInfinitySparseMatrix")
d@groups <- factor(c("cat","cat","dog","cat","cat","dog"))
names(d@groups) <- c(LETTERS[1:3], letters[1:3])
nem <- num_eligible_matches(d)
expect_equal(names(nem), c("cat", "dog"))
expect_equal(nem[[1]], 3)
expect_equal(nem[[2]], 1)
expect_true(num_eligible_matches.InfinitySparseMatrix(d) == 4)
expect_true(num_eligible_matches(as.InfinitySparseMatrix(d)) == 4)
e <- d
e[1] <- Inf
nem <- num_eligible_matches(e)
expect_equal(names(nem), c("cat", "dog"))
expect_equal(nem[[1]], 2)
expect_equal(nem[[2]], 1)
expect_true(num_eligible_matches.InfinitySparseMatrix(e) == 3)
expect_true(num_eligible_matches(as.InfinitySparseMatrix(e)) == 3)
d <- matrix(rep(1:2, 10), 10, 2)
d <- caliper(d, 1.5)
expect_true(num_eligible_matches(d) == 10)
})
test_that("equality of matches", {
data(nuclearplants)
# Truly identical matches
f1 <- fullmatch(pr ~ cost, data=nuclearplants)
f2 <- fullmatch(pr ~ cost, data=nuclearplants)
expect_true(compare_optmatch(f1, f2))
# Completely different matched
data(plantdist)
expect_warning(p1 <- fullmatch(plantdist), "Without \'data\'")
expect_false(compare_optmatch(p1,f1))
# Same match, different call
f3 <- fullmatch(pr ~ cost, data=nuclearplants, max=100)
expect_true(compare_optmatch(f1, f3))
# Matches with unmatched objects
expect_warning(f4 <- fullmatch(pr ~ cost, data=nuclearplants, max=1), "infeasible")
expect_warning(f5 <- fullmatch(pr ~ cost, data=nuclearplants, max=1, min=1), "infeasible")
expect_true(compare_optmatch(f4,f5))
# Make sure its not returning true for everything!
expect_false(compare_optmatch(f1,f4))
expect_false(compare_optmatch(f3,f5))
# Re-ordering
nuclearplants2 <- nuclearplants[sample(seq_len(nrow(nuclearplants))),]
f6 <- fullmatch(pr ~ cost, data=nuclearplants2)
# f1, f2, f6 are all the same, but f6 has a different order
expect_true(all(f1 == f2))
expect_false(all(f1 == f6))
# But compare_optmatch doesn't care!
expect_true(compare_optmatch(f1, f6))
# Try with blocked
b1 <- fullmatch(pr ~ cost, data=nuclearplants, within=exactMatch(pr ~ ne, data=nuclearplants))
nuclearplants$ne2 <- 1 - nuclearplants$ne
b2 <- fullmatch(pr ~ cost, data=nuclearplants, within=exactMatch(pr ~ ne2, data=nuclearplants))
expect_error(all(b1 == b2), "sets of factors are different")
# But compare_optmatch doesn't care!
expect_true(compare_optmatch(b1, b2))
# Make some wonky observation names
row.names(nuclearplants) <-
vapply(seq_len(nrow(nuclearplants)),
function(x) {
paste0(sample(strsplit("!@#$%^&*()_+1234567890asdfghjkl",
"")[[1]], 10, TRUE),
collapse="")
}, character(1)
)
w1 <- fullmatch(pr ~ cost, data=nuclearplants)
w2 <- fullmatch(pr ~ cost, data=nuclearplants, max=10)
expect_true(compare_optmatch(w1,w2))
wb1 <- fullmatch(pr ~ cost, data=nuclearplants, within=exactMatch(pr ~ ne, data=nuclearplants))
wb2 <- fullmatch(pr ~ cost, data=nuclearplants, within=exactMatch(pr ~ ne2, data=nuclearplants))
expect_error(all(wb1 == wb2), "sets of factors are different")
# But compare_optmatch doesn't care!
expect_true(compare_optmatch(wb1, wb2))
# If we drop NA members, should be the same match
f4_dropna<- f4[!is.na(f4)]
expect_true(compare_optmatch(f4, f4_dropna))
# The problem that motivated this function: Two matches are identical, except one has an extra NA
f4b <- f4
f4b[1] <- NA
# This doesn't catch it!
expect_true(all(f4 == f4b, na.rm=TRUE))
# This does!
expect_false(compare_optmatch(f4, f4b))
# Differing names should always be false.
f1b <- f1
names(f1b)[1] <- "Z"
expect_false(compare_optmatch(f1, f1b))
f1c <- f1
names(f1c)[1] <- "A"
expect_false(compare_optmatch(f1, f1c))
## # Saving this to test time.
## n <- 20000
## s1 <- as.factor(sample(letters, n, TRUE))
## names(s1) <- sample(LETTERS, n, TRUE)
## s2 <- s1[sample(seq_along(s1), n, TRUE)]
## system.time(compare_optmatch(s1,s2))
## # Taking about .3sec on laptop.
})
test_that("combining optmatch objects", {
data(nuclearplants)
f1 <- fullmatch(pr ~ t1, data = nuclearplants[nuclearplants$pt == 0,])
expect_is(c(f1), "optmatch")
f2 <- fullmatch(pr ~ t1, data = nuclearplants[nuclearplants$pt == 1,])
fc <- c(f1, f2)
expect_equal(length(fc), length(f1) + length(f2))
for (a in c("subproblem", "contrast.group", "levels")) {
expect_equal(length(attr(fc, a)),
length(attr(f1, a)) + length(attr(f2, a)))
}
expect_is(attr(fc, "hashed.distance"), "list")
expect_length(attr(fc, "hashed.distance"), 2)
expect_is(attr(fc, "call"), "list")
expect_length(attr(fc, "call"), 2)
for (a in c("min.controls", "max.controls", "omit.fraction", "exceedances")) {
expect_is(attr(fc, a), "numeric")
expect_length(attr(fc, a), 2)
expect_equivalent(attr(fc, a)[1], attr(f1, a))
expect_equivalent(attr(fc, a)[2], attr(f2, a))
}
expect_error(c(f1, f1), "duplicated")
full <- fullmatch(pr ~ t1, data = nuclearplants,
within = exactMatch(pr ~ pt, data = nuclearplants))
expect_true(compare_optmatch(fc, full))
levels(full) <- levels(fc)
expect_equivalent(full, fc)
p1 <- pairmatch(pr ~ t1, data = nuclearplants[nuclearplants$pt == 0,])
expect_is(c(p1), "optmatch")
p2 <- pairmatch(pr ~ t1, data = nuclearplants[nuclearplants$pt == 1,])
pc <- c(p1, p2)
expect_equal(length(pc), length(p1) + length(p2))
for (a in c("subproblem", "contrast.group", "levels")) {
expect_equal(length(attr(pc, a)),
length(attr(p1, a)) + length(attr(p2, a)))
}
expect_error(c(p1, p1), "duplicated")
expect_identical(is.na(p1), is.na(pc)[1:26])
expect_identical(is.na(p2), is.na(pc)[27:32])
f1 <- fullmatch(pr ~ t1, data = nuclearplants[1:10,])
f2 <- fullmatch(pr ~ t1, data = nuclearplants[11:25,])
f3 <- fullmatch(pr ~ t1, data = nuclearplants[26:32,])
fc <- c(f1, f2, f3)
expect_is(fc, "optmatch")
expect_equal(length(fc), length(f1) + length(f2) + length(f3))
for (a in c("subproblem", "contrast.group", "levels")) {
expect_equal(length(attr(fc, a)),
length(attr(f1, a)) + length(attr(f2, a)) +
length(attr(f3, a)))
}
expect_is(attr(fc, "hashed.distance"), "list")
expect_length(attr(fc, "hashed.distance"), 3)
expect_is(attr(fc, "call"), "list")
expect_length(attr(fc, "call"), 3)
for (a in c("min.controls", "max.controls", "omit.fraction", "exceedances")) {
expect_is(attr(fc, a), "numeric")
expect_length(attr(fc, a), 3)
expect_equivalent(attr(fc, a)[1], attr(f1, a))
expect_equivalent(attr(fc, a)[2], attr(f2, a))
expect_equivalent(attr(fc, a)[3], attr(f3, a))
}
# Min, Max, etc carry forward properly
options("optmatch_verbose_messaging" = FALSE)
f1 <- fullmatch(pr ~ t1, data = nuclearplants[1:25,],
min = 1, max = 2)
f2 <- fullmatch(pr ~ t1, data = nuclearplants[26:32,],
max = 3, omit.fraction = .1)
fc <- c(f1, f2)
expect_equivalent(attr(fc, "max.controls"),
c(attr(f1, "max.controls"),
attr(f2, "max.controls")))
expect_equivalent(attr(fc, "min.controls"),
c(attr(f1, "min.controls"),
attr(f2, "min.controls")))
expect_equivalent(attr(fc, "omit.fraction"),
c(attr(f1, "omit.fraction"),
attr(f2, "omit.fraction")))
# Functions taking optmatch objects
f1 <- fullmatch(pr ~ t1, data = nuclearplants[1:25,],
min = 1, max = 2)
f2 <- fullmatch(pr ~ t1, data = nuclearplants[26:32,],
min = 1, max = 2)
fc <- c(f1, f2)
nuclearplants$treat <- rep(0:1, times = c(25, 7))
full <- fullmatch(pr ~ t1, data = nuclearplants, min = 1, max = 2,
within = exactMatch(pr ~ treat, data = nuclearplants))
expect_identical(matched(fc), matched(full))
expect_identical(optmatch_restrictions(fc), optmatch_restrictions(full))
expect_identical(stratumStructure(fc), stratumStructure(full))
expect_identical(summary(fc)$effective.sample.size,
summary(full)$effective.sample.size)
expect_identical(summary(fc)$matched.set.structures,
summary(full)$matched.set.structures)
# Suppress output, but will error
expect_silent(invisible(capture.output(print(fc))))
expect_silent(invisible(capture.output(print(fc, quote = TRUE))))
expect_silent(invisible(capture.output(print(fc, grouped = TRUE))))
expect_output(print(fc), "0.1.1")
expect_output(print(fc), "1.1.1")
expect_output(print(fc, grouped = TRUE), "0.1.1")
expect_output(print(fc, grouped = TRUE), "1.1.1")
expect_output(print(fc, grouped = TRUE), "Members")
})
test_that("combining already blocked matches", {
data("nuclearplants")
nuclearplants$z <- rep(0:2, times = c(15,10,7))
f1 <- fullmatch(pr ~ t1, data = nuclearplants[nuclearplants$z == 0,])
f2 <- fullmatch(pr ~ t1, data = nuclearplants[nuclearplants$z != 0,],
within = exactMatch(pr ~ z, data = nuclearplants))
fc <- c(f1, f2)
full <- fullmatch(pr ~ t1, data = nuclearplants,
within = exactMatch(pr ~ z, data = nuclearplants))
# There are a few matches with equivalent mincost solutions, so just ensure
# total matched distance is equivalent.
expect_true(all.equal(
sum(Reduce(c, matched.distances(fc,
match_on(pr ~ t1,
data = nuclearplants,
within =
exactMatch(pr ~ z,
data = nuclearplants))))),
sum(Reduce(c, matched.distances(full,
match_on(pr ~ t1,
data = nuclearplants,
within =
exactMatch(pr ~ z,
data = nuclearplants)))))
))
expect_identical(matched(fc), matched(full))
expect_equivalent(attr(fc, "max.controls"),
attr(full, "max.controls"))
expect_equivalent(attr(fc, "min.controls"),
attr(full, "min.controls"))
expect_equivalent(attr(fc, "omit.fraction"),
attr(full, "omit.fraction"))
expect_equivalent(attr(fc, "exceedances"),
c(attr(f1, "exceedances"),
attr(f2, "exceedances")))
expect_identical(stratumStructure(fc), stratumStructure(full))
expect_identical(summary(fc)$effective.sample.size,
summary(full)$effective.sample.size)
expect_identical(summary(fc)$matched.set.structures,
summary(full)$matched.set.structures)
})
test_that("handleSolver", {
# Input: ""
s <- handleSolver("")
if (requireNamespace("rrelaxiv", quietly = TRUE)) {
expect_equal(s, "RELAX-IV")
} else {
expect_equal(s, LEMON())
}
# Input: "RELAX-IV"
if (requireNamespace("rrelaxiv", quietly = TRUE)) {
s <- handleSolver("RELAX-IV")
expect_equal(s, "RELAX-IV")
} else {
expect_error(handleSolver("RELAX-IV"),
"install package")
}
# Input: "LEMON"
s <- handleSolver("LEMON")
expect_equal(s, LEMON())
# INPUT: LEMON(...)
s <- handleSolver(LEMON("CycleCancelling"))
expect_equal(s, LEMON("CycleCancelling"))
s <- handleSolver(LEMON("CostScaling"))
expect_equal(s, LEMON("CostScaling"))
s <- handleSolver(LEMON("CapacityScaling"))
expect_equal(s, LEMON("CapacityScaling"))
s <- handleSolver(LEMON("NetworkSimplex"))
expect_equal(s, LEMON("NetworkSimplex"))
expect_error(handleSolver("ABC"), "Invalid solver")
expect_error(handleSolver(123), "Invalid solver")
expect_error(handleSolver(ls()), "Invalid solver")
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.