Extreme requests

R/covidcast.R

@@ -100,15 +100,16 @@ print.covidcast_data_source <- function(source, ...) {
 #' print(smoothed_cli)
 #' df <- smoothed_cli$call("nation", "us", epirange(20210405, 20210410))
 #' @param base_url optional alternative API base url
+#' @param timeout_seconds the maximum amount of time to wait for a response
 #' @importFrom httr stop_for_status content http_type
 #' @importFrom jsonlite fromJSON
 #' @importFrom xml2 read_html xml_find_all xml_text
 #' @return an instance of covidcast_epidata
 #'
 #' @export
-covidcast_epidata <- function(base_url = global_base_url) {
+covidcast_epidata <- function(base_url = global_base_url, timeout_seconds = 30) {
   url <- join_url(base_url, "covidcast/meta")
-  response <- do_request(url, list())
+  response <- do_request(url, list(), timeout_seconds)
 
   if (response$status_code != 200) {
     # 500, 429, 401 are possible

R/epidatacall.R

@@ -111,19 +111,23 @@ print.epidata_call <- function(epidata_call) {
 #'   time_value and value fields or c("-direction") to return everything except
 #'   the direction field
 #' @param disable_date_parsing disable automatic date parsing
+#' @param return_empty boolean that allows returning an empty tibble if there is no data
+#' @param timeout_seconds the maximum amount of time to wait for a response
 #' @return
 #' - For `fetch`: a tibble or a JSON-like list
 #' @export
 #'
-fetch <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE) {
+fetch <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE, return_empty = FALSE, timeout_seconds = 30) {
   stopifnot(inherits(epidata_call, "epidata_call"))
   stopifnot(is.null(fields) || is.character(fields))
   stopifnot(is.logical(disable_date_parsing), length(disable_date_parsing) == 1)
+  stopifnot(is.logical(return_empty))
+  stopifnot(is.numeric(timeout_seconds))
 
   if (epidata_call$only_supports_classic) {
-    return(fetch_classic(epidata_call, fields))
+    return(fetch_classic(epidata_call, fields, return_empty = return_empty, timeout_seconds = timeout_seconds))
   } else {
-    return(fetch_tbl(epidata_call, fields, disable_date_parsing))
+    return(fetch_tbl(epidata_call, fields, disable_date_parsing, return_empty, timeout_seconds = timeout_seconds))
   }
 }
 
@@ -136,17 +140,21 @@ fetch <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE) {
 #'   time_value and value fields or c("-direction") to return everything except
 #'   the direction field
 #' @param disable_date_parsing disable automatic date parsing
+#' @param return_empty boolean that allows returning an empty tibble if there is no data.
+#' @param timeout_seconds the maximum amount of time to wait for a response
 #' @importFrom readr read_csv
 #' @importFrom httr stop_for_status content
 #' @importFrom rlang abort
 #' @return
 #' - For `fetch_tbl`: a [`tibble::tibble`]
 #' @importFrom tibble as_tibble
 #' @keywords internal
-fetch_tbl <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE) {
+fetch_tbl <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE, return_empty = FALSE, timeout_seconds = 30) {
   stopifnot(inherits(epidata_call, "epidata_call"))
   stopifnot(is.null(fields) || is.character(fields))
   stopifnot(is.logical(disable_date_parsing), length(disable_date_parsing) == 1)
+  stopifnot(is.logical(return_empty))
+  stopifnot(is.numeric(timeout_seconds))
 
   if (epidata_call$only_supports_classic) {
     rlang::abort("This endpoint only supports the classic message format, due to a non-standard behavior. Use fetch_classic instead.",
@@ -155,7 +163,10 @@ fetch_tbl <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE)
     )
   }
 
-  response_content <- fetch_classic(epidata_call, fields, disable_data_frame_parsing = FALSE)
+  response_content <- fetch_classic(epidata_call, fields, disable_data_frame_parsing = FALSE, return_empty = return_empty, timeout_seconds = timeout_seconds)
+  if (return_empty && length(response_content) == 0) {
+    return(tibble())
+  }
   return(parse_data_frame(epidata_call, response_content, disable_date_parsing) %>% as_tibble())
 }
 
@@ -172,48 +183,38 @@ fetch_tbl <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE)
 #' @param disable_data_frame_parsing do not automatically cast the epidata
 #'   output to a data frame (some endpoints return a list of lists, which is not
 #'   a data frame)
+#' @param return_empty boolean that allows returning an empty tibble if there is no data.
+#' @param timeout_seconds the maximum amount of time to wait for a response
 #' @importFrom httr stop_for_status content http_error
 #' @importFrom jsonlite fromJSON
 #' @return
 #' - For `fetch_classic`: a JSON-like list
 #' @keywords internal
-fetch_classic <- function(epidata_call, fields = NULL, disable_data_frame_parsing = TRUE) {
+fetch_classic <- function(epidata_call, fields = NULL, disable_data_frame_parsing = TRUE, return_empty = FALSE, timeout_seconds = 30) {
   stopifnot(inherits(epidata_call, "epidata_call"))
   stopifnot(is.null(fields) || is.character(fields))
+  stopifnot(is.logical(return_empty))
+  stopifnot(is.numeric(timeout_seconds))
 
-  response <- request_impl(epidata_call, "classic", fields)
+  response <- request_impl(epidata_call, "classic", fields, timeout_seconds)
   response_content <- httr::content(response, as = "text", encoding = "UTF-8")
 
-  # TODO Temporary workaround the first row of the response being a comment
-  # Remove on 2023-06-21
-  if (grepl("This request exceeded", response_content) && !epidata_call$only_supports_classic) {
-    response_content <- jsonlite::fromJSON(response_content, simplifyDataFrame = FALSE)
-    message <- response_content$epidata[[1L]]
-    cli::cli_abort(c(
-      "epidata warning, promoted to error: {message}",
-      "i" = "Either:",
-      "*" = "set the environment variable DELPHI_EPIDATA_KEY, or",
-      "*" = 'set the option "delphi.epidata.key":',
-      " " = '{.code options(delphi.epidata.key = "YOUR_KEY_OR_TEMP_KEY")}',
-      "To save your key for later sessions (and hide it from your code), you can edit your .Renviron file with:",
-      "*" = "usethis::edit_r_environ()"
-    ))
-  }
-
   response_content <- jsonlite::fromJSON(response_content, simplifyDataFrame = !disable_data_frame_parsing)
 
   # success is 1, no results is -2, truncated is 2, -1 is generic error
   if (response_content$result != 1) {
-    rlang::abort(paste0("epidata error: ", response_content$message), "epidata_error")
+    if ((response_content$result != -2) && !(return_empty)) {
+      rlang::abort(paste0("epidata error: ", response_content$message), "epidata_error")
+    }
   }
   if (response_content$message != "success") {
     rlang::warn(paste0("epidata warning: ", response_content$message), "epidata_warning")
   }
   return(response_content$epidata)
 }
 
-fetch_debug <- function(epidata_call, format_type = "classic", fields = NULL) {
-  response <- request_impl(epidata_call, format_type, fields)
+fetch_debug <- function(epidata_call, format_type = "classic", fields = NULL, timeout_seconds = 30) {
+  response <- request_impl(epidata_call, format_type, fields, timeout_seconds)
   content <- httr::content(response, "text", encoding = "UTF-8")
   content
 }
@@ -263,13 +264,13 @@ with_base_url <- function(epidata_call, base_url) {
 #' HTTP errors and forwarding the HTTP body in R errors
 #' @importFrom httr stop_for_status content http_type
 #' @importFrom xml2 read_html xml_find_all xml_text
-request_impl <- function(epidata_call, format_type, fields = NULL) {
+request_impl <- function(epidata_call, format_type, fields = NULL, timeout_seconds = 30) {
   stopifnot(inherits(epidata_call, "epidata_call"))
   stopifnot(format_type %in% c("json", "csv", "classic"))
 
   url <- full_url(epidata_call)
   params <- request_arguments(epidata_call, format_type, fields)
-  response <- do_request(url, params)
+  response <- do_request(url, params, timeout_seconds)
 
   if (response$status_code != 200) {
     # 500, 429, 401 are possible

R/request.R

@@ -21,14 +21,15 @@ join_url <- function(url, endpoint) {
 #' }
 #'
 #' @importFrom httr RETRY
-do_request <- function(url, params) {
+do_request <- function(url, params, timeout_seconds = 30) {
   # don't retry in case of certain status codes
   res <- httr::RETRY("GET",
     url = url,
     query = params,
     terminate_on = c(400, 401, 403, 405, 414, 500),
     http_headers,
-    httr::authenticate("epidata", get_auth_key())
+    httr::authenticate("epidata", get_auth_key()),
+    httr::timeout(timeout_seconds)
   )
   if (res$status_code == 414) {
     res <- httr::RETRY("POST",

tests/testthat/test-epidatacall.R

@@ -81,21 +81,20 @@ test_that("fetch_tbl warns on non-success", {
     .package = "httr"
   )
   # TODO: Turn these tests back on, when the API is fully online
-  # Remove on 2023-06-21
-  # artificial_warning <- "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs."
-  # debug_triplet <- readRDS(testthat::test_path("data/test-classic.rds")) %>%
-  #   jsonlite::fromJSON() %>%
-  #   `[[<-`("message", artificial_warning)
-  # local_mocked_bindings(
-  #   # see generation code above
-  #   fromJSON = function(...) debug_triplet,
-  #   .package = "jsonlite"
-  # )
+  artificial_warning <- "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs."
+  debug_triplet <- readRDS(testthat::test_path("data/test-classic.rds")) %>%
+    jsonlite::fromJSON() %>%
+    `[[<-`("message", artificial_warning)
+  local_mocked_bindings(
+    # see generation code above
+    fromJSON = function(...) debug_triplet,
+    .package = "jsonlite"
+  )
 
-  # expect_warning(epidata_call %>% fetch_tbl(),
-  #   regexp = paste0("epidata warning: ", artificial_warning),
-  #   fixed = TRUE
-  # )
+  expect_warning(epidata_call %>% fetch_tbl(),
+    regexp = paste0("epidata warning: ", artificial_warning),
+    fixed = TRUE
+  )
 })
 
 test_that("classic only fetch", {

vignettes/endpoints.Rmd

@@ -141,7 +141,7 @@ Example call:
 
 ```{r}
 del <- delphi(system = "ec", epiweek = 201501) %>% fetch()
-names(del[[1L]]$forecast)
+names(del$forecast)
 ```
 
 ### FluSurv hospitalization data