R/predicates.R

In armcn/pure: Data Checks and Assertions

#' Check
#'
#' @param x Object to check
#' @return TRUE or FALSE
#' @name check
NULL

#' Check if an object is a list
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_list <- function(x) {
  is.list(x)
}

#' Check if an object is a logical vector
#'
#' This will return TRUE for vectors containing combinations
#' of TRUE, FALSE, and NA. The vector may have attributes
#' and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_logical <- function(x) {
  is.logical(x)
}

#' Check if an object is an integer vector
#'
#' This will return TRUE for vectors containing combinations
#' of integers and NA_integer_. The vector may have
#' attributes and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_integer <- function(x) {
  is.integer(x)
}

#' Check if an object is a double vector
#'
#' This will return TRUE for vectors containing combinations
#' of doubles, NA_real_, NaN, -Inf, Inf. The vector may have
#' attributes and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_double <- function(x) {
  is.double(x)
}

#' Check if an object is a character vector
#'
#' This will return TRUE for vectors containing combinations
#' of characters and NA_character_. The vector may have
#' attributes and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_character <- function(x) {
  is.character(x)
}

#' @export
is_date <- function(x) {
  inherits(x, "Date")
}

#' @export
is_posixct <- function(x) {
  inherits(x, "POSIXct")
}

#' @export
is_hms <- function(x) {
  inherits(x, "hms")
}

#' @export
is_factor <- function(x) {
  is.factor(x)
}

#' Check if an object is a complex vector
#'
#' This will return TRUE for vectors containing combinations
#' of complex numbers and NA_complex_. The vector may have
#' attributes and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_complex <- function(x) {
  is.complex(x)
}

#' Check if an object is a raw vector
#'
#' This will return TRUE for vectors containing raw bytes.
#' The vector may have attributes and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_raw <- function(x) {
  is.raw(x)
}

#' Check if an object has no attributes
#'
#' This will return TRUE for objects without attributes.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_bare <- function(x) {
  compose(is.null, attributes)(x)
}

#' Check if an object is a vector
#'
#' This will return TRUE for atomic vectors or lists. The
#' vector may have attributes and/or have length zero.
#'
#' @inheritParams check
#' @inherit check return
#'
#' @export
is_vector <- function(x) {
  or(is_atomic, is_list)(x)
}

is_atomic <- function(x) {
  or(
    is_logical,
    is_integer,
    is_double,
    is_character,
    is_complex,
    is_raw
  )(x)
}

is_scalar <- function(x) {
  isTRUE(length(x) <= 1)
}

is_bare_list <- function(x) {
  and(is_bare, is_list)(x)
}

is_bare_vector <- function(x) {
  and(is_bare, is_vector)(x)
}

is_bare_atomic <- function(x) {
  and(is_bare, is_atomic)(x)
}

is_bare_logical <- function(x) {
  and(is_bare, is_logical)(x)
}

is_bare_integer <- function(x) {
  and(is_bare, is_integer)(x)
}

is_bare_double <- function(x) {
  and(is_bare, is_double)(x)
}

is_bare_character <- function(x) {
  and(is_bare, is_character)(x)
}

is_bare_complex <- function(x) {
  and(is_bare, is_complex)(x)
}

is_bare_raw <- function(x) {
  and(is_bare, is_raw)(x)
}

is_length_zero <- function(x) {
  length(x) == 0
}

#' @export
is_empty_vector <- function(x) {
  and(is_vector, is_length_zero)(x)
}

is_not_empty_vector <- function(x) {
  not(is_empty_vector)(x)
}

is_any_na <- function(x) {
  any(is.na(x))
}

is_not_any_na <- function(x) {
  not(is_any_na)(x)
}

is_any_infinite <- function(x) {
  any(is.infinite(x))
}

is_not_any_infinite <- function(x) {
  not(is_any_infinite)(x)
}

is_any_nan <- function(x) {
  any(is.nan(x))
}

is_not_any_nan <- function(x) {
  not(is_any_nan)(x)
}

#' @export
is_pure_logical <- function(x) {
  and(
    is_bare_logical,
    is_not_any_na
  )(x)
}

#' @export
is_pure_integer <- function(x) {
  and(
    is_bare_integer,
    is_not_any_na
  )(x)
}

#' @export
is_pure_double <- function(x) {
  and(
    is_bare_double,
    is_not_any_na,
    is_not_any_nan,
    is_not_any_infinite
  )(x)
}

#' @export
is_pure_character <- function(x) {
  and(
    is_bare_character,
    is_not_any_na
  )(x)
}

#' @export
is_pure_date <- function(x) {
  and(
    is_date,
    is_not_any_na
  )(x)
}

#' @export
is_pure_posixct <- function(x) {
  and(
    is_posixct,
    is_not_any_na
  )(x)
}

#' @export
is_pure_hms <- function(x) {
  and(
    is_hms,
    is_not_any_na
  )(x)
}

#' @export
is_pure_factor <- function(x) {
  and(
    is_factor,
    is_not_any_na
  )(x)
}

is_pure_complex <- function(x) {
  and(
    is_bare_complex,
    is_not_any_na
  )(x)
}

is_pure_raw <- function(x) {
  is_bare_raw(x)
}

#' @export
is_pure_atomic <- function(x) {
  or(
    is_pure_logical,
    is_pure_integer,
    is_pure_double,
    is_pure_character,
    is_pure_date,
    is_pure_posixct,
    is_pure_hms,
    is_pure_factor,
    is_pure_complex,
    is_pure_raw
  )(x)
}

#' @export
is_pure_list <- function(x) {
  and(
    is_list,
    compose(
      all,
      unlist,
      map(is_pure_atomic),
      unlist
    )
  )(x)
}

#' @export
is_flat_list <- function(x) {
  flattened <-
    is.atomic(unlist(x, recursive = FALSE))

  length(flattened) == length(x)
}

#' @export
is_pure_flat_list <- function(x) {
  and(
    is_pure_list,
    is_flat_list
  )(x)
}

#' @export
is_pure_vector <- function(x) {
  or(
    is_pure_atomic,
    is_pure_list
  )(x)
}

#' @export
is_pure_integer_scalar <- function(x) {
  and(
    is_pure_integer,
    is_scalar
  )(x)
}

#' @export
is_pure_scalar <- function(x) {
  and(
    is_pure_vector,
    is_scalar
  )(x)
}

#' @export
is_pure_numeric <- function(x) {
  or(
    is_pure_integer,
    is_pure_double
  )(x)
}

is_function <- function(x) {
  is.function(x)
}

is_arity <- function(n) {
  function(x) {
    n_args(x) == n
  }
}

#' @export
is_unary_function <- function(x) {
  and(
    is_function,
    is_arity(1)
  )(x)
}

#' @export
is_binary_function <- function(x) {
  and(
    is_function,
    is_arity(2)
  )(x)
}

is_homogeneous_list <- function(x) {

}