diff --git a/R/constants.R b/R/constants.R index 66480f4e..56068632 100644 --- a/R/constants.R +++ b/R/constants.R @@ -2,4 +2,4 @@ version <- "1.0.0" http_headers <- httr::add_headers("User-Agent" = paste0("delphi_epidata", version)) -base_url <- "https://delphi.cmu.edu/epidata/" +global_base_url <- "https://delphi.cmu.edu/epidata/" diff --git a/R/covidcast.R b/R/covidcast.R new file mode 100644 index 00000000..9e75b4de --- /dev/null +++ b/R/covidcast.R @@ -0,0 +1,154 @@ + +parse_signal <- function(signal, base_url) { + class(signal) <- c("covidcast_data_signal", class(signal)) + signal$key <- paste(signal$source, signal$signal, sep = ":") + + #' + #' fetch covidcast data + #' + #' @param data_source data source to fetch + #' @param signals data source to fetch + #' @param time_type data source to fetch + #' @param time_values data source to fetch + #' @param geo_type geo_type to fetch + #' @param geo_values data source to fetch + #' @param as_of data source to fetch + #' @param issues data source to fetch + #' @param lag data source to fetch + #' @return an instance of epidata_call + signal$call <- function(geo_type, + geo_values, + time_values, + ...) { + epicall <- covidcast( + signal$source, signal$signal, signal$time_type, geo_type, + time_values, geo_values, ... + ) + epicall$base_url <- base_url + epicall + } + r <- list() + r[[signal$signal]] <- signal + r +} + +print.covidcast_data_signal <- function(signal, ...) { + print(signal$name) + print(signal$key) + print(signal$short_description) +} + +parse_source <- function(source, base_url) { + class(source) <- c("covidcast_data_source", class(source)) + signals <- do.call(c, lapply(source$signals, parse_signal, base_url = base_url)) + class(signals) <- c("covidcast_data_signal_list", class(signals)) + source$signals <- signals + r <- list() + r[[source$source]] <- source + r +} + + +as.data.frame.covidcast_data_signal_list <- function(signals, ...) { + as.data.frame(do.call(rbind, lapply(signals, function(x) { + sub <- x[c( + "source", + "signal", + "name", + "active", + "short_description", + "description", + "time_type", + "time_label", + "value_label", + "format", + "category", + "high_values_are", + "is_smoothed", + "is_weighted", + "is_cumulative", + "has_stderr", + "has_sample_size" + )] + sub$geo_types <- paste0(names(x$geo_types), collapse = ",") + sub + })), row.names = sapply(signals, function(x) { + x$key + }), ...) +} + + +print.covidcast_data_source <- function(source, ...) { + print(source$name, ...) + print(source$source, ...) + print(source$description, ...) + signals <- as.data.frame(source$signals) + print(signals[, c("signal", "name", "short_description")], ...) +} + +#' +#' creates the covidcast epidata helper +#' +#' @param base_url optional alternative base url +#' @importFrom httr RETRY stop_for_status content +#' @importFrom jsonlite fromJSON +#' @importFrom rlang abort +#' @return an instance of covidcast_epidata +#' +#' @export +covidcast_epidata <- function(base_url = global_base_url) { + url <- join_url(base_url, "covidcast/meta") + res <- do_request(url, list()) + + httr::stop_for_status(res) + r <- httr::content(res, "text", encoding = "UTF-8") + meta <- jsonlite::fromJSON(r, simplifyVector = FALSE) + + sources <- do.call(c, lapply(meta, parse_source, base_url = base_url)) + class(sources) <- c("covidcast_data_source_list", class(sources)) + + all_signals <- do.call(c, lapply(sources, function(x) { + l <- c(x$signals) + names(l) <- paste(x$source, names(l), sep = ":") + l + })) + class(all_signals) <- c("covidcast_data_signal_list", class(all_signals)) + structure( + list( + sources = sources, + signals = all_signals + ), + class = "covidcast_epidata" + ) +} + + +as.data.frame.covidcast_data_source_list <- function(sources, ...) { + as.data.frame(do.call(rbind, lapply(sources, function(x) { + sub <- x[c( + "source", "name", "description", "reference_signal", "license" + )] + sub$signals <- paste0(sapply(x$signals, function(y) { + y$signal + }), collapse = ",") + sub + })), row.names = sapply(sources, function(x) { + x$source + }), ...) +} + +print.covidcast_epidata <- function(epidata, ...) { + print("COVIDcast Epidata Fetcher") + print("Sources:") + sources <- as.data.frame(epidata$sources) + print(sources[1:5, c("source", "name")], ...) + if (nrow(sources) > 5) { + print(paste0((nrow(sources) - 5), " more...")) + } + print("Signals") + signals <- as.data.frame(epidata$signals) + print(signals[1:5, c("source", "signal", "name")], ...) + if (nrow(signals) > 5) { + print(paste0((nrow(signals) - 5), " more...")) + } +} diff --git a/R/epidatacall.R b/R/epidatacall.R index 320926e8..1eafd5a4 100644 --- a/R/epidatacall.R +++ b/R/epidatacall.R @@ -1,7 +1,8 @@ -create_epidata_call <- function(endpoint, params, meta = NULL, only_supports_classic = FALSE) { +create_epidata_call <- function(endpoint, params, meta = NULL, + only_supports_classic = FALSE) { stopifnot(is.character(endpoint), length(endpoint) == 1) stopifnot(is.list(params)) stopifnot(is.null(meta) || is.list(meta)) @@ -13,7 +14,7 @@ create_epidata_call <- function(endpoint, params, meta = NULL, only_supports_cla list( endpoint = endpoint, params = params, - base_url = base_url, + base_url = global_base_url, meta = meta, only_supports_classic = only_supports_classic ), @@ -62,11 +63,7 @@ request_arguments <- full_url <- function(epidata_call) { stopifnot(inherits(epidata_call, "epidata_call")) - url <- epidata_call$base_url - if (url[length(url)] != "/") { - url <- paste0(url, "/") - } - paste0(url, epidata_call$endpoint) + join_url(epidata_call$base_url, epidata_call$endpoint) } #' @@ -99,18 +96,7 @@ request_impl <- function(epidata_call, format_type, fields = NULL) { url <- full_url(epidata_call) params <- request_arguments(epidata_call, format_type, fields) - # don't retry in case of certain status codes - res <- httr::RETRY("GET", url, - query = params, http_headers, - terminate_on = c(400, 401, 403, 405, 414, 500) - ) - if (res$status_code == 414) { - res <- httr::RETRY("POST", url, - body = params, encode = "form", http_headers, - terminate_on = c(400, 401, 403, 405, 414, 500) - ) - } - res + do_request(url, params) } #' @@ -119,9 +105,8 @@ request_impl <- function(epidata_call, format_type, fields = NULL) { #' @param epidata_call and instance of epidata_call #' @param fields filter fields #' @param disable_date_parsing disable automatic date parsing -#' @importFrom httr RETRY stop_for_status content http_error +#' @importFrom httr stop_for_status content http_error #' @importFrom jsonlite fromJSON -#' @importFrom MMWRweek MMWRweek2Date #' @return parsed json message #' #' @export @@ -149,9 +134,8 @@ fetch_classic <- function(epidata_call, fields = NULL, disable_date_parsing = FA #' @param epidata_call and instance of epidata_call #' @param fields filter fields #' @param disable_date_parsing disable automatic date parsing -#' @importFrom httr RETRY stop_for_status content +#' @importFrom httr stop_for_status content #' @importFrom jsonlite fromJSON -#' @importFrom MMWRweek MMWRweek2Date #' @importFrom rlang abort #' @return parsed json message #' @@ -177,7 +161,7 @@ fetch_json <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE #' #' @param epidata_call and instance of epidata_call #' @param fields filter fields -#' @importFrom httr RETRY stop_for_status content +#' @importFrom httr stop_for_status content #' @importFrom rlang abort #' @return CSV text #' @@ -238,8 +222,7 @@ info_to_type <- function(info, disable_date_parsing = FALSE) { #' @param fields filter fields #' @param disable_date_parsing disable automatic date parsing #' @importFrom readr read_csv -#' @importFrom httr RETRY stop_for_status content -#' @importFrom MMWRweek MMWRweek2Date +#' @importFrom httr stop_for_status content #' @importFrom rlang abort #' @return tibble #' @@ -293,10 +276,6 @@ fetch_tbl <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE) #' @param epidata_call and instance of epidata_call #' @param fields filter fields #' @param disable_date_parsing disable automatic date parsing -#' @importFrom readr read_csv -#' @importFrom httr RETRY stop_for_status content -#' @importFrom MMWRweek MMWRweek2Date -#' @importFrom rlang abort #' @return data.frame #' #' @export diff --git a/R/parse.R b/R/parse.R index 56228aab..74a6b3da 100644 --- a/R/parse.R +++ b/R/parse.R @@ -3,6 +3,12 @@ parse_api_date <- function(value) { as.Date(as.character(value), format = "%Y%m%d") } + + +#' +#' parses a week +#' @importFrom MMWRweek MMWRweek2Date +#' @return a date parse_api_week <- function(value) { v <- as.integer(value) years <- floor(v / 100) diff --git a/R/request.R b/R/request.R new file mode 100644 index 00000000..e05751da --- /dev/null +++ b/R/request.R @@ -0,0 +1,24 @@ +join_url <- function(url, endpoint) { + if (url[length(url)] != "/") { + url <- paste0(url, "/") + } + paste0(url, endpoint) +} + +#' +#' performs the request +#' @importFrom httr RETRY +do_request <- function(url, params) { + # don't retry in case of certain status codes + res <- httr::RETRY("GET", url, + query = params, http_headers, + terminate_on = c(400, 401, 403, 405, 414, 500) + ) + if (res$status_code == 414) { + res <- httr::RETRY("POST", url, + body = params, encode = "form", http_headers, + terminate_on = c(400, 401, 403, 405, 414, 500) + ) + } + res +} diff --git a/R/utils.R b/R/utils.R index d0211448..3b562377 100644 --- a/R/utils.R +++ b/R/utils.R @@ -5,7 +5,7 @@ format_item <- function(value) { if (inherits(value, "EpiRange")) { paste0(toString(value$from), "-", toString(value$to)) } else if (is.list(value) && - "from" %in% names(value) && "to" %in% names(value)) { + "from" %in% names(value) && "to" %in% names(value) && length(names(value)) == 2) { paste0(toString(value$from), "-", toString(value$to)) } else { toString(value) diff --git a/vignettes/covidcast.Rmd b/vignettes/covidcast.Rmd new file mode 100644 index 00000000..23160de7 --- /dev/null +++ b/vignettes/covidcast.Rmd @@ -0,0 +1,49 @@ +--- +title: "COVIDcast API Client" +author: "Delphi Group" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{COVIDcast API Client} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(echo = TRUE) +``` + +# Delphi Epidata R API Client + +```{r libraries} +# devtools::install_url("https://github.com/cmu-delphi/delphi-epidata-r/releases/latest/download/delphi-epidata.tar.gz") +# install.packages('delphi.epidata') +library('delphi.epidata') +library('magrittr') +``` + + +```{r} +covidcast_api <- covidcast_epidata() +epicall <- covidcast_api$sources$`fb-survey`$signals$smoothed_cli$call("nation", "us", epirange(20210405, 20210410)) +``` + +```{r} +epicall %>% fetch_classic() +``` + +```{r} +epicall %>% fetch_json() +``` + +```{r} +epicall %>% fetch_csv() +``` + +```{r} +epicall %>% fetch_df() +``` + +```{r} +# epicall %>% with_base_url("https://staging.delphi.cmu.edu/epidata/") %>% fetch_df() +```