From f8e21c779c169e6af51737bbece59e1e2ef3eb1f Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 26 May 2023 11:41:00 -0700 Subject: [PATCH 1/5] refactor(epidatacall): * use testthat::with_mocked_bindings for test mocking * delete fetch_csv --- DESCRIPTION | 2 - NAMESPACE | 1 - R/epidatacall.R | 100 ------------------------------ tests/testthat/test-epidatacall.R | 53 +++++++--------- 4 files changed, 23 insertions(+), 133 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ddba9cce..777b6ecd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,8 +34,6 @@ RoxygenNote: 7.2.3 Suggests: dplyr, knitr, - mockery, - mockr, rmarkdown, testthat (>= 3.1.5), withr diff --git a/NAMESPACE b/NAMESPACE index c29b64df..cbe41ffd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,6 @@ S3method(print,covidcast_data_signal) S3method(print,covidcast_data_source) S3method(print,covidcast_epidata) S3method(print,epidata_call) -S3method(print,epidata_csv) export("%>%") export(covid_hosp_facility) export(covid_hosp_facility_lookup) diff --git a/R/epidatacall.R b/R/epidatacall.R index 40332479..69cf5a61 100644 --- a/R/epidatacall.R +++ b/R/epidatacall.R @@ -195,72 +195,6 @@ fetch_classic <- function(epidata_call, fields = NULL, disable_data_frame_parsin return(response_content$epidata) } -#' Fetches the data and returns a tibble or an `epidata_csv` -#' -#' @param epidata_call an instance of `epidata_call` -#' @param fields filter fields -#' @param disable_date_parsing Boolean. Optionally, `TRUE` to disable parsing of -#' columns we expect to be dates, keeping them as character columns instead. -#' `FALSE` (the default) to parse these columns into `Date` vectors. -#' @param disable_tibble_output Boolean. Optionally, `TRUE` to output a -#' character vector with the `epidata_csv` class (which provides a custom -#' `print` method). `FALSE` (the default) to output a tibble. -#' @return -#' - For `fetch_csv`: a tibble, or `epidata_csv` if requested with -#' `disable_tibble_output = TRUE` -#' -#' @importFrom httr stop_for_status content -#' @importFrom rlang abort -fetch_csv <- function(epidata_call, fields = NULL, disable_date_parsing = FALSE, disable_tibble_output = FALSE) { - stopifnot(inherits(epidata_call, "epidata_call")) - stopifnot(is.null(fields) || is.character(fields)) - - 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.", - epidata_call = epidata_call, - class = "only_supports_classic_format" - ) - } - - response <- request_impl(epidata_call, "csv", fields) - response_content <- httr::content(response, "text", encoding = "UTF-8") - class(response_content) <- c("epidata_csv", class(response_content)) - - if (disable_tibble_output) { - return(response_content) - } - - meta <- epidata_call$meta - fields_pred <- fields_to_predicate(fields) - col_names <- c() - col_types <- list() - for (i in seq_len(length(meta))) { - info <- meta[[i]] - if (fields_pred(info$name)) { - col_names <- c(col_names, info$name) - col_types[info$name] <- info_to_type(info, disable_date_parsing) - } - } - - csv_tibble <- if (length(col_names) > 0) { - readr::read_csv(response_content, col_types = col_types) - } else { - readr::read_csv(response_content) - } - - if (!disable_date_parsing) { - # parse weeks - columns <- colnames(csv_tibble) - for (i in seq_len(length(meta))) { - info <- meta[[i]] - if (info$name %in% columns && info$type == "epiweek") { - csv_tibble[[info$name]] <- parse_api_week(csv_tibble[[info$name]]) - } - } - } - csv_tibble -} - fetch_debug <- function(epidata_call, format_type = "classic", fields = NULL) { response <- request_impl(epidata_call, format_type, fields) content <- httr::content(response, "text", encoding = "UTF-8") @@ -334,37 +268,3 @@ request_impl <- function(epidata_call, format_type, fields = NULL) { response } - -#' @export -print.epidata_csv <- function(x, ...) { - char_limit <- getOption("epidata_csv__char_limit", default = 300L) - cat( - "# A epidata_csv object with", nchar(x), "characters; showing up to", char_limit, - "characters below. To print the entire string, use `print(as.character(x))`:\n" - ) - cat(substr(x, 1L, char_limit)) - if (nchar(x) > char_limit) { - cat("[...]") - } - cat("\n") - invisible(x) -} - -info_to_type <- function(info, disable_date_parsing = FALSE) { - types <- list( - date = if (disable_date_parsing) { - readr::col_integer() - } else { - readr::col_date(format = "%Y%m%d") - }, - epiweek = readr::col_integer(), - bool = readr::col_logical(), - text = readr::col_character(), - int = readr::col_integer(), - float = readr::col_double(), - categorical = readr::col_factor(info$categories) - ) - r <- types[info$type] - stopifnot(!is.null(r)) - r -} diff --git a/tests/testthat/test-epidatacall.R b/tests/testthat/test-epidatacall.R index c5502c22..ddcae380 100644 --- a/tests/testthat/test-epidatacall.R +++ b/tests/testthat/test-epidatacall.R @@ -1,4 +1,4 @@ -test_that("fetch_tbl", { +test_that("fetch and fetch_tbl", { epidata_call <- covidcast( data_source = "jhu-csse", signals = "confirmed_7dav_incidence_prop", @@ -7,32 +7,21 @@ test_that("fetch_tbl", { time_values = epirange("2020-06-01", "2020-08-01"), geo_values = "ca,fl" ) - # Generated with - # epidata_call %>% - # fetch_debug(format_type = "classic") %>% - # readr::write_rds(testthat::test_path("data/test-classic.rds")) - mockery::stub(fetch_classic, "httr::content", readRDS(testthat::test_path("data/test-classic.rds"))) - mockery::stub(fetch_tbl, "fetch_classic", fetch_classic) - # Generated with - # epidata_call %>% - # fetch_debug(format_type = "csv") %>% - # readr::write_rds(testthat::test_path("data/test-csv.rds")) - mockery::stub(fetch_csv, "httr::content", readRDS(testthat::test_path("data/test-csv.rds"))) - # This test compares the output of a tibble using fetch_tbl and fetch_csv. - # - # 1) fetch_tbl calls fetch_classic, which requests the default (classic - # format) from the API, uses jsonlite::fromJSON to convert the underlying data - # to a data.frame, and finally applies parse_data_frame is used to do the data - # type coersion specified by the epidata_call metadata. - # 2) fetch_csv requests the csv format from the API, then uses readr::read_csv - # to get a data.frame, and has its own methods to enforce data types. - tbl_out <- epidata_call %>% fetch_tbl() - csv_out <- epidata_call %>% fetch_csv() - expect_identical(tbl_out, csv_out) + # This test compares the output of a tibble using fetch and fetch_tbl. + with_mocked_bindings( + { + tbl_out <- epidata_call %>% fetch_tbl() + out <- epidata_call %>% fetch() + }, + # RDS file generated with + # epidata_call %>% + # fetch_debug(format_type = "classic") %>% + # readr::write_rds(testthat::test_path("data/test-classic.rds")) + content = function(...) readRDS(testthat::test_path("data/test-classic.rds")), + .package = "httr" + ) - # # This test compares fetch_tbl with the output of fetch, which should be identical. - out <- epidata_call %>% fetch() expect_identical(out, tbl_out) }) @@ -51,10 +40,14 @@ test_that("fetch_tbl warns on non-success", { readRDS(testthat::test_path("data/test-classic.rds")) %>% jsonlite::fromJSON() %>% `[[<-`("message", "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs.") - mockery::stub(fetch_classic, "jsonlite::fromJSON", debug_response_content_triplet) - mockery::stub(fetch_tbl, "fetch_classic", fetch_classic) - expect_warning(epidata_call %>% fetch_tbl(), - regexp = paste0("epidata warning: ", artificial_warning), - fixed = TRUE + with_mocked_bindings( + { + expect_warning(epidata_call %>% fetch_tbl(), + regexp = paste0("epidata warning: ", artificial_warning), + fixed = TRUE + ) + }, + fromJSON = function(...) debug_response_content_triplet, + .package = "jsonlite" ) }) From 1da2ee4d2f3e9362e5f70c2c6ae8ecfef9de1480 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 26 May 2023 11:42:31 -0700 Subject: [PATCH 2/5] docs: doc --- man/fetch_csv.Rd | 35 ----------------------------------- 1 file changed, 35 deletions(-) delete mode 100644 man/fetch_csv.Rd diff --git a/man/fetch_csv.Rd b/man/fetch_csv.Rd deleted file mode 100644 index 3def231b..00000000 --- a/man/fetch_csv.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/epidatacall.R -\name{fetch_csv} -\alias{fetch_csv} -\title{Fetches the data and returns a tibble or an \code{epidata_csv}} -\usage{ -fetch_csv( - epidata_call, - fields = NULL, - disable_date_parsing = FALSE, - disable_tibble_output = FALSE -) -} -\arguments{ -\item{epidata_call}{an instance of \code{epidata_call}} - -\item{fields}{filter fields} - -\item{disable_date_parsing}{Boolean. Optionally, \code{TRUE} to disable parsing of -columns we expect to be dates, keeping them as character columns instead. -\code{FALSE} (the default) to parse these columns into \code{Date} vectors.} - -\item{disable_tibble_output}{Boolean. Optionally, \code{TRUE} to output a -character vector with the \code{epidata_csv} class (which provides a custom -\code{print} method). \code{FALSE} (the default) to output a tibble.} -} -\value{ -\itemize{ -\item For \code{fetch_csv}: a tibble, or \code{epidata_csv} if requested with -\code{disable_tibble_output = TRUE} -} -} -\description{ -Fetches the data and returns a tibble or an \code{epidata_csv} -} From 2f9464ae0f28c277576e138e246185887c68b3a2 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 26 May 2023 17:53:50 -0700 Subject: [PATCH 3/5] Update tests/testthat/test-epidatacall.R Co-authored-by: brookslogan --- tests/testthat/test-epidatacall.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-epidatacall.R b/tests/testthat/test-epidatacall.R index ddcae380..da420278 100644 --- a/tests/testthat/test-epidatacall.R +++ b/tests/testthat/test-epidatacall.R @@ -39,7 +39,7 @@ test_that("fetch_tbl warns on non-success", { # see generation code above readRDS(testthat::test_path("data/test-classic.rds")) %>% jsonlite::fromJSON() %>% - `[[<-`("message", "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs.") + `[[<-`("message", artificial_warning) with_mocked_bindings( { expect_warning(epidata_call %>% fetch_tbl(), From 0b3fae2622381aea29705fa72a6fc0f043e71a29 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Tue, 30 May 2023 17:55:15 -0700 Subject: [PATCH 4/5] bug(test): correctly mock requests --- tests/testthat/test-epidatacall.R | 46 ++++++++++++++++++------------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-epidatacall.R b/tests/testthat/test-epidatacall.R index da420278..7a0f1d4d 100644 --- a/tests/testthat/test-epidatacall.R +++ b/tests/testthat/test-epidatacall.R @@ -8,12 +8,11 @@ test_that("fetch and fetch_tbl", { geo_values = "ca,fl" ) - # This test compares the output of a tibble using fetch and fetch_tbl. - with_mocked_bindings( - { - tbl_out <- epidata_call %>% fetch_tbl() - out <- epidata_call %>% fetch() - }, + local_mocked_bindings( + request_impl = function(...) NULL, + .package = "epidatr" + ) + local_mocked_bindings( # RDS file generated with # epidata_call %>% # fetch_debug(format_type = "classic") %>% @@ -22,6 +21,8 @@ test_that("fetch and fetch_tbl", { .package = "httr" ) + tbl_out <- epidata_call %>% fetch_tbl() + out <- epidata_call %>% fetch() expect_identical(out, tbl_out) }) @@ -34,20 +35,27 @@ test_that("fetch_tbl warns on non-success", { time_values = epirange("2020-06-01", "2020-08-01"), geo_values = "ca,fl" ) - artificial_warning <- "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs." - debug_response_content_triplet <- + + local_mocked_bindings( + request_impl = function(...) NULL, + .package = "epidatr" + ) + local_mocked_bindings( + content = function(...) NULL, + .package = "httr" + ) + artificial_warning <- "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs." + debug_triplet <- readRDS(testthat::test_path("data/test-classic.rds")) %>% + jsonlite::fromJSON() %>% + `[[<-`("message", artificial_warning) + local_mocked_bindings( # see generation code above - readRDS(testthat::test_path("data/test-classic.rds")) %>% - jsonlite::fromJSON() %>% - `[[<-`("message", artificial_warning) - with_mocked_bindings( - { - expect_warning(epidata_call %>% fetch_tbl(), - regexp = paste0("epidata warning: ", artificial_warning), - fixed = TRUE - ) - }, - fromJSON = function(...) debug_response_content_triplet, + fromJSON = function(...) debug_triplet, .package = "jsonlite" ) + + expect_warning(epidata_call %>% fetch_tbl(), + regexp = paste0("epidata warning: ", artificial_warning), + fixed = TRUE + ) }) From e8ae92a183c806a5c5352099be7bb11fdd7cb0a2 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Tue, 30 May 2023 17:57:32 -0700 Subject: [PATCH 5/5] style: styler --- tests/testthat/test-epidatacall.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-epidatacall.R b/tests/testthat/test-epidatacall.R index 7a0f1d4d..30d5d835 100644 --- a/tests/testthat/test-epidatacall.R +++ b/tests/testthat/test-epidatacall.R @@ -44,10 +44,10 @@ test_that("fetch_tbl warns on non-success", { content = function(...) NULL, .package = "httr" ) - artificial_warning <- "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs." + artificial_warning <- "* This is a warning with a leading asterisk and {braces} to make sure we don't have bulleting/glue bugs." debug_triplet <- readRDS(testthat::test_path("data/test-classic.rds")) %>% - jsonlite::fromJSON() %>% - `[[<-`("message", artificial_warning) + jsonlite::fromJSON() %>% + `[[<-`("message", artificial_warning) local_mocked_bindings( # see generation code above fromJSON = function(...) debug_triplet, @@ -56,6 +56,6 @@ test_that("fetch_tbl warns on non-success", { expect_warning(epidata_call %>% fetch_tbl(), regexp = paste0("epidata warning: ", artificial_warning), - fixed = TRUE + fixed = TRUE ) })