R/fetch_FRED.R

In fognyc/factorr: Tools for Retrieving Factor Time-Series Hosted on Remote Servers

#' @importFrom magrittr "%>%"

fetch_fred_series_obs <- function(hdl_str, dest_dir, save_to_disk = T,
                                  observation_start = NULL,
                                  observation_end = NULL) {

  # Select catalog entry and match FRED series_id parameter
  c_entry <- dplyr::filter(catalog, .data$hdl == hdl_str)
  series_id <- c_entry$internal_id

  # ----------------------------------------------------------------------------
  # Set up dir/file names
  #
  # < path_df_ >, < path_d_ > and < path_f_ > are reserved prefix,
  # where 'd' stand for directory and 'f' stands for file.
  #
  path_df_audit <- stringr::str_glue(dest_dir, '/Audit/', hdl_str, '.pdf')
  path_df_series_csv <- stringr::str_glue(dest_dir, '/Uncompressed/',
                                          hdl_str, '.csv')
  # ----------------------------------------------------------------------------


  # Validate function arguments
  if (is.character(series_id) == FALSE) {
    stop("Series_id must be in characters")
  }

  if (is.null(observation_start) == TRUE) {
    observation_start <- "1776-07-04"
  }

  if (is.null(observation_end) == TRUE) {
    observation_end <- "9999-12-31"
  }

  # JSON call
  json_url_prefix_obs <- stringr::str_glue(c_entry$url_src,
                                           "series/observations",
                                           "?series_id=")

  obj <-
    try({
      jsonlite::fromJSON(txt =
                           paste0(json_url_prefix_obs,
                                  series_id,
                                  "&observation_start=",
                                  observation_start,
                                  "&observation_end=",
                                  observation_end,
                                  "&output_type=2",
                                  "&api_key=", Sys.getenv('FRED'),
                                  "&file_type=json")
      )}, silent = TRUE)

  if (class(obj) == "try-error") {
    stop("Download of specified time-series failed")
  }

  tbl <- readr::type_convert(obj$observations,
                             col_types = readr::cols(
                               readr::col_date(format = "%Y-%m-%d"),
                               readr::col_double()),
                             na = c(".", "NA")) %>%
    tibble::as_tibble() %>%
    magrittr::set_colnames(value = c('date', 'series'))

  # Validate format conversion from readr::type_convert
  if( attr(tbl$date, which = 'class') != 'Date' ) {
    stop('< date > format failed in readr::type_convert', call. = T)
  }

  if( is.double(tbl$series) == FALSE) {
    stop('< doule > format failed in readr::type_convert', call. = T)
  }

  tbl <- magrittr::set_colnames(x = tbl,
                                value = c('date', c_entry$alias_name))

  if( save_to_disk ) {
    readr::write_csv(x = tbl, path = path_df_series_csv)
  }

  # ----------------------------------------------------------------------------
  # Auditing
  fetch_fred_series_tags(series_id = series_id,
                         meta = list(
                           path_df_audit =  path_df_audit,
                           path_df_series_csv = path_df_series_csv,
                           c_entry = c_entry,
                           request_stamp = as.character(Sys.time()),
                           hasNA = anyNA(tbl[ ,2])))

  tags <- get_tags(series_id = series_id, c_entry = c_entry)
  attr(tbl, which = 'catalog_hdl') <- hdl_str
  attr(tbl, which = 'series_freq') <- tags$series_freq
  attr(tbl, which = 'units') <- tags$series_units
  # ----------------------------------------------------------------------------

  return(tbl)
}


