diff --git a/DESCRIPTION b/DESCRIPTION index f84e736a..1fdeafd9 100644 --- a/DESCRIPTION +++ b/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", diff --git a/NEWS.md b/NEWS.md index 313bac38..87addbc8 100644 --- a/NEWS.md +++ b/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. 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 diff --git a/R/car.R b/R/car.R index 6f4eb44d..48c28687 100644 --- a/R/car.R +++ b/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 2 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 2 sub-graphs" + ) comp <- spdep::n.comp.nb(nb) for (k in seq_len(comp$nc)) { diff --git a/R/read-data.R b/R/read-data.R index 29a6f0a9..c304c3c9 100644 --- a/R/read-data.R +++ b/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) { diff --git a/R/utils.R b/R/utils.R index 528c1787..7beb4bd9 100644 --- a/R/utils.R +++ b/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) { diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index e8410cd8..98317777 100644 --- a/tests/testthat/test-utils.R +++ 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(1), message_regexp = "msg 1"), + "^Raising 1$") + expect_message(suppress_conditions(f(1), warning_regexp = "Raising 1"), + "^msg 1\n$") }) test_that("read csv can read semicolon delimited files", {