Update contact_matrix to only accept survey() objects

DESCRIPTION

@@ -30,7 +30,8 @@ Imports:
     lubridate,
     oai,
     wpp2017,
-    xml2
+    xml2,
+    lifecycle
 Suggests: 
     ggplot2,
     here,
@@ -45,7 +46,7 @@ VignetteBuilder:
 Encoding: UTF-8
 LazyData: true
 NeedsCompilation: no
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.0
 URL: https://github.com/epiforecasts/socialmixr,
     https://epiforecasts.io/socialmixr/
 BugReports: https://github.com/epiforecasts/socialmixr/issues

NAMESPACE

@@ -43,6 +43,7 @@ importFrom(httr,status_code)
 importFrom(httr,user_agent)
 importFrom(jsonlite,fromJSON)
 importFrom(jsonlite,toJSON)
+importFrom(lifecycle,deprecate_warn)
 importFrom(lubridate,period)
 importFrom(lubridate,period_to_seconds)
 importFrom(lubridate,years)

NEWS.md

@@ -1,6 +1,16 @@
 # socialmixr 0.3.1.9000
 
 * An error in `list_surveys()` was fixed which stopped this working
+* `contact_matrix()` was updated to only accept `survey` objects, not DOIs and matches the documentation. It is still possible to get a contact matrix from a DOI but it is necessary to go through the `get_survey()` function.
+
+  ```r
+  # No longer works!
+  contact_matrix("10.5281/zenodo.1095664")
+
+  # Recommended workflow
+  get_survey("10.5281/zenodo.1095664") |>
+    contact_matrix()
+  ```
 
 # socialmixr 0.3.1
 

R/contact_matrix.r

@@ -30,6 +30,7 @@
 #' @importFrom stats xtabs runif median
 #' @importFrom utils data globalVariables
 #' @importFrom countrycode countrycode
+#' @importFrom lifecycle deprecate_warn
 #' @import data.table
 #' @export
 #' @autoglobal
@@ -56,8 +57,21 @@ contact_matrix <- function(survey, countries = NULL, survey.pop, age.limits, fil
   missing.participant.age <- match.arg(missing.participant.age)
   missing.contact.age <- match.arg(missing.contact.age)
 
-  ## get the survey
-  survey <- get_survey(survey)
+  error_string <-
+    "must be a survey object (created using `survey()` or `get_survey()`)"
+
+  if (all(is_doi(survey))) {
+    deprecate_warn(
+      "0.3.2", paste0("contact_matrix(survey = '", error_string, "')"),
+      details = "Passing a DOI will be removed in version 0.4.0."
+    )
+    survey <- get_survey(survey)
+  } else if (!inherits(survey, "survey")) {
+    stop(error_string)
+  }
+
+  ## clean the survey
+  survey <- clean(survey)
   ## check and get columns
   columns <- suppressMessages(check(survey, ...))
 

R/download_survey.r

@@ -23,7 +23,7 @@
 download_survey <- function(survey, dir = NULL, sleep = 1) {
   survey <- sub("^(https?:\\/\\/(dx\\.)?doi\\.org\\/|doi:)", "", survey)
   survey <- sub("#.*$", "", survey)
-  is.doi <- (length(survey) > 0) && all(grepl("^10.[0-9.]{4,}/[-._;()/:A-z0-9]+$", survey))
+  is.doi <- (length(survey) > 0) && all(is_doi(survey))
   is.url <- (length(survey) > 0) && (is.doi || grepl("^https?:\\/\\/", survey))
 
   if (is.url && length(survey) > 1) {
@@ -129,3 +129,12 @@ find_common_prefix <- function(vec) {
 
   return(lcs)
 }
+
+##' Checks if a character string is a DOI
+##'
+##' @param x Character vector; the string or strings to check
+##' @return Logical; \code{TRUE} if \code{x} is a DOI, \code{FALSE} otherwise
+##' @author Sebastian Funk
+is_doi <- function(x) {
+  is.character(x) & grepl("^10.[0-9.]{4,}/[-._;()/:A-z0-9]+$", x)
+}

tests/testthat/test-matrix.r

@@ -87,7 +87,7 @@ test_that("demography is numeric", {
 })
 
 test_that("survey argument is validated", {
-  expect_error(contact_matrix(survey = "bogus"), "URL")
+  expect_error(contact_matrix(survey = "bogus"), "survey")
 })
 
 test_that("error is thrown if no survey population can be generated", {
@@ -544,3 +544,9 @@ test_that("Contact matrices per capita are also generated when bootstrapping", {
     ), 2)
   })
 })
+
+test_that("passing a DOI for survey is deprecated", {
+  lifecycle::expect_deprecated(
+    contact_matrix(survey = "10.5281/zenodo.1095664") # nolint
+  )
+})