Extending tests

.github/workflows/ci.yml

@@ -1,6 +1,8 @@
 name: ci
 
-on: [push]
+on:
+  workflow_dispatch: #get a button to trigger it by hand
+  push:
 
 jobs:
   build:

.github/workflows/test-coverage.yml

@@ -0,0 +1,55 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  workflow_dispatch: #get a button to trigger it by hand
+  push:
+    branches: [main, master, extendingTests]
+  pull_request:
+    branches: [main, master]
+
+name: test-coverage
+
+jobs:
+  test-coverage:
+    runs-on: ubuntu-latest
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }}
+
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::covr
+          needs: coverage
+
+      - name: Test coverage
+        run: |
+          covr::codecov(
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package")
+          )
+        shell: Rscript {0}
+
+      - name: Show testthat output
+        if: always()
+        run: |
+          ## --------------------------------------------------------------------
+          find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
+
+      - name: Upload test results
+        if: failure()
+        uses: actions/upload-artifact@v3
+        with:
+          name: coverage-test-failures
+          path: ${{ runner.temp }}/package
+
+      - name: Upload coverage reports to Codecov
+        uses: codecov/codecov-action@v3

R/covidcast.R

@@ -39,7 +39,7 @@ print.covidcast_data_signal <- function(signal, ...) {
 
 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))
+  signals <- do.call(c, unname(lapply(source$signals, parse_signal, base_url = base_url)))
   class(signals) <- c("covidcast_data_signal_list", class(signals))
   source$signals <- signals
   r <- list()
