R/ustfd.R

In ustfd: API Client for US Treasury Fiscal Data

#' Retrieve Fiscal Data API in a single call
#'
#' @description
#'
#' `ustfd_simple()` aggregates the workflow for retrieving data from the API
#' into a single call.
#'
#' @inheritParams ustfd_query
#' @param user_agent optional string
#'
#' @return a list containing the following items
#'  * `meta` - the metadata returned by the API
#'  * `data` - the payload returned by the API in table form.
#'  See [`ustfd_response_payload()`]
#'
#' @export
#'
#' @family ustfd_user
#'
#' @examples
#' \dontrun{
#' library(ustfd)
#'
#' exchange_rates <- ustfd_simple(
#'   'v1/accounting/od/rates_of_exchange',
#'    fields = c(
#'     'country_currency_desc', 'exchange_rate','record_date','effective_date'
#'    ),
#'    filter = list(
#'      record_date = c('>=' = '2020-01-01'),
#'      country_currency_desc = list('in' = c('Canada-Dollar','Mexico-Peso'))
#'    )
#' )
#' }

ustfd_simple <- function(
  endpoint, filter=NULL, fields=NULL, sort=NULL, page_size=NULL, page_number=NULL,
  user_agent='http://github.com/groditi/ustfd'
  ){
  query <- ustfd_query(endpoint, filter, fields, sort, page_size, page_number)
  response <- ustfd_request(query, user_agent)
  return(
    list(
      meta = ustfd_response_meta_object(response),
      data = ustfd_response_payload(response)
    )
  )

}

#' Retrieve Data From the U.S. Bureau Of the Fiscal Service API
#'
#' @description
#'
#' `ustfd_request()`  will execute queries against the Fiscal Data API. Queries
#' can generated using [ustfd_query()].
#'
#' @param query list generated by one of the query generating functions
#' @param user_agent string, optional
#' @param process_response function, optional. processes the `httr` response
#'  object. Defaults to [`ustfd_json_response()`] which will return the JSON
#'  payload parsed into a list
#' @param ... further arguments will be passed to `process_response` when called
#'
#' @return a httr response object
#'
#' @export
#'
#' @family ustfd_low_level
#'
#' @examples
#' \dontrun{
#' library(ustfd)
#' query <- ustfd_query('v1/accounting/dts/dts_table_2', sort =c('-record_date'))
#' response <- ustfd_request(query)
#' payload_table <- ustfd_response_payload(response)
#' payload_meta <- ustfd_response_meta_object(response)
#' }

ustfd_request <- function(
  query,
  user_agent='http://github.com/groditi/ustfd',
  process_response = ustfd_json_response,
  ...
){
  url <- utils::URLdecode(ustfd_url(query))
  response <- httr::GET(url, httr::user_agent(user_agent))
  #httr::stop_for_status(response)
  if(response$status_code > 200){
    msg_text <- sprintf('Status code "%s" for URL %s', response$status_code, url)
    rlang::warn(msg_text)
    rlang::abort(httr::http_status(response)$message)
  }

  return(process_response(response, ...))
}

#' Process JSON Response of a Successful API Query
#'
#' @description
#'
#' `ustfd_json_response()`  will process the response to a successful request
#' from Fiscal Data API and translate a JSON object into a R data structure.
#'
#' @param response an httr response returned by [ustfd_request()]
#' @param ... additional arguments passed to `httr::content`
#'
#' @return a list
#'
#' @export
#'
#' @family ustfd_low_level
#'
#' @examples
#' \dontrun{
#' library(ustfd)
#' query <- ustfd_query('v1/accounting/dts/dts_table_2', sort =c('-record_date'))
#' response <- ustfd_request(query)
#' payload_table <- ustfd_response_payload(response)
#' payload_meta <- ustfd_response_meta_object(response)
#' }

ustfd_json_response <- function(response, ...){
  if(httr::headers(response)[['content-type']] != 'application/json')
    rlang::abort(paste(httr::headers(response)[['content-type']], 'is not JSON'))

  parsed <- httr::content(response, as = 'parsed', simplifyVector = FALSE, ...)
  if('error' %in% names(parsed))
    rlang::abort(parsed$message)

  return(parsed)
}

