From 8155c93c17ff1010e8b0b45bbed674ee3435b0f8 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 1 Sep 2023 17:29:22 -0700 Subject: [PATCH] refactor: use tibbles for metadata printing --- DESCRIPTION | 1 + NAMESPACE | 7 +- R/covidcast.R | 125 +++++++++++++++----------------- tests/testthat/test-covidcast.R | 13 +--- 4 files changed, 69 insertions(+), 77 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ee40aa12..cd8ed922 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,6 +30,7 @@ Imports: jsonlite, magrittr, MMWRweek, + purrr, readr, tibble, xml2 diff --git a/NAMESPACE b/NAMESPACE index 7a4b5a8f..a1910cdf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,9 +1,10 @@ # Generated by roxygen2: do not edit by hand -S3method(as.data.frame,covidcast_data_signal_list) -S3method(as.data.frame,covidcast_data_source_list) +S3method(as_tibble,covidcast_data_signal_list) +S3method(as_tibble,covidcast_data_source_list) S3method(print,covidcast_data_signal) S3method(print,covidcast_data_source) +S3method(print,covidcast_epidata) S3method(print,epidata_call) export("%>%") export(avail_endpoints) @@ -65,6 +66,8 @@ importFrom(httr,modify_url) importFrom(httr,stop_for_status) importFrom(jsonlite,fromJSON) importFrom(magrittr,"%>%") +importFrom(purrr,map_chr) +importFrom(purrr,map_lgl) importFrom(readr,read_csv) importFrom(tibble,as_tibble) importFrom(tibble,tibble) diff --git a/R/covidcast.R b/R/covidcast.R index 088a0387..932b3593 100644 --- a/R/covidcast.R +++ b/R/covidcast.R @@ -59,36 +59,50 @@ parse_source <- function(source, base_url) { r } -#' @method as.data.frame covidcast_data_signal_list +#' @method as_tibble covidcast_data_signal_list +#' @importFrom tibble as_tibble +#' @importFrom purrr map_chr map_lgl #' @export -as.data.frame.covidcast_data_signal_list <- function(x, ...) { - as.data.frame( - do.call(rbind, lapply(x, function(z) { - sub <- z[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(z$geo_types), collapse = ",") - sub - })), - row.names = sapply(x, function(y) y$key), - ... - ) +as_tibble.covidcast_data_signal_list <- function(x, ...) { + tib <- list() + tib$source <- unname(map_chr(x, "source")) + tib$signal <- unname(map_chr(x, "signal")) + tib$name <- unname(map_chr(x, "name")) + tib$active <- unname(map_lgl(x, "active")) + tib$short_description <- unname(map_chr(x, "short_description")) + tib$description <- unname(map_chr(x, "description")) + tib$time_type <- unname(map_chr(x, "time_type")) + tib$time_label <- unname(map_chr(x, "time_label")) + tib$value_label <- unname(map_chr(x, "value_label")) + tib$format <- unname(map_chr(x, "format")) + tib$category <- unname(map_chr(x, "category")) + tib$high_values_are <- unname(map_chr(x, "high_values_are")) + if ("is_smoothed" %in% names(x)) { + tib$is_smoothed <- unname(map_lgl(x, "is_smoothed")) + } else { + tib$is_smoothed <- NA + } + if ("is_weighted" %in% names(x)) { + tib$is_weighted <- unname(map_lgl(x, "is_weighted")) + } else { + tib$is_weighted <- NA + } + if ("is_cumulative" %in% names(x)) { + tib$is_cumulative <- unname(map_lgl(x, "is_cumulative")) + } else { + tib$is_cumulative <- NA + } + if ("has_stderr" %in% names(x)) { + tib$has_stderr <- unname(map_lgl(x, "has_stderr")) + } else { + tib$has_stderr <- NA + } + if ("has_sample_size" %in% names(x)) { + tib$has_sample_size <- unname(map_lgl(x, "has_sample_size")) + } else { + tib$has_sample_size <- NA + } + as_tibble(tib) } #' @export @@ -96,8 +110,8 @@ print.covidcast_data_source <- function(x, ...) { print(x$name, ...) print(x$source, ...) print(x$description, ...) - signals <- as.data.frame(x$signals) - print(signals[, c("signal", "name", "short_description")], ...) + signals <- as_tibble(x$signals) + print(signals[, c("signal", "short_description")], ...) } #' Creates the COVIDcast Epidata autocomplete helper @@ -152,45 +166,26 @@ covidcast_epidata <- function(base_url = global_base_url, timeout_seconds = 30) ) } -#' @method as.data.frame covidcast_data_source_list +#' @method as_tibble covidcast_data_source_list #' @export -as.data.frame.covidcast_data_source_list <- function(x, ...) { - as.data.frame( - do.call( - rbind, - lapply( - x, - FUN = function(z) { - cols <- c( - "source", "name", "description", "reference_signal", - "license" - ) - sub <- z[cols] - sub$signals <- paste0( - sapply(z$signals, function(y) y$signal), - collapse = "," - ) - sub - } - ) - ), - row.names = sapply(x, function(z) z$source), - ... - ) +as_tibble.covidcast_data_source_list <- function(x, ...) { + tib <- list() + tib$source <- unname(map_chr(x$sources, "source")) + tib$name <- unname(map_chr(x$sources, "name")) + tib$description <- unname(map_chr(x$sources, "description")) + tib$reference_signal <- unname(map_chr(x$sources, "reference_signal")) + tib$license <- unname(map_chr(x$sources, "license")) + tib <- as_tibble(tib) } +#' @export print.covidcast_epidata <- function(x, ...) { print("COVIDcast Epidata Fetcher") print("Sources:") - sources <- as.data.frame(x$sources) - print(sources[1:5, c("source", "name")], ...) - if (nrow(sources) > 5) { - print(paste0((nrow(sources) - 5), " more...")) - } + sources <- as_tibble(x$sources) + print(sources[, c("source", "name")], ...) + print("Signals") - signals <- as.data.frame(x$signals) - print(signals[1:5, c("source", "signal", "name")], ...) - if (nrow(signals) > 5) { - print(paste0((nrow(signals) - 5), " more...")) - } + signals <- as_tibble(x$signals) + print(signals[, c("source", "signal", "name")], ...) } diff --git a/tests/testthat/test-covidcast.R b/tests/testthat/test-covidcast.R index bf6e43b3..d470af24 100644 --- a/tests/testthat/test-covidcast.R +++ b/tests/testthat/test-covidcast.R @@ -1,5 +1,5 @@ test_that("covidcast", { - covidcast_api <- epidatr:::covidcast_epidata() + covidcast_api <- epidatr::covidcast_epidata() expect_identical( covidcast_api$sources$`fb-survey`$signals$smoothed_cli$call( "nation", @@ -19,24 +19,17 @@ test_that("covidcast", { ) }) -# quite minimal, could probably use some checks that the fields are as desired -test_that("dataframe converters", { - res <- epidatr:::covidcast_epidata()$sources %>% as.data.frame() - expect_identical(class(res), "data.frame") - res <- epidatr:::covidcast_epidata()$signals %>% as.data.frame() - expect_identical(class(res), "data.frame") -}) test_that("http errors", { # see generate_test_data.R local_mocked_bindings( do_request = function(...) readRDS(testthat::test_path("data/test-do_request-httpbin.rds")) ) - expect_error(epidatr:::covidcast_epidata(), class = "http_400") + expect_error(epidatr::covidcast_epidata(), class = "http_400") }) test_that("name completion", { - all_names <- names(epidatr:::covidcast_epidata()$signals) + all_names <- names(epidatr::covidcast_epidata()$signals) expect_identical(all_names, all_names) })