#175; expanded tests and fixed subproblemSuccess/matchfailed

markmfredrickson · Jul 11, 2019 · d0998b7 · d0998b7
1 parent 7705ccd
commit d0998b7
Show file tree

Hide file tree

Showing 3 changed files with 64 additions and 11 deletions.
diff --git a/R/fullmatch.R b/R/fullmatch.R
@@ -593,17 +593,11 @@ fullmatch.matrix <- function(x,
   attr(mout, "call") <- cl
 
 
-  ### Due to a bug in `subproblemSuccess` (#175) we need
-  ### to manually check for failure here.
-  #if (all(isFALSE(subproblemSuccess(mout)))) {
-  grps <- attr(mout, "subproblem")
-  failed <- sapply(split(mout, grps), function(x) { all(is.na(x) | grepl("\\.NA$", x)) })
-  if (all(failed)) {
+  if (all(subproblemSuccess(mout) == FALSE)) {
     warning(paste("Matching failed.",
                   "(Restrictions impossible to meet?)\n",
                   "Enter ?matchfailed for more info."))
-  #} else if (any(isFALSE(subproblemSuccess(mout)))) {
-  } else if (any(failed)) {
+  } else if (any(subproblemSuccess(mout) == FALSE)) {
     warning(paste("At least one subproblem matching failed.\n",
                   "(Restrictions impossible to meet?)\n",
                   "Enter ?matchfailed for more info."))

diff --git a/R/matchfailed.R b/R/matchfailed.R
@@ -20,6 +20,8 @@ matchfailed <- function(x) {
 #' @keywords internal
 subproblemSuccess <- function(x) {
   grps <- attr(x, "subproblem")
-  failed <- sapply(split(x, grps), function(x) { all(is.na(x)) })
+  failed <- sapply(split(x, grps), function(x) {
+    all(is.na(x) | grepl("\\.NA$", x))
+  })
   return(!failed)
 }
diff --git a/tests/testthat/test.Optmatch.R b/tests/testthat/test.Optmatch.R
@@ -182,8 +182,65 @@ test_that("Indicating failing subproblems", {
   names(Z) <- names(B) <- letters[1:16]
   match <- pairmatch(exactMatch(Z ~ B), data = Z) # assure data order by passing Z
 
-  expect_equal(sum(subproblemSuccess(match)), 2)
-  expect_true(all(names(subproblemSuccess(match)) %in%  c("1", "2")))
+  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", {