#' Extract Metadata From Parsed API Response
#'
#' @description
#'
#' `ustfd_response_meta_object()`  will return the meta object included in a
#' successful API response. The meta object is a list with the following items:
#'
#' * `count` - the number of records in the response
#' * `labels` - a named list of labels for each field
#' * `dataTypes` - a named list describing the data type for each field
#' * `dataFormats` - a named list describing the data format for each field
#' * `total-count` - the total number of records matching the query
#' * `total-pages` - the total number of pages of records matching the query
#'
#'
#' @param response a parsed response returned by [ustfd_json_response()]
#'
#' @return a list
#'
#' @export
#'
#' @family ustfd_low_level
#'
#' @examples
#' \dontrun{
#' library(ustfd)
#' query <- ustfd_query('v1/accounting/dts/dts_table_2', sort =c('-record_date'))
#' response <- ustfd_request(query)
#' payload_table <- ustfd_response_payload(response)
#' payload_meta <- ustfd_response_meta_object(response)
#' }

ustfd_response_meta_object <- function(response){
  response$meta
}

#' Extract Payload as Table From Parsed API Response
#'
#' @description
#'
#' `ustfd_response_payload()` will return the results of the query in tabular
#' format in the form of a tibble with one column for each field returned and
#' one row for every record returned in the same order they were returned.
#'
#' @param response a parsed response returned by [ustfd_json_response()]
#'
#' @return a tibble
#'
#' @export
#'
#' @family ustfd_low_level
#'
#' @examples
#' \dontrun{
#' library(ustfd)
#' query <- ustfd_query('v1/accounting/dts/dts_table_2', sort =c('-record_date'))
#' response <- ustfd_request(query)
#' payload_table <- ustfd_response_payload(response)
#' payload_meta <- ustfd_response_meta_object(response)
#' }
#'
ustfd_response_payload <- function(response){
  meta <- ustfd_response_meta_object(response)
  empty_prototype <- empty_table_prototype(meta$dataTypes)

  if(meta$count == 0) return(empty_prototype)

  parsed_payload(response$data, meta$dataTypes)
}

parsed_payload <- function(data, data_types){
  col_parsers <- col_processor_map(data_types)
  tbl <- lapply(
    payload_transpose(data, template = names(data_types)),
    function(x){ x[x == 'null'] <- NA; x}
  )
  rm(data)
  #lapply( # against all expectations this actually profiles worse than imap
  #  rlang::set_names(names(tbl), names(tbl)),
  #  function(nm) col_parsers[[nm]](tbl[[nm]])
  #)
  parsed <- purrr::imap(tbl, function(.x, nm) col_parsers[[nm]](.x))
  tibble::as_tibble(parsed)
}

#purrr::list_transpose is slow and dplyr::bind_rows uses a lot of memory.
payload_transpose <- function(x, template){
  len <- length(x)
  wid <- length(template)
  y <- rlang::rep_named(template, list())
  for(col in template){
    y[[col]] <- vapply(x, .subset2, character(1), col, USE.NAMES = FALSE)
  }
  y
}

col_processor_map <- function(types){
  type_processor_map <- list(
    'DATE' = lubridate::ymd,
    'PERCENTAGE' = readr::parse_number,
    'CURRENCY' = readr::parse_number,
    'NUMBER' = as.numeric,
    'INTEGER' = as.numeric,
    'YEAR' = as.integer,
    'MONTH' = as.integer,
    'DAY' = as.integer,
    'QUARTER' = as.integer,
    'STRING' = as.character,
    '***' = as.character
  )

  types_c <- as.character(types)
  unknown_types <- which(!types_c %in% names(type_processor_map))
  if(length(unknown_types) > 0){
    rlang::warn(sprintf("Unknown mapping for type '%s'.", types_c[unknown_types]))
    types_c[unknown_types] <- '***'
  }

  purrr::set_names(
    type_processor_map[types_c],
    names(types)
  )
}

record_processor_factory <- function(types){
  record_processors <- col_processor_map(types)
  processor <- function(record){
    purrr::imap(
      purrr::modify_if(record, ~.x == 'null', ~NA_character_),
      ~ record_processors[[.y]](.x)
    )
  }
  return(processor)
}

empty_table_prototype <- function(types){
  prototypes <- list(
    'DATE' = lubridate::Date(0),
    'PERCENTAGE' = double(0),
    'CURRENCY' = double(0),
    'NUMBER' = double(0),
    'YEAR' = integer(0),
    'MONTH' = integer(0),
    'DAY' = integer(0),
    'QUARTER' = integer(0),
    'STRING' = character(0)
  )

  tbl_prototype <- purrr::set_names(
    prototypes[unlist(types)],
    names(types)
  )
  return(tibble::tibble(!!!tbl_prototype))
}