R/availability.R

In CT-Data-Haven/cwi: Prep for DataHaven's Community Wellbeing Index

# dynamically check availability of:
# * qwi by state (prev qwi_avail)
# * census available (prev cb_avail)
# use caching & memoization with cachem & memoise

## CENSUS BUREAU: DATASETS IN THE API BY PROGRAM ----

#' @title Check availability of datasets
#' @description These two functions check for the availability of datasets needed
#' to formulate API queries.
#' * `check_cb_avail` finds all available vintages of
#' major surveys under the Census Bureau's ACS and Decennial programs for the
#' mainland US.
#' * `check_qwi_avail` finds all years of QWI data available per state.
#'
#' Previously, these were datasets built into the package, which ran the risk of
#' being outdated and therefore missing the availability of new data. These functions
#' need to read data from the internet, but are memoized so that the results are
#' reasonably up-to-date without having to make API calls repeatedly.
#' @return **For `check_cb_avail`**: A data frame with columns for vintage, program (e.g. "acs"), survey (e.g. "acs5"),
#' and title, as returned from the Census Bureau API.
#' @examples
#' \dontrun{
#' if (interactive()) {
#'     cb_avail <- check_cb_avail()
#'     cb_avail |>
#'         dplyr::filter(program == "dec", vintage == 2020)
#' }
#' }
#' @export
#' @seealso [US Census Bureau API Discovery Tool](https://www.census.gov/data/developers/updates/new-discovery-tool.html) [LED Extraction Tool](https://ledextract.ces.census.gov/)
#' @rdname availability
#' @family utils
check_cb_avail <- function() {
    # ALL TABLES AVAILABLE: VINTAGE + PROGRAM + SURVEY CODE
    surveys <- list(
        acs = c("acs1", "acs3", "acs5"),
        dec = c(
            "ddhca", "ddhcb", "dhc", "pl",
            "sf1", "sf2", "sf3", "sf4"
        )
    )
    surveys <- tibble::enframe(surveys, name = "program", value = "survey")
    surveys <- tidyr::unnest(surveys, survey)

    avail <- safe_read_avail("https://api.census.gov/data.json", "json")
    avail <- avail[["dataset"]]
    avail <- purrr::map(avail, cb_meta_list)
    avail <- purrr::compact(avail)
    avail <- dplyr::bind_rows(avail)
    avail <- tidyr::unnest_wider(avail, dataset, names_sep = "", names_repair = "unique")
    # drop survey subsets
    avail <- avail[is.na(avail$dataset3), ]
    avail <- dplyr::select(avail, vintage, program = dataset1, survey = dataset2, title)
    avail <- dplyr::semi_join(avail, surveys, by = c("program", "survey"))
    avail <- dplyr::arrange(avail, vintage, program, survey)
    avail
}

cb_meta_list <- function(x) {
    list(
        vintage = x$c_vintage,
        dataset = list(x$c_dataset),
        title = x$title
    )
}

## QWI: STATES + YEARS AVAILABLE ----
#' @return **For check_qwi_avail`**: A data frame with columns for state FIPS code, earliest year available, and most recent year available.
#' @examples
#' \dontrun{
#' if (interactive()) {
#'     qwi_avail <- check_qwi_avail()
#'     qwi_avail |>
#'         dplyr::filter(state_code == "09")
#' }
#' }
#' @export
#' @rdname availability
check_qwi_avail <- function() {
    # scrape start & end years per state from html table
    # get fips code instead of state abbrevs
    avail <- safe_read_avail("https://ledextract.ces.census.gov/loading_status.html", "html")
    avail <- rvest::html_table(avail)[[1]]
    avail <- clean_names(avail)
    avail <- dplyr::mutate(avail, dplyr::across(c(start_quarter, end_quarter), function(x) {
        x <- stringr::str_extract(x, "\\d{4}")
        as.numeric(x)
    }))
    states <- dplyr::distinct(tidycensus::fips_codes, state, state_code)
    avail <- dplyr::inner_join(avail, states, by = "state")
    avail <- dplyr::select(avail, state_code, start_year = start_quarter, end_year = end_quarter)
    avail <- dplyr::arrange(avail, state_code)
    avail
}

safe_read_avail <- function(url, type) {
    if (type == "json") {
        func <- jsonlite::read_json
    } else if (type == "html") {
        func <- rvest::read_html
    } else {
        cli::cli_abort("Incorrect file type")
    }
    safe_func <- purrr::safely(func)
    res <- safe_func(url)
    if (is.null(res$error)) {
        res$result
    } else {
        cli::cli_abort("Unable to get available data from {.url {url}}. Check the Census API.")
    }
}