@@ -113,7 +113,7 @@ covidcast_epidata <- function(base_url = global_base_url) {
   if (response$status_code != 200) {
     # 500, 429, 401 are possible
     msg <- "fetch data from API"
-    if (httr::http_type(response) == "text/html") {
+    if (httr::http_type(response) == "text/html" & length(response$content) > 0) {
       # grab the error information out of the returned HTML document
       msg <- paste(msg, ":", xml2::xml_text(xml2::xml_find_all(
         xml2::read_html(content(response, "text")),

R/model.R

@@ -150,26 +150,6 @@ parse_api_week <- function(value) {
   MMWRweek::MMWRweek2Date(years, weeks)
 }
 
-fields_to_predicate <- function(fields = NULL) {
-  if (is.null(fields)) {
-    return(function(x) {
-      TRUE
-    })
-  }
-  to_include <- c()
-  to_exclude <- c()
-  for (f in fields) {
-    if (substr(f, 1, 2) == "-") {
-      to_exclude <- c(to_exclude, substr(f, 2, length(f)))
-    } else {
-      to_include <- c(to_include, f)
-    }
-  }
-  function(x) {
-    !(x %in% to_exclude) && (length(to_include) == 0 || x %in% to_include)
-  }
-}
-
 #' @importFrom checkmate test_character test_class test_date test_integerish test_list
 parse_timeset_input <- function(value) {
   if (is.null(value)) {

README.md

@@ -1,6 +1,7 @@
 # delphi Epidata R client
 
 [![License: MIT][mit-image]][mit-url] [![Github Actions][github-actions-image]][github-actions-url]
+[![codecov](https://codecov.io/gh/dsweber2/epidatr/branch/dev/graph/badge.svg?token=jVHL9eHZNZ)](https://codecov.io/gh/dsweber2/epidatr)
 
 ## Documentation
 
@@ -19,13 +20,17 @@ functions have been replaced by the `fetch()` function, which almost always
 returns a tibble, except when used with a limited number of older endpoints
 (such as `delphi()` and `meta()`), where it will output a nested list structure.
 If you encounter an error like
+
 ```{r}
 Error in fetch_tbl(.) : could not find function "fetch_tbl"
 ```
-please update to use `fetch()` instead.  If instead you encounter
+
+please update to use `fetch()` instead. If instead you encounter
+
 ```{r}
 Error in fetch(.) : could not find function "fetch"
 ```
+
 please update to the newest `epidatr`.
 
 Note (2022-08-02): the package that this installs is being renamed from
@@ -54,6 +59,7 @@ a separate key that needs to be passed as an argument.
 ## Development Environment
 
 Relevant R commands
+
 ```r
 install.packages(c('devtools', 'pkgdown', 'styler', 'lintr')) # install dev dependencies
 devtools::install_deps(dependencies = TRUE) # install package dependencies

tests/testthat/test-covidcast.R

@@ -5,3 +5,32 @@ test_that("covidcast", {
     covidcast("fb-survey", "smoothed_cli", "nation", "day", "us", epirange(20210405, 20210410))
   )
 })
+
+# quite minimal, could probably use some checks that the fields are as desired
+test_that("dataframe converters", {
+  res <- covidcast_epidata()$sources %>% as.data.frame()
+  expect_identical(class(res), "data.frame")
+  res <- covidcast_epidata()$signals %>% as.data.frame()
+  expect_identical(class(res), "data.frame")
+})
+
+test_that("http errors", {
+  # generated with
+  # response <- httr::RETRY("GET",
+  #   url = "https://httpbin.org/status/400",
+  #   query = list(),
+  #   terminate_on = c(400, 401, 403, 405, 414, 500),
+  #   http_headers,
+  #   httr::authenticate("epidata", get_auth_key())
+  # ) %>% readr::write_rds(testthat::test_path("data/test-do_request-httpbin.rds"))
+  local_mocked_bindings(
+    do_request = function(...) readRDS(testthat::test_path("data/test-do_request-httpbin.rds"))
+  )
+  expect_error(covidcast_epidata(), class = "http_400")
+})
+
+
+test_that("name completion", {
+  all_names <- names(covidcast_epidata()$signals)
+  expect_identical(all_names, all_names)
+})

tests/testthat/test-epidatacall.R

@@ -1,3 +1,28 @@
+test_that("request_impl http errors", {
+  # should give a 401 error
+  epidata_call <- pvt_cdc(auth = "ImALittleTeapot", epiweeks = epirange(202003, 202304), locations = "ma")
+  local_mocked_bindings(
+    # generated via
+    # url <- full_url(epidata_call)
+    # params <- request_arguments(epidata_call, "csv", NULL)
+    # result <- do_request(url, params) %>% readr::write_rds(testthat::test_path("data/test-http401.rds"))
+    do_request = function(...) readRDS(testthat::test_path("data/test-http401.rds")),
+  )
+  expect_error(response <- epidata_call %>% request_impl("csv"), class = "http_401")
+
+  # should give a 500 error (the afhsb endpoint is removed)
+
+  # generated via
+  # epidata_call <- pvt_afhsb(auth = Sys.getenv("SECRET_API_AUTH_AFHSB"), locations = "mn", epiweeks = epirange(202002, 202110), flu_types = "flu1")
+  # url <- full_url(epidata_call)
+  # params <- request_arguments(epidata_call, "csv", NULL)
+  # response <- do_request(url, params) %>% readr::write_rds(testthat::test_path("data/test-http500.rds"))
+  local_mocked_bindings(
+    do_request = function(...) readRDS(testthat::test_path("data/test-http500.rds"))
+  )
+  expect_error(response <- epidata_call %>% request_impl("csv"), class = "http_500")
+})
+
 test_that("fetch and fetch_tbl", {
   epidata_call <- covidcast(
     data_source = "jhu-csse",
@@ -7,7 +32,6 @@ test_that("fetch and fetch_tbl", {
     time_values = epirange("2020-06-01", "2020-08-01"),
     geo_values = "ca,fl"
   )
-
   local_mocked_bindings(
     request_impl = function(...) NULL,
     .package = "epidatr"
@@ -24,6 +48,18 @@ test_that("fetch and fetch_tbl", {
   tbl_out <- epidata_call %>% fetch_tbl()
   out <- epidata_call %>% fetch()
   expect_identical(out, tbl_out)
+
+  local_mocked_bindings(
+    # RDS file generated with
+    # epidata_call %>%
+    # fetch_debug(format_type = "classic", fields = c("time_value", "value")) %>%
+    # readr::write_rds(testthat::test_path("data/test-narrower-fields.rds"))
+    content = function(...) readRDS(testthat::test_path("data/test-narrower-fields.rds")),
+    .package = "httr"
+  )
+  # testing that the fields fill as expected
+  res <- epidata_call %>% fetch(fields = c("time_value", "value"))
+  expect_equal(res, tbl_out[c("time_value", "value")])
 })
 
 test_that("fetch_tbl warns on non-success", {
@@ -59,3 +95,23 @@ test_that("fetch_tbl warns on non-success", {
     fixed = TRUE
   )
 })
+
+test_that("classic only fetch", {
+  # delphi is an example endpoint that only suports the classic call
+  epidata_call <- delphi(system = "ec", epiweek = 201501)
+  local_mocked_bindings(
+    # generated using
+    # epidata_call %>%
+    #   fetch_debug(format_type = "classic") %>%
+    #   readr::write_rds(testthat::test_path("data/test-classic-only.rds"))
+    content = function(...) readRDS(testthat::test_path("data/test-classic-only.rds")),
+    .package = "httr"
+  )
+  # make sure that fetch actually uses the classic method on endpoints that only support the classic
+  fetch_out <- epidata_call %>% fetch()
+  fetch_classic_out <- epidata_call %>% fetch_classic()
+  expect_identical(fetch_out, fetch_classic_out)
+
+  # making sure that fetch_tbl and throws the expected error on classic only
+  expect_error(epidata_call %>% fetch_tbl(), class = "only_supports_classic_format")
+})

tests/testthat/test-model.R

@@ -46,3 +46,30 @@ test_that("`parse_timeset_input` on valid inputs", {
   # NULL: allow this as a missing argument marker
   expect_identical(parse_timeset_input(NULL), NULL)
 })
+
+test_that("null parsing", {
+  # parse_data_frame (df[[info$name]] = NULL)-> parse_value
+  epidata_call <- flusurv(locations = "ca", epiweeks = 202001)
+  # mocked data generated with
+  # epidata_call %>%
+  #   fetch_classic() %>%
+  #   readr::write_rds(testthat::test_path("data/flusurv-epiweeks.rds"))
+  mock_df <- as.data.frame(readr::read_rds(testthat::test_path("data/flusurv-epiweeks.rds")))
+  metadata <- epidata_call$meta
+  mock_df[[metadata[[1]]$name]][1] <- list(NULL)
+  mock_df[[metadata[[2]]$name]] <- c(TRUE)
+  epidata_call$meta[[2]]$type <- "bool"
+  res <- parse_data_frame(epidata_call, mock_df) %>% as_tibble()
+  # expect_null(res[["release_date"]]) # this is actually a list
+  expect_true(res$location)
+
+  # if the call has no metadata, return the whole frame as is
+  epidata_call$meta <- NULL
+  expect_identical(parse_data_frame(epidata_call, mock_df), mock_df)
+})
+
+test_that("parse invalid time", {
+  vale <- list(3)
+  vale$class <- "my nonexistant class"
+  expect_error(parse_timeset_input(vale))
+})

tests/testthat/test-request.R

@@ -0,0 +1,4 @@
+test_that("requesting works", {
+  res <- do_request("https://httpbin.org/status/414", list())
+  expect_equal(res$status_code, 414)
+})