R/internal.R

In eFRED: Fetch Data from the Federal Reserve Economic Database

.use_default_key <- function(){
  key <- Sys.getenv("FRED_KEY")
  if (key == "")
    stop("No FRED API key was found. Keys are free and can be requested at ",
         "<https://fred.stlouisfed.org/docs/api/api_key.html>. Register the key ",
         "for the session with set_fred_key(\"your-32-character-key\"), or pass ",
         "it directly through the 'key' argument.", call. = FALSE)
  key
}


# Shared state used only to keep the "resource unavailable" report readable when
# a single call makes many requests (e.g. fred_state over 51 states): within one
# such loop each distinct cause is reported once rather than once per series.
.fred_env <- new.env(parent = emptyenv())

.fred_unavailable <- function(msg){
  full <- sub("[[:space:]]+$", "", paste0("eFRED: ", msg))
  if (!grepl("[.!?]$", full)) full <- paste0(full, ".")
  full <- paste(full, "No data were returned.")
  if (isTRUE(.fred_env$in_loop)){
    if (full %in% .fred_env$seen) return(invisible(NULL))
    .fred_env$seen <- c(.fred_env$seen, full)
  }
  message(full)
  invisible(NULL)
}

.fred_loop_begin <- function(){
  if (isTRUE(.fred_env$in_loop)) return(invisible(FALSE))
  .fred_env$in_loop <- TRUE
  .fred_env$seen    <- character()
  invisible(TRUE)
}

.fred_loop_end <- function(owner){
  if (isTRUE(owner)){
    .fred_env$in_loop <- FALSE
    .fred_env$seen    <- character()
  }
  invisible(NULL)
}

.id_parse <- function(...){
  series <- list(...)
  if (length(series) == 0) stop("No series provided.")
  vals <- sapply(series, function(i) toupper(as.character(i)))
  nm <- names(series)
  if (is.null(nm)){
    vals <- Reduce(c, vals)
    nm   <- vals
  } else {
    nm <- Reduce(c, sapply(seq_along(nm), function(i){
      if (length(vals[[i]]) > 1){
        nmval <- names(vals[[i]])
        if (is.null(nmval)) nmval <- vals[[i]]
        if (nm[i] == "") return(nmval)
        return(paste0(nm[i], nmval))
      } else if (nm[i] == "") return(vals[[i]])
      nm[i]
    }))
    vals <- Reduce(c, vals)
  }
  list(id = vals, name = nm)
}

.real_parse <- function(start, end){
  if (!is.null(start)){start <- paste0("&realtime_start=", start)
  } else {start <- ""}
  if (!is.null(end)){end <- paste0("&realtime_end=", end)
  } else {end <- ""}
  paste0(start, end)
}

.loop_id_list <- function(series, fun, key, other){
  owner <- .fred_loop_begin()
  on.exit(.fred_loop_end(owner))
  results <- lapply(seq_along(series$id), function(i){
    tryCatch(
      fun(series$id[i], key, other),
      error = function(e){
        warning(paste0("Series '", series$name[i], "' could not be retrieved: ",
                       conditionMessage(e)), call. = FALSE)
        NULL
      }
    )
  })
  names(results) <- series$name
  results <- results[!vapply(results, is.null, logical(1))]
  if (length(results) == 0) return(invisible(NULL))
  results
}

.drop_null <- function(x) x[!vapply(x, is.null, logical(1))]

.loop_id_rbind <- function(series, fun, key, other){
  owner <- .fred_loop_begin()
  on.exit(.fred_loop_end(owner))
  results <- lapply(seq_along(series$id), function(i){
    tryCatch(
      {
        ser <- fun(series$id[i], key, other)
        if (is.null(ser)) return(NULL)
        ser$group <- series$name[i]
        ser
      },
      error = function(e){
        warning(paste0("Series '", series$name[i], "' could not be retrieved: ",
                       conditionMessage(e)), call. = FALSE)
        NULL
      }
    )
  })
  Reduce(rbind, .drop_null(results))
}

.loop_id_merge <- function(series, fun, key, other, all=TRUE, by="date"){
  owner <- .fred_loop_begin()
  on.exit(.fred_loop_end(owner))
  results <- lapply(seq_along(series$id), function(i){
    tryCatch(
      {
        ser <- fun(series$id[i], key, other)
        if (is.null(ser)) return(NULL)
        colnames(ser)[which(colnames(ser) == "value")] <- series$name[i]
        ser
      },
      error = function(e){
        warning(paste0("Series '", series$name[i], "' could not be retrieved: ",
                       conditionMessage(e)), call. = FALSE)
        NULL
      }
    )
  })
  results <- .drop_null(results)
  if (length(results) == 0) return(NULL)
  df <- results[[1]]
  if (length(results) > 1){
    for (i in 2:length(results)) df <- merge(df, results[[i]], all=all, by=by)
  }
  df
}

.loop_general_rbind <- function(ids, fun, key, other){
  owner <- .fred_loop_begin()
  on.exit(.fred_loop_end(owner))
  results <- lapply(ids, function(i){
    tryCatch(
      {
        ser <- fun(i, key, other)
        if (is.null(ser)) return(NULL)
        ser$group <- i
        ser
      },
      error = function(e){
        warning(paste0("ID '", i, "' could not be retrieved: ",
                       conditionMessage(e)), call. = FALSE)
        NULL
      }
    )
  })
  Reduce(rbind, .drop_null(results))
}


.args_parse <- function(args){
  if (length(args) == 0) return("")
  nm <- names(args)
  if (is.null(nm)) stop("API arguments must be named.")
  paste(
    sapply(seq_along(args), function(i){
      paste0("&",nm[i],"=",as.character(args[[i]]))
    }),
    collapse=""
  )
}