add covidcast meta wrapper

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/"

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..."))
+  }
+}

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

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)

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
+}

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)

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()
+```