Merge pull request #167 from cmu-delphi/ds/tibble

refactor: use tibbles for metadata printing

Author: dshemetov

DESCRIPTION

@@ -30,6 +30,7 @@ Imports:
     jsonlite,
     magrittr,
     MMWRweek,
+    purrr,
     readr,
     tibble,
     xml2

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)

R/covidcast.R

@@ -59,45 +59,59 @@ 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
 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, "source"))
+  tib$name <- unname(map_chr(x, "name"))
+  tib$description <- unname(map_chr(x, "description"))
+  tib$reference_signal <- unname(map_chr(x, "reference_signal"))
+  tib$license <- unname(map_chr(x, "license"))
+  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")], ...)
 }

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