Nothing
#' 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,
'CURRENCY0' = 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))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.