diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0d9c4140..506dd153 100644 --- a/.github/workflows/ci.yml +++ b/.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: diff --git a/.github/workflows/test-coverage.yml b/.github/workflows/test-coverage.yml new file mode 100644 index 00000000..90d44749 --- /dev/null +++ b/.github/workflows/test-coverage.yml @@ -0,0 +1,54 @@ +# 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, dev] + pull_request: + +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 diff --git a/R/covidcast.R b/R/covidcast.R index a23a95e9..14d064f0 100644 --- a/R/covidcast.R +++ b/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")), diff --git a/R/model.R b/R/model.R index aa8f7df1..b2b844f5 100644 --- a/R/model.R +++ b/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)) { diff --git a/README.md b/README.md index 3755c208..4b8319e4 100644 --- a/README.md +++ b/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 diff --git a/tests/testthat/data/flusurv-epiweeks.rds b/tests/testthat/data/flusurv-epiweeks.rds new file mode 100644 index 00000000..b7ada33b Binary files /dev/null and b/tests/testthat/data/flusurv-epiweeks.rds differ diff --git a/tests/testthat/data/http401.rds b/tests/testthat/data/http401.rds new file mode 100644 index 00000000..7392ffc9 Binary files /dev/null and b/tests/testthat/data/http401.rds differ diff --git a/tests/testthat/data/test-classic-only.rds b/tests/testthat/data/test-classic-only.rds new file mode 100644 index 00000000..0ee9c951 Binary files /dev/null and b/tests/testthat/data/test-classic-only.rds differ diff --git a/tests/testthat/data/test-do_request-httpbin.rds b/tests/testthat/data/test-do_request-httpbin.rds new file mode 100644 index 00000000..59cd76d5 Binary files /dev/null and b/tests/testthat/data/test-do_request-httpbin.rds differ diff --git a/tests/testthat/data/test-http401.rds b/tests/testthat/data/test-http401.rds new file mode 100644 index 00000000..b3a79bb0 Binary files /dev/null and b/tests/testthat/data/test-http401.rds differ diff --git a/tests/testthat/data/test-http500.rds b/tests/testthat/data/test-http500.rds new file mode 100644 index 00000000..777e319f Binary files /dev/null and b/tests/testthat/data/test-http500.rds differ diff --git a/tests/testthat/data/test-narrower-fields.rds b/tests/testthat/data/test-narrower-fields.rds new file mode 100644 index 00000000..602ffb71 Binary files /dev/null and b/tests/testthat/data/test-narrower-fields.rds differ diff --git a/tests/testthat/test-covidcast.R b/tests/testthat/test-covidcast.R index 918851a8..d239e179 100644 --- a/tests/testthat/test-covidcast.R +++ b/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) +}) diff --git a/tests/testthat/test-epidatacall.R b/tests/testthat/test-epidatacall.R index 30d5d835..d8d9cfc8 100644 --- a/tests/testthat/test-epidatacall.R +++ b/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") +}) diff --git a/tests/testthat/test-model.R b/tests/testthat/test-model.R index 6357c2ed..99f548ee 100644 --- a/tests/testthat/test-model.R +++ b/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)) +}) diff --git a/tests/testthat/test-request.R b/tests/testthat/test-request.R new file mode 100644 index 00000000..da09f858 --- /dev/null +++ b/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) +})