Merge pull request #441 from mrc-ide/spdep-warnings

Suppress spdep warnings

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: naomi
 Title: Naomi Model for Subnational HIV Estimates
-Version: 2.9.27
+Version: 2.9.28
 Authors@R:
     person(given = "Jeff",
            family = "Eaton",

NEWS.md

@@ -1,10 +1,11 @@
 # naomi 2.9.28
 
-* Make duckdb an optional dependency
+* Suppress "some observations have no neighbours" and "neighbour object has 2 sub-graphs" warnings from `spdep` v1.3.6 see https://r-spatial.github.io/spdep/news/index.html#version-13-6-development. We expect this warning for some countries and it will make tests and output noisy to leave on.
 
 # naomi 2.9.27
 
 * Show calibration plot ratio values to nearest 0.1. 
+* Make duckdb an optional dependency
 
 # naomi 2.9.26
 

R/car.R

@@ -13,17 +13,22 @@ create_adj_matrix <- function(sh) {
 
   s2_current <- sf::sf_use_s2()
   on.exit(invisible(
-    suppress_one_message(utils::capture.output(sf::sf_use_s2(s2_current)),
-                         "Spherical geometry \\(s2\\) switched"))
+    suppress_conditions(utils::capture.output(sf::sf_use_s2(s2_current)),
+                        "Spherical geometry \\(s2\\) switched"))
   )
-  invisible(suppress_one_message(utils::capture.output(sf::sf_use_s2(FALSE)),
-                                 "Spherical geometry \\(s2\\) switched"))
+  invisible(suppress_conditions(utils::capture.output(sf::sf_use_s2(FALSE)),
+                                "Spherical geometry \\(s2\\) switched"))
 
   if (nrow(sh) == 1) {
     adj <- matrix(0, dimnames = list(sh$area_id, sh$area_id))
   } else {
-    nb <- suppress_one_message(spdep::poly2nb(sh),
-                               "although coordinates are longitude/latitude, st_intersects assumes that they are planar")
+    nb <- suppress_conditions(
+      spdep::poly2nb(sh),
+      message_regexp = "although coordinates are longitude/latitude, st_intersects assumes that they are planar",
+      warning_regexp = c(
+        "some observations have no neighbours",
+        "neighbour object has \\d+ sub-graphs")
+      )
     adj <- spdep::nb2mat(nb, style = "B", zero.policy = TRUE)
     colnames(adj) <- rownames(adj)
   }
@@ -76,7 +81,10 @@ scale_gmrf_precision <- function(Q,
 
   ## `style = ` argument is arbitrary; it will throw a warning if NULL (default),
   ## but the neighbours list does not depend on it.
-  nb <- spdep::mat2listw(abs(Q), style = "B", zero.policy = TRUE)$neighbours
+  nb <- suppress_conditions(
+    spdep::mat2listw(abs(Q), style = "B", zero.policy = TRUE)$neighbours,
+    warning_regexp = "neighbour object has \\d+ sub-graphs"
+  )
   comp <- spdep::n.comp.nb(nb)
 
   for (k in seq_len(comp$nc)) {

R/read-data.R

@@ -218,7 +218,9 @@ read_area_merged <- function(file) {
 #'
 #' @keywords internal
 read_csv_partial_cols <- function(...){
-  suppress_one_warning(readr_read_csv(...), "The following named parsers don't match the column names")
+  suppress_conditions(
+    readr_read_csv(...),
+    warning_regexp = "The following named parsers don't match the column names")
 }
 
 drop_na_rows <- function(x) {

R/utils.R

@@ -31,20 +31,27 @@ write_csv_string <- function(x, ..., row.names = FALSE) {
   paste0(brio::readLines(tmp), collapse = "\n")
 }
 
-suppress_one_warning <- function(expr, regexp) {
-  withCallingHandlers(expr,
-    warning = function(w) {
-        if(grepl(regexp, w$message))
-          invokeRestart("muffleWarning")
-    })
-}
-
-suppress_one_message <- function(expr, regexp) {
-  withCallingHandlers(expr,
-    message = function(w) {
-        if(grepl(regexp, w$message))
-          invokeRestart("muffleMessage")
-    })
+suppress_conditions <- function(expr, message_regexp = NULL,
+                                warning_regexp = NULL) {
+  handlers <- list()
+  if (!is.null(message_regexp)) {
+    handlers$message <- function(w) {
+      if(grepl(paste(message_regexp, collapse = "|"), w$message)) {
+        invokeRestart("muffleMessage")
+      }
+    }
+  }
+  if (!is.null(warning_regexp)) {
+    handlers$warning <- function(w) {
+      if(grepl(paste(warning_regexp, collapse = "|"), w$message)) {
+        invokeRestart("muffleWarning")
+      }
+    }
+  }
+  with_handlers <- function(...) {
+    withCallingHandlers(expr, ...)
+  }
+  do.call(with_handlers, handlers)
 }
 
 `%||%` <- function(a, b) {

tests/testthat/test-utils.R

@@ -1,7 +1,40 @@
-test_that("suppress_one_warning behaves", {
-  expect_equal(suppress_one_warning(log(-1), "NaNs produced"), NaN)
-  expect_warning(suppress_one_warning(log(-1), "NaNs produced"), NA)
-  expect_warning(suppress_one_warning(log(-1), "unmatched"), "^NaNs produced$")
+test_that("suppress_conditions works as expected", {
+  expect_silent(suppress_conditions(log(-1), warning_regexp = "NaNs produced"))
+  expect_warning(suppress_conditions(log(-1), warning_regexp = "unmatched"),
+                 "^NaNs produced$")
+
+  f_warn <- function(x) {
+    warning("my first warning")
+    2 + 2
+    warning("my second warning")
+  }
+  expect_silent(suppress_conditions(
+    f_warn(),
+    warning_regexp = c("first warning", "second warning")))
+
+  f_msg <- function(n) {
+    for (i in seq_len(n)) {
+      message(paste("msg", i))
+    }
+  }
+  expect_silent(suppress_conditions(f_msg(1), message_regexp = "msg 1"))
+  expect_message(suppress_conditions(f_msg(1), message_regexp = "unmatched"),
+                 "^msg 1\n$")
+  expect_silent(suppress_conditions(f_msg(2), message_regexp = c("1", "2")))
+
+  f_both <- function(n) {
+    warning(paste("Raising", n))
+    for (i in seq_len(n)) {
+      message(paste("msg", i))
+    }
+  }
+  expect_silent(suppress_conditions(f_both(1),
+                                    message_regexp = "msg 1",
+                                    warning_regexp = "Raising 1"))
+  expect_warning(suppress_conditions(f_both(1), message_regexp = "msg 1"),
+                 "^Raising 1$")
+  expect_message(suppress_conditions(f_both(1), warning_regexp = "Raising 1"),
+                 "^msg 1\n$")
 })
 
 test_that("read csv can read semicolon delimited files", {