R/utils.R

In jesse-smith/essence: Interface to TN ESSENCE

#' Check/Assert that an Object is Either `TRUE` or `FALSE`
#'
#' @param x The object to check
#'
#' @return `check_*()` returns `TRUE` if successful or a error message string
#'   otherwise; `assert_*()` returns `x` (invisibly) if successful or an
#'   error otherwise
#'
#' @keywords internal
#'
#' @aliases assert_bool
check_bool <- function(x) {
  checkmate::check_logical(x, any.missing = FALSE, len = 1L, null.ok = FALSE)
}

#' @rdname check_bool
assert_bool <- function(x) {
  checkmate::assert_logical(
    x,
    any.missing = FALSE,
    len = 1L,
    null.ok = FALSE,
    .var.name = rlang::expr_label(rlang::enexpr(x))
  )
}

#' Standardize a Class
#'
#' Combine class names and remove missing values
#'
#' @param ... `character` vectors of class names
#'
#' @return A `character` vector of class names
#'
#' @keywords internal
std_class <- function(...) {

  chr_reduce <- rlang::as_function(~ vec_c(.x, .y, .ptype = character()))

  not_na <- rlang::as_function(~ rlang::is_true(!rlang::is_na(.x)))

  class <- Filter(not_na, Reduce(chr_reduce, rlang::list2(...)))

  if (vec_is_empty(class)) character() else vec_set_names(vec_data(class), NULL)
}

#' Informative \code{\link[httr:stop_for_status]{stop_for_status()}} Wrapper
#'
#' `abort_status()` is just like
#' \code{\link[httr:stop_for_status]{stop_for_status()}}, except it prints the
#' response message returned by the server on error (if any).
#'
#' @param x A `response` object
#'
#' @param task `character`. A message to display to the use as
#'   "Failed to `task`"
#'
#' @return If request was successful, the response (invisibly). Otherwise,
#'   raised a classed http error, as generated by
#'   \code{\link[httr:http_condition]{http_condition()}}
#'
#' @keywords internal
abort_status <- function(x, task = "complete request") {
  httr::stop_for_status(
    x,
    task = paste0(task, ": ", httr::content(x))
  )
}

#' Use \code{\link[httr:authenticate]{authenticate()}} with `secret` Credentials
#'
#' @param creds A `secret` containing a `user` and `password`
#'
#' @inheritParams httr::authenticate
#'
#' @return A `request` object with authentication
#'
#' @keywords internal
auth <- function(creds = es_creds_get(), type = "basic") {
  # Unlock credentials to use with `authenticate()`
  creds_chr <- as.character(scrt_unlock(creds))

  # Return object to use for authentication
  httr::authenticate(
    user = creds_chr[["user"]],
    password = creds_chr[["password"]],
    type = type
  )
}