R/introspectors.R

In jeanmathieupotvin/dotprofile: Create and Manage Configuration Profiles

#' Introspectors
#'
#' Check types and lengths of \R objects.
#'
#' @name introspectors
#'
#' @param x `[any]`
#'
#'   Object to be tested.
#'
#' @param n `[NULL | integer(1)]`
#'
#'   The desired length of `x`. If `NULL`, length is not tested, only the
#'   type is. It is automatically coerced to an `integer` value via
#'   [as.integer()][base::as.integer()].
#'
#' @param .na `[logical(1)]`
#'
#'   Can `x` contain [NA][base::NA] values? Beware! Validation of this argument
#'   is deferred to the underlying [if][base::Control] statement.
#'
#' @returns A `logical(1)`.
#'
#' @details Types are abbreviated for convenience and consistency:
#'   * `nul` stands for `"NULL"`,
#'   * `lgl` stands for `"logical"`,
#'   * `int` stands for `"integer"`,
#'   * `num` stands for `"numeric"`,
#'   * `dbl` stands for `"double"`,
#'   * `cpx` stands for `"complex"`,
#'   * `chr` stands for `"character"`,
#'   * `ato` stands for `"atomic"`, and
#'   * `lst` stands for `"list"`.
#'
#'   An [atomic vector][base::is.atomic()] is either a `NULL` or any
#'   of these base types: `"logical"`, `"integer"`, `"double"`, `"complex"`,
#'   `"character"`, and `"raw"`. [Raw vectors][base::raw()] are out of scope.
#'
#'   What \R sometimes call a [numeric][base::numeric()] is just a
#'   [double][base::double()] (or a `"real"`) value: a *double-precision vector*.
#'   Package \pkg{dotprofile} sticks to the conventional `"double"` name.
#'   Therefore, functions [is_num()] and [is_scalar_num()] are respectively
#'   identical to functions [is_dbl()] and [is_scalar_dbl()].
#'
#' @section Checking NA values: By default, [NA values][base::NA] are
#'   valid values, except when a scalar value is expected. In that case,
#'   they are invalid. This assumption can easily be changed via argument
#'   `.na`.
#'
#'   When checking for [NA values][base::NA] in a [list][base::list()],
#'   [is_lst()] and [is_scalar_lst()] do __not__ recurse into their
#'   recursive elements.
#'
#' @section Checking NULL values: It makes no sense to check for a `NULL`'s
#'   length, because it is always equal to 0. Therefore, [is_nul()] is just
#'   an alias to function [is.null()][base::is.null()], and is provided for
#'   convenience.
#'
#'   Keep in mind that `is_ato(NULL)` yields `TRUE` because `NULL` is a
#'   degenerate atomic type. However, `is_ato(NULL, 1L)` always yields
#'   `FALSE`, because of `NULL`'s implicit length.
#'
#' @note Introspector functions of \pkg{dotprofile} are equivalent to what
#' \pkg{rlang} typically offers, both in terms of performance and convenience.
#' However, managing \R dependencies can be a big mess in production, so
#' \pkg{dotprofile} tries hard to avoid relying on other packages when it is
#' not absolutely required.
#'
#' @examples
#' ## Check if a vector contains 3 double values.
#' is_dbl(c(1.0, 1.1, 1.2), 3L)
#'
#' ## Beware of R implicit conversions. This yields FALSE.
#' is_int(c(1L, 2, 3L))
#'
#' ## By default, NAs are accepted in vectors.
#' is_int(c(1L, NA_integer_))        # TRUE
#' is_int(c(1L, NA_integer_), FALSE) # FALSE
#'
#' ## By default, scalar values cannot be NA.
#' is_scalar_int(NA_integer_)       # FALSE
#' is_scalar_int(NA_integer_, TRUE) # TRUE
#'
#' @export
is_nul <- function(x) { return(base::is.null(x)) }

#' @rdname introspectors
#' @export
is_lgl <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x)

    if (is_nul(n)) {
        return(is.logical(x) && has_no_na)
    } else {
        return(is.logical(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_int <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x)

    if (is_nul(n)) {
        return(is.integer(x) && has_no_na)
    } else {
        return(is.integer(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_dbl <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x)

    if (is_nul(n)) {
        return(is.double(x) && has_no_na)
    } else {
        return(is.double(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_num <- is_dbl

#' @rdname introspectors
#' @export
is_cpx <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x)

    if (is_nul(n)) {
        return(is.complex(x) && has_no_na)
    } else {
        return(is.complex(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_chr <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x)

    if (is_nul(n)) {
        return(is.character(x) && has_no_na)
    } else {
        return(is.character(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_ato <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x)

    if (is_nul(n)) {
        return(is.atomic(x) && has_no_na)
    } else {
        return(is.atomic(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_lst <- function(x, n = NULL, .na = TRUE)
{
    has_no_na <- if (.na) TRUE else !anyNA(x, FALSE)

    if (is_nul(n)) {
        return(is.list(x) && has_no_na)
    } else {
        return(is.list(x) && identical(length(x), as.integer(n)) && has_no_na)
    }
}

#' @rdname introspectors
#' @export
is_scalar_lgl <- function(x, .na = FALSE) { return(is_lgl(x, 1L, .na)) }

#' @rdname introspectors
#' @export
is_scalar_int <- function(x, .na = FALSE) { return(is_int(x, 1L, .na)) }

#' @rdname introspectors
#' @export
is_scalar_dbl <- function(x, .na = FALSE) { return(is_dbl(x, 1L, .na)) }

#' @rdname introspectors
#' @export
is_scalar_num <- is_scalar_dbl

#' @rdname introspectors
#' @export
is_scalar_cpx <- function(x, .na = FALSE) { return(is_cpx(x, 1L, .na)) }

#' @rdname introspectors
#' @export
is_scalar_chr <- function(x, .na = FALSE) { return(is_chr(x, 1L, .na)) }

#' @rdname introspectors
#' @export
is_scalar_ato <- function(x, .na = FALSE) { return(is_ato(x, 1L, .na)) }

#' @rdname introspectors
#' @export
is_scalar_lst <- function(x, .na = FALSE) { return(is_lst(x, 1L, .na)) }