Merge pull request #132 from dsweber2/largeRequests

Extreme requests: adding the `timeout_seconds` and `return_empty` parameters

Author: dsweber2

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,32 +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")
 
   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
 }
@@ -247,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",