# test_galeshapley.R
# test matching with the Gale-Shapley Algorithm
test_that("Check if galeShapley.marriageMarket matching is stable", {
uM <- matrix(runif(12), nrow = 4, ncol = 3)
uW <- matrix(runif(12), nrow = 3, ncol = 4)
matching.marriageMarket <- galeShapley.marriageMarket(uM, uW)
expect_true(galeShapley.checkStability(uM, uW, matching.marriageMarket$proposals, matching.marriageMarket$engagements))
})
test_that("Check if galeShapley is an alias for galeShapley.marriageMarket", {
uM <- matrix(runif(12), nrow = 4, ncol = 3)
uW <- matrix(runif(12), nrow = 3, ncol = 4)
matching1 <- galeShapley(uM, uW)
matching2 <- galeShapley.marriageMarket(uM, uW)
expect_true(all.equal(matching1, matching2))
})
test_that("Check if galeShapley.collegeAdmissions matching is stable", {
uM <- matrix(runif(16), nrow = 2, ncol = 8)
uW <- matrix(runif(16), nrow = 8, ncol = 2)
matching <- galeShapley.collegeAdmissions(uM, uW, slots = 4)
expect_true(galeShapley.checkStability(uM, uW, matching$matched.students, matching$matched.colleges))
matching <- galeShapley.collegeAdmissions(uM, uW, slots = 8)
expect_true(galeShapley.checkStability(uM, uW, matching$matched.students, matching$matched.colleges))
matching <- galeShapley.collegeAdmissions(uM, uW, slots = 10)
expect_true(galeShapley.checkStability(uM, uW, matching$matched.students, matching$matched.colleges))
})
test_that("Check if college-optimal galeShapley.collegeAdmissions matching is stable", {
uM <- matrix(runif(6), nrow = 3, ncol = 2)
uW <- matrix(runif(6), nrow = 2, ncol = 3)
matching <- galeShapley.collegeAdmissions(uM, uW, slots = 2, studentOptimal = FALSE)
expect_true(galeShapley.checkStability(uW, uM, matching$matched.colleges, matching$matched.students))
})
test_that(
"Check if using preferences as inputs yields the same results as when using cardinal utilities as inputs",
{
uM <- matrix(runif(16 * 14), nrow = 14, ncol = 16)
uW <- matrix(runif(16 * 14), nrow = 16, ncol = 14)
matching1 <- galeShapley.marriageMarket(uM, uW)
matching2 <- galeShapley.marriageMarket(proposerPref = sortIndex(uM), reviewerPref = sortIndex(uW))
expect_true(all(matching1$engagements == matching2$engagements))
}
)
test_that(
"Check if using preferences as inputs with R indices yields the same results as when using cardinal utilities as inputs",
{
uM <- matrix(runif(16 * 14), nrow = 16, ncol = 14)
uW <- matrix(runif(16 * 14), nrow = 14, ncol = 16)
matching1 <- galeShapley.marriageMarket(uM, uW)
matching2 <- galeShapley.marriageMarket(proposerPref = sortIndex(uM) + 1, reviewerPref = sortIndex(uW) + 1)
expect_true(all.equal(matching1$engagements, matching2$engagements))
}
)
test_that("Check if incorrect preference orders result in an error", {
uM <- matrix(runif(16 * 14), nrow = 16, ncol = 14)
uW <- matrix(runif(16 * 14), nrow = 14, ncol = 16)
proposerPref <- sortIndex(uM) + 1
reviewerPref <- sortIndex(uW) + 1
proposerPrefPrime <- proposerPref
proposerPrefPrime[1, 1] <- 9999
reviewerPrefPrime <- reviewerPref
reviewerPrefPrime[1, 1] <- 9999
expect_error(
galeShapley.marriageMarket(proposerPref = proposerPrefPrime, reviewerPref = reviewerPref),
"proposerPref was defined by the user but is not a complete list of preference orderings"
)
expect_error(
galeShapley.marriageMarket(proposerPref = proposerPref, reviewerPref = reviewerPrefPrime),
"reviewerPref was defined by the user but is not a complete list of preference orderings"
)
})
test_that("Check validate function", {
# generate cardinal and ordinal preferences
uM <- matrix(runif(12), nrow = 4, ncol = 3)
uW <- matrix(runif(12), nrow = 4, ncol = 3)
prefM <- sortIndex(uM)
prefW <- sortIndex(uW)
# expect errors
expect_error(galeShapley.validate(proposerUtils = uM, reviewerUtils = uW))
expect_error(galeShapley.validate(proposerPref = prefM, reviewerPref = prefW))
# generate cardinal and ordinal preferences
uM <- matrix(runif(16), nrow = 4, ncol = 4)
uW <- matrix(runif(12), nrow = 4, ncol = 3)
prefM <- sortIndex(uM)
prefW <- sortIndex(uW)
# expect errors
expect_error(galeShapley.validate(proposerUtils = uM, reviewerUtils = uW))
expect_error(galeShapley.validate(proposerPref = prefM, reviewerPref = prefW))
})
test_that("Check null inputs", {
expect_error(
galeShapley.marriageMarket(),
"missing proposer preferences"
)
uM <- matrix(runif(16 * 14), nrow = 16, ncol = 14)
expect_error(
galeShapley.marriageMarket(uM),
"missing reviewer utilities"
)
expect_error(
galeShapley.marriageMarket(proposerPref = sortIndex(uM)),
"missing reviewer utilities"
)
})
test_that("Check if incorrect dimensions result in error", {
uM <- matrix(runif(16 * 14), nrow = 16, ncol = 14)
uW <- matrix(runif(15 * 15), nrow = 15, ncol = 15)
expect_error(galeShapley.marriageMarket(uM, uW))
expect_error(galeShapley.marriageMarket(proposerPref = sortIndex(uM), reviewerUtils = uW))
uM <- matrix(runif(16 * 16), nrow = 16, ncol = 16)
uW <- matrix(runif(15 * 16), nrow = 15, ncol = 16)
expect_error(galeShapley.marriageMarket(proposerPref = sortIndex(uM), reviewerUtils = uW))
})
test_that("Check outcome from galeShapley.marriageMarket matching", {
uM <- matrix(c(
0, 1,
1, 0,
0, 1
), nrow = 2, ncol = 3)
uW <- matrix(c(
0, 2, 1,
1, 0, 2
), nrow = 3, ncol = 2)
matching <- galeShapley.marriageMarket(uM, uW)
expect_true(all.equal(matching$engagements, matrix(c(2, 3), ncol = 1)))
expect_true(all.equal(matching$proposals, matrix(c(NA, 1, 2), ncol = 1)))
})
test_that("Check outcome from student-optimal galeShapley.collegeAdmissions matching", {
uM <- matrix(c(
0, 1,
1, 0,
0, 1
), nrow = 2, ncol = 3)
uW <- matrix(c(
0, 2, 1,
1, 0, 2
), nrow = 3, ncol = 2)
matching <- galeShapley.collegeAdmissions(uM, uW, slots = 2, studentOptimal = TRUE)
expect_true(all.equal(matching$matched.colleges, matrix(c(2, 3, NA, 1), ncol = 2)))
expect_true(all.equal(matching$matched.students, matrix(c(2, 1, 2), ncol = 1)))
})
test_that("Check outcome from collge-optimal galeShapley.collegeAdmissions matching", {
uM <- matrix(c(
0, 1,
1, 0,
0, 1
), nrow = 2, ncol = 3)
uW <- matrix(c(
0, 2, 1,
1, 0, 2
), nrow = 3, ncol = 2)
matching <- galeShapley.collegeAdmissions(uW, uM, slots = 2, studentOptimal = FALSE)
expect_true(all.equal(matching$matched.students, matrix(c(2, 3), ncol = 1)))
expect_true(all.equal(matching$matched.colleges, matrix(c(NA, NA, NA, NA, 1, 2), ncol = 2)))
})
test_that("Check checkStability", {
# define preferences
uM <- matrix(c(
0, 1,
1, 0,
0, 1
), nrow = 2, ncol = 3)
uW <- matrix(c(
0, 2, 1,
1, 0, 2
), nrow = 3, ncol = 2)
# define matchings (this one is correct)
matching <- list(
"engagements" = as.matrix(c(1, 2) + 1),
"proposals" = as.matrix(c(2, 0, 1) + 1)
)
# check if the matching is stable
expect_true(galeShapley.checkStability(uM, uW, matching$proposals, matching$engagements))
# swap proposals and engagements (this one isn't stable)
expect_false(suppressWarnings(galeShapley.checkStability(uM, uW, matching$engagements, matching$proposals)))
})
test_that("Assortative matching?", {
uM <- matrix(runif(16), nrow = 4, ncol = 4)
uW <- matrix(runif(16), nrow = 4, ncol = 4)
diag(uM)[] <- 2
diag(uW)[] <- 2
matching <- galeShapley.marriageMarket(uM, uW)
expect_true(all(matching$proposals == 1:4))
expect_true(all(matching$engagements == 1:4))
})
test_that("Marriage Market and College Admissions Problem Should Be Identical When Slots = 1", {
uM <- matrix(runif(12), nrow = 4, ncol = 3)
uW <- matrix(runif(12), nrow = 3, ncol = 4)
# student-optimal
matching.marriageMarket <- galeShapley.marriageMarket(uM, uW)
matching.collegeAdmissions <- galeShapley.collegeAdmissions(uM, uW, slots = 1, studentOptimal = TRUE)
expect_equal(matching.marriageMarket$proposals, matching.collegeAdmissions$matched.students)
expect_equal(matching.marriageMarket$engagements, matching.collegeAdmissions$matched.colleges)
expect_equal(matching.marriageMarket$single.proposers, matching.collegeAdmissions$unmatched.students)
expect_equal(matching.marriageMarket$single.reviewers, matching.collegeAdmissions$unmatched.colleges)
# college-optimal
matching.marriageMarket <- galeShapley.marriageMarket(uW, uM)
matching.collegeAdmissions <- galeShapley.collegeAdmissions(uM, uW, slots = 1, studentOptimal = FALSE)
expect_equal(matching.marriageMarket$proposals, matching.collegeAdmissions$matched.colleges)
expect_equal(matching.marriageMarket$engagements, matching.collegeAdmissions$matched.students)
expect_equal(matching.marriageMarket$single.proposers, matching.collegeAdmissions$unmatched.colleges)
expect_equal(matching.marriageMarket$single.reviewers, matching.collegeAdmissions$unmatched.students)
})
test_that("Check if galeShapley.collegeAdmissions matching returns the same results when the slots are constant across colleges", {
uM <- matrix(runif(16), nrow = 2, ncol = 8)
uW <- matrix(runif(16), nrow = 8, ncol = 2)
matching1 <- galeShapley.collegeAdmissions(uM, uW, slots = 4)
matching2 <- galeShapley.collegeAdmissions(uM, uW, slots = c(4, 4))
expect_true(identical(matching1, matching2))
})
test_that("Check student-optimal galeShapley.collegeAdmissions with different numbers of slots", {
# four students, two colleges, slots c(1,2)
uStudents <- matrix(runif(8), nrow = 2, ncol = 4)
uColleges <- matrix(runif(8), nrow = 4, ncol = 2)
matching1 <- galeShapley.collegeAdmissions(uStudents, uColleges, slots = c(1, 2))
# now, expand students and college preferences and use galeShapley() instead
uStudents <- rbind(uStudents[1, ], uStudents[2, ], uStudents[2, ])
uColleges <- cbind(uColleges[, 1], uColleges[, 2], uColleges[, 2])
matching2 <- galeShapley(uStudents, uColleges)
expect_true(all.equal(matching1$unmatched.students, matching2$single.proposers))
expect_equal(matching1$matched.colleges[[1]], matching2$engagements[1])
expect_equal(sort(matching1$matched.colleges[[2]]), sort(matching2$engagements[2:3]))
# college 3 gets mapped into college 2
matching2$proposals[matching2$proposals == 3] <- 2
expect_equal(matching1$matched.students, matching2$proposals)
})
test_that("Check college-optimal galeShapley.collegeAdmissions with different numbers of slots", {
# four students, two colleges, slots c(1,2)
uStudents <- matrix(runif(8), nrow = 2, ncol = 4)
uColleges <- matrix(runif(8), nrow = 4, ncol = 2)
matching1 <- galeShapley.collegeAdmissions(uStudents, uColleges, slots = c(1, 2), studentOptimal = FALSE)
# now, expand students and college preferences and use galeShapley() instead
uStudents <- rbind(uStudents[1, ], uStudents[2, ], uStudents[2, ])
uColleges <- cbind(uColleges[, 1], uColleges[, 2], uColleges[, 2])
matching2 <- galeShapley(uColleges, uStudents)
expect_true(all.equal(matching1$unmatched.students, matching2$single.reviewers))
expect_equal(matching1$matched.colleges[[1]], matching2$proposals[1])
expect_equal(sort(matching1$matched.colleges[[2]]), sort(matching2$proposals[2:3]))
# college 3 gets mapped into college 2
matching2$engagements[matching2$engagements == 3] <- 2
expect_equal(matching1$matched.students, matching2$engagements)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.