R/utils.R

In rando: Context Aware Random Numbers

#' @name is_wholenumber
#'
#' @title Check if a Number is Whole
#'
#' @description
#' The built-in function `is.integer()` will check if a number is of
#' the `integer` class. However, we would usually want a function
#' that can check if a number is a _whole number_. It is also
#' vectorised over the input.
#'
#' @param x
#' Number to check
#'
#' @param tol
#' tolerance to check the values
#'
#' @return
#' A logical vector the same length as `x`
#'
#'
#' @examples
#' is.integer(2)
#' is_wholenumber(2)
#'
#' is.integer(seq(2, 3, 0.25))
#' is_wholenumber(seq(2, 3, 0.25))
#' @export
is_wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
  if (is.numeric(x)) abs(x - round(x)) < tol else rep(FALSE, length(x))
}


#' @name match.call2
#'
#' @title Alternate Parametrisation of `match.call()`
#'
#' @description
#' Alters the built-in function [match.call()] by providing an
#' additional argument which means that by default a user can specify
#' how far up the call stack they want to match a call of. See
#' [match.call()][base::match.call()] for more details.
#'
#' @param n
#' How far up the call-stack they would like to extract. The default,
#' `n=0` produces the same result as `match.call()` so this can be
#' inserted wherever `match.call()` is used.
#'
#' @param definition a function, by default the function from which
#' `match.call2()` is called.
#'
#' @param call an unevaluated call to the function specified by
#' `definition`, as generated by `call`
#'
#' @param expand.dots logical. Should arguments matching `...` in the
#' call be included or left as a `...` argument?
#'
#' @param envir an environment, from which the `...` in `call`
#' are retrieved, if any.
#'
#' @return
#' An object of class `call`
#'
#' @examples
#' f <- function(n) {
#'   g(n)
#' }
#'
#' g <- function(n) {
#'   h(n)
#' }
#'
#' h <- function(n) {
#'   match.call2(n)
#' }
#'
#' f(0)
#' f(1)
#' f(2)
#' @export
#'
match.call2 <- function(n = 0L,
                        definition = sys.function(sys.parent(n+1L)),
                        call = sys.call(sys.parent(n + 1L)),
                        expand.dots = TRUE,
                        envir = parent.frame(n + 3L)) {
  match.call(
    definition = definition,
    call = call,
    expand.dots = expand.dots,
    envir = envir
  )
}

#' @name null_switch
#'
#' @title Evaluate Expressions until not NULL
#'
#' @description
#' Evaluates expressions until one that is not `NULL` is encountered
#' and returns that. Expressions after the first non-`NULL` result are not
#' evaluated. If all expressions are `NULL`, it will return `NULL`
#'
#' @param ...
#' expressions to try to evaluate
#'
#' @return
#' The result of evaluating one of the expressions. Will only be
#' `NULL` if they _all_ evaluated to `NULL`
#'
#' @examples
#' f <- function() {
#'   cat("Evaluating f\n")
#'   NULL
#' }
#' g <- function() {
#'   cat("Evaluating g\n")
#'   2
#' }
#'
#' null_switch(NULL, f(), g())
#' null_switch(NULL, g(), f())
#' null_switch(f(), f(), f())
#' @export
#'

null_switch <- function(...) {
  len <- ...length()
  res <- NULL
  i <- 1
  while (i <= len & is.null(res)) {
    res <- ...elt(i)
    i <- i + 1
  }

  res
}

if (getRversion() < "4.0") {
  deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
    paste(deparse(expr, width.cutoff, ...), collapse = collapse)
  }
}

if (getRversion() < "3.6") {
  str2lang <- function(s) parse(text = s, keep.source = FALSE)[[1]]
}