fetch_fred_series_tags <- function(series_id,
                                   meta = list(path_df_audit =  NULL,
                                               path_df_series_csv = NULL,
                                               c_entry = NULL,
                                               request_stamp = NULL,
                                               hasNA = NULL)
                                   ) {

  # Validate function arguments
  if (is.character(series_id) == FALSE) {
    stop("Series_id must be in characters")
  }

  if (is.null(meta$c_entry) == TRUE) {
    stop('Missing catalog entry in < meta > list argument')
  }

  # JSON call
  json_url_prefix_series <- stringr::str_glue(meta$c_entry$doc_src,
                                              "?series_id=")

  obj <-
    try({
      jsonlite::fromJSON(txt =
                           paste0(json_url_prefix_series,
                                  series_id,
                                  "&api_key=", Sys.getenv('FRED'),
                                  "&file_type=json")
      )}, silent = TRUE)

  if (class(obj) == "try-error") {
    stop("Download of specified time-series tags failed")
  }

  caption_str <- as.character(stringr::str_glue(meta$c_entry$desc,
                                                ': Attributes'))
  tbl_attr <- tibble::tibble(
    file = c( fs::path_file(meta$path_df_series_csv)),
    user = c( fs::file_info(meta$path_df_series_csv)$user),
    device_id =
      c( as.character( fs::file_info(meta$path_df_series_csv)$device_id )),
    permissions =
      c( as.character( fs::file_info(meta$path_df_series_csv)$permissions )),
    size = c( fs::file_info(meta$path_df_series_csv)$size),
    birth =
      c( as.character( fs::file_info(meta$path_df_series_csv)$birth_time) )
  ) %>% xtable::xtable(caption = caption_str)

  caption_str <- as.character(stringr::str_glue(meta$c_entry$desc,
                                                ': Time Stamps'))
  tbl_times <- tibble::tibble(
    file = c( fs::path_file(meta$path_df_series_csv)),
    modification =
      c( as.character(
        fs::file_info(meta$path_df_series_csv)$modification_time )),
    access =
      c( as.character( fs::file_info(meta$path_df_series_csv)$access_time) ),
    change =
      c( as.character( fs::file_info(meta$path_df_series_csv)$change_time) )
  ) %>% xtable::xtable(caption = caption_str)


  FRED_notice <- stringr::str_glue('Pursuant to the FRED\\textregistered',
                                   'API Terms of Use,',
                                   'note that this product uses the',
                                   'FRED\\textregistered API',
                                   'but is not endorsed or certified by the',
                                   'Federal Reserve Bank of St. Louis.',
                                   .sep = ' ')
  FRED_terms <- 'https://research.stlouisfed.org/docs/api/terms_of_use.html'

  obj <- obj$seriess
  arsenal::write2pdf(file = meta$path_df_audit,
                     object = list(
                       obj$title,
                       stringr::str_glue('Source: FRED,',
                                         'Federal Reserve Bank of St. Louis.',
                                         FRED_notice, 'See', FRED_terms,
                                         'for Terms of Use.', .sep = ' '),
                       stringr::str_glue('Series id: ', series_id),
                       stringr::str_glue('Start: ', obj$observation_start),
                       stringr::str_glue('End: ', obj$observation_end),
                       stringr::str_glue('Frequency: ', obj$frequency),
                       stringr::str_glue('Units: ', obj$units),
                       obj$seasonal_adjustment,
                       stringr::str_glue('FRED Last Update: ',
                                         obj$last_updated),
                       'NOTES:', obj$notes,
                       "\\newpage",
                       stringr::str_glue('Login: ',
                                         as.character(
                                           Sys.info()['login'])),
                       stringr::str_glue('User: ',
                                         as.character(
                                           Sys.info()['user'])),
                       stringr::str_glue('Effective user: ',
                                         as.character(
                                           Sys.info()['effective_user'])),
                       stringr::str_glue('Server Request:',
                                         meta$request_stamp,
                                         Sys.timezone(), .sep = ' '),
                       stringr::str_glue('JSON observations prefix: ',
                                         stringr::str_glue(
                                           meta$c_entry$url_src,
                                           "series/observations")),
                       stringr::str_glue('JSON series (tags, notes) prefix: ',
                                         meta$c_entry$doc_src),
                       stringr::str_glue('Series has NA: ',
                                         meta$hasNA),
                       stringr::str_glue('catalog handle: ',
                                         meta$c_entry$hdl),
                       stringr::str_glue('catalog description: ',
                                         meta$c_entry$desc),
                       stringr::str_glue('catalog internal id: ',
                                         meta$c_entry$internal_id),
                       tbl_attr, tbl_times
                     ),
                     quiet = TRUE)
}


get_tags <- function(series_id, c_entry = NULL) {

  # Validate function arguments
  if (is.character(series_id) == FALSE) {
    stop("Series_id must be in characters")
  }

  if (is.null(c_entry) == TRUE) {
    stop('Missing catalog entry argument')
  }

  # JSON call
  json_url_prefix_series <- stringr::str_glue(c_entry$doc_src,
                                              "?series_id=")

  obj <-
    try({
      jsonlite::fromJSON(txt =
                           paste0(json_url_prefix_series,
                                  series_id,
                                  "&api_key=", Sys.getenv('FRED'),
                                  "&file_type=json")
      )}, silent = TRUE)

  if (class(obj) == "try-error") {
    stop("Download of specified time-series tags failed")
  }

  return ( list(series_freq = obj$seriess$frequency,
             series_units = obj$seriess$units) )
}