R/utils.R

In neatR: Neat Data for Presentation

#' Extended check for null or NA values
#' @noRd

is_na <- function(x) {
  if (is.null(x) || length(x) == 0L) {
    out <- TRUE
  } else {
    out <- is.na(x)
  }
  out
}

#' Check for singletons of numeric
#' @noRd

num_singleton_check <- function(x) {
  if (!(is.numeric(x) && NROW(x) == 1)) {
    e <- paste0(
      "`", deparse(substitute(x)),
      "` must be a numeric of length one."
    )
    stop(e)
  }
}

#' Check for singletons of integer
#' @noRd

int_singleton_check <- function(x) {
  if (!(any(
    is.integer(x),
    (is.numeric(x) && x == as.integer(x))
  ) && NROW(x) == 1)) {
    e <- paste0(
      "`", deparse(substitute(x)),
      "` must be a integer of length one."
    )
    stop(e)
  }
}

#' Check for singletons of string
#' @noRd

str_singleton_check <- function(x, is_nullable = FALSE) {
  na_chk <- data.table::fifelse(is_nullable, is.null(x), FALSE)
  chk <- any(na_chk, (is.character(x) && NROW(x) == 1))
  if (!chk) {
    e <- paste0(
      "`", deparse(substitute(x)),
      "` must be a string (character type) of length one."
    )
    stop(e)
  }
}

#' Check for singletons of boolean
#' @noRd

bool_singleton_check <- function(x) {
  if (!(is.logical(x) && NROW(x) == 1)) {
    e <- paste0(
      "`", deparse(substitute(x)),
      "` must be a boolean (TRUE / FALSE) of length one."
    )
    stop(e)
  }
}

#' Check list of singleton strings
#' @noRd

lst_str_check <- function(x) {
  if (!(all(is.list(x), str_singleton_check(x[[1]])))) {
    e <- paste0(
      "`", deparse(substitute(x)),
      "` must be a list of string (character)"
    )
    stop(e)
  }
}

#' Put a string within parenthesis
#' @noRd

inpar <- function(x) {
  paste0(" (", as.character(x), ")")
}

#' Sandwiching a variable with prefix and suffix, outputs a string of the input
#' with optional prefix and suffix
#' @noRd

sandwich <- function(x, prefix = "", suffix = "") {
  clean_space(paste0(prefix, x, suffix))
}

#' Check for empty string
#' @noRd

is_empty <- function(x) {
  if (!is.character(x)) {
    stop("Input should be a character.")
  }
  trimws(x) == ""
}

#' Coalesce for null or na values in a vector
#' @noRd

coalesce <- function(x, replace_by) {
  if (is.null(x)) {
    return(replace_by)
  }
  if (is.character(x)) {
    x[trimws(x) == ""] <- NA_character_
  }
  data.table::fcoalesce(x, replace_by)
}

#' Get nth element from a list
#' @noRd

getnth <- function(l, n) {
  sapply(l, "[[", n)
}

#' Check date type
#' @noRd

date_check <- function(date) {
  # Allow all NA (logical or otherwise) to pass, they will be handled later
  if (all(is.na(date))) {
    return()
  }

  chk <- any(inherits(date, "POSIXt"), inherits(date, "Date"))
  if (!chk) {
    e <- paste0(
      "`", deparse(substitute(date)),
      "` must be a date or timestamp variable"
    )
    stop(e)
  }
}

#' Check timestamp type
#' @noRd

timestamp_check <- function(timestamp) {
  if (all(is.na(timestamp))) {
    return()
  }

  chk <- inherits(timestamp, "POSIXt")
  if (!chk) {
    e <- paste0(
      "`", deparse(substitute(timestamp)),
      "` must be a timestamp variable"
    )
    stop(e)
  }
}

#' Handle deprecated arguments
#' @noRd

.handle_deprecated_args <- function(old_arg, new_arg, old_name, new_name) {
  if (!is.null(old_arg)) {
    warning(
      paste0(
        "The argument `", old_name,
        "` is deprecated; please use `", new_name, "` instead."
      ),
      call. = FALSE
    )
    return(old_arg)
  }
  new_arg
}