R/predicates.R

In arkhe: Tools for Cleaning Rectangular Data

# PREDICATES

# Not exported =================================================================
is_empty_string <- function(x, na.rm = FALSE, assert_type = FALSE) {
  if (isTRUE(assert_type)) assert_type(x, "character")
  z <- x == ""
  z
}
is_zero_numeric <- function(x, na.rm = FALSE, assert_type = FALSE) {
  if (isTRUE(assert_type)) assert_type(x, "numeric")
  z <- x == 0
  z
}

# Helpers ======================================================================
#' Utility Predicates
#'
#' * `is_empty()` checks is an object is empty (any zero-length dimensions).
#' * `has_length()` checks how long is an object.
#' * `has_names()` checks if an object is named.
#' * `has_duplicates()` checks if an object has duplicated elements.
#' * `has_missing()` and `has_infinite()` check if an object contains missing
#' or infinite values.
#' @param x A [`vector`] to be tested.
#' @param n A length-one [`numeric`] vector specifying the length to test `x`
#'  with. If `NULL`, returns `TRUE` if `x` has length greater than zero, and
#'  `FALSE` otherwise.
#' @param names A [`character`] vector specifying the names to test `x`
#'  with. If `NULL`, returns `TRUE` if `x` has names, and `FALSE` otherwise.
#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
#'  be omitted?
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-utils
#' @rdname predicate-utils
NULL

#' @export
#' @rdname predicate-utils
has_length <- function(x, n = NULL) {
  if (is.null(n)) length(x) > 0 else length(x) == n
}
#' @export
#' @rdname predicate-utils
has_names <- function(x, names = NULL) {
  if (is.null(names)) {
    has_length(names(x))
  } else {
    identical(names(x), names)
  }
}
#' @export
#' @rdname predicate-utils
has_duplicates <- function(x) {
  any(duplicated(x))
}
#' @export
#' @rdname predicate-utils
has_missing <- function(x) {
  any(is.na(x))
}
#' @export
#' @rdname predicate-utils
has_infinite <- function(x) {
  any(is.infinite(x))
}
#' @export
#' @rdname predicate-utils
is_empty <- function(x) {
  any((dim(x) %||% length(x)) == 0)
}
#' @export
#' @rdname predicate-utils
is_unique <- function(x, na.rm = FALSE) {
  if (na.rm) x <- stats::na.omit(x)
  length(unique(x)) == 1
}

# Type =========================================================================
#' Type Predicates
#'
#' @param x An object to be tested.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-type
#' @rdname predicate-type
NULL

#' @export
#' @rdname predicate-type
is_list <- function(x) {
  typeof(x) == "list"
}
#' @export
#' @rdname predicate-type
is_atomic <- function(x) {
  typeof(x) %in% c("logical", "integer", "double",
                   "complex", "character", "raw")
}
#' @export
#' @rdname predicate-type
is_vector <- function(x) {
  is_atomic(x) || is_list(x)
}
#' @export
#' @rdname predicate-type
is_numeric <- function(x) {
  typeof(x) %in% c("integer", "double")
}
#' @export
#' @rdname predicate-type
is_integer <- function(x) {
  typeof(x) == "integer"
}
#' @export
#' @rdname predicate-type
is_double <- function(x) {
  typeof(x) == "double"
}
#' @export
#' @rdname predicate-type
is_character <- function(x) {
  typeof(x) == "character"
}
#' @export
#' @rdname predicate-type
is_logical <- function(x) {
  typeof(x) == "logical"
}
#' @export
#' @rdname predicate-type
is_error <- function(x) {
  inherits(x, "try-error") || inherits(x, "simpleError") || inherits(x, "error")
}
#' @export
#' @rdname predicate-type
is_warning <- function(x) {
  inherits(x, "simpleWarning") || inherits(x, "warning")
}
#' @export
#' @rdname predicate-type
is_message <- function(x) {
  inherits(x, "simpleMessage") || inherits(x, "message")
}

# Scalar =======================================================================
#' Scalar Type Predicates
#'
#' @param x An object to be tested.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-scalar
#' @rdname predicate-scalar
NULL

#' @export
#' @rdname predicate-scalar
is_scalar_list <- function(x) {
  is_list(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_atomic <- function(x) {
  is_atomic(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_vector <- function(x) {
  is_vector(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_numeric <- function(x) {
  is_numeric(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_integer <- function(x) {
  is_integer(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_double <- function(x) {
  is_double(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_character <- function(x) {
  is_character(x) && length(x) == 1
}
#' @export
#' @rdname predicate-scalar
is_scalar_logical <- function(x) {
  is_logical(x) && length(x) == 1
}

# Numeric ======================================================================
#' Numeric Predicates
#'
#' Check numeric objects:
#' * `is_zero()` checks if an object contains only zeros.
#' * `is_odd()` and `is_even()` check if a number is odd or even, respectively.
#' * `is_positive()` and `is_negative` check if an object contains only
#'   (strictly) positive or negative numbers.
#' * `is_whole()` checks if an object only contains whole numbers.
#' @param x A [`numeric`] object to be tested.
#' @param tolerance A [`numeric`] scalar giving the tolerance to check within.
#' @param strict A [`logical`] scalar: should strict inequality be used?
#' @param ... Currently not used.
#' @return A [`logical`] vector.
#' @family predicates
#' @name predicate-numeric
#' @rdname predicate-numeric
NULL

#' @export
#' @rdname predicate-numeric
is_zero <- function(x, ...) {
  assert_type(x, "numeric")
  x == 0
}
#' @export
#' @rdname predicate-numeric
is_odd <- function(x, ...) { # impair
  assert_type(x, "numeric")
  as.logical(x %% 2)
}
#' @export
#' @rdname predicate-numeric
is_even <- function(x, ...) { # pair
  assert_type(x, "numeric")
  !as.logical(x %% 2)
}
#' @export
#' @rdname predicate-numeric
is_positive <- function(x, strict = FALSE, ...) {
  assert_type(x, "numeric")
  if (strict) x > 0 else x >= 0
}
#' @export
#' @rdname predicate-numeric
is_negative <- function(x, strict = FALSE, ...) {
  assert_type(x, "numeric")
  if (strict) x < 0 else x <= 0
}
#' @export
#' @rdname predicate-numeric
is_whole <- function(x, tolerance = .Machine$double.eps^0.5, ...) {
  assert_type(x, "numeric")
  abs(x - round(x, digits = 0)) <= tolerance
}

#' Numeric Trend Predicates
#'
#' Check numeric objects:
#' * `is_constant()` checks for equality among all elements of a vector.
#' * `is_increasing()` and `is_decreasing()` check if a sequence of numbers
#'   is monotonically increasing or decreasing, respectively.
#' @param x,y A [`numeric`] object to be tested.
#' @param tolerance A [`numeric`] scalar giving the tolerance to check within.
#' @param strict A [`logical`] scalar: should strict inequality be used?
#' @param na.rm A [`logical`] scalar: should missing values (including `NaN`)
#'  be omitted?
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-trend
#' @rdname predicate-trend
NULL

#' @export
#' @rdname predicate-trend
is_constant <- function(x, tolerance = .Machine$double.eps^0.5, na.rm = FALSE) {
  assert_type(x, "numeric")
  abs(max(x, na.rm = na.rm) - min(x, na.rm = na.rm)) <= tolerance
}
#' @export
#' @rdname predicate-trend
is_increasing <- function(x, na.rm = FALSE) {
  assert_type(x, "numeric")
  if (na.rm) x <- stats::na.omit(x)
  all(x == cummax(x))
}
#' @export
#' @rdname predicate-trend
is_decreasing <- function(x, na.rm = FALSE) {
  assert_type(x, "numeric")
  if (na.rm) x <- stats::na.omit(x)
  all(x == cummin(x))
}
#' @export
#' @rdname predicate-trend
is_greater <- function(x, y, strict = FALSE, na.rm = FALSE) {
  assert_type(x, "numeric")
  assert_type(y, "numeric")
  z <- if (strict) x > y else x >= y
  all(z, na.rm = na.rm)
}
#' @export
#' @rdname predicate-trend
is_lower <- function(x, y, strict = FALSE, na.rm = FALSE) {
  assert_type(x, "numeric")
  assert_type(y, "numeric")
  z <- if (strict) x < y else x <= y
  all(z, na.rm = na.rm)
}

# Matrix =======================================================================
#' Matrix Predicates
#'
#' * `is_square()` checks if a matrix is square.
#' * `is_symmetric()` checks if a matrix is symmetric.
#' @param x A [`matrix`] to be tested.
#' @return A [`logical`] scalar.
#' @family predicates
#' @name predicate-matrix
#' @rdname predicate-matrix
NULL

#' @export
#' @rdname predicate-matrix
is_square <- function(x) {
  if (is.matrix(x)) nrow(x) == ncol(x) else FALSE
}
#' @export
#' @rdname predicate-matrix
is_symmetric <- function(x) {
  if (is.matrix(x)) identical(x, t(x)) else FALSE
}

# Graph ========================================================================
# Graph Predicates
#
# `is_dag()` checks if a graph has a topological ordering (i.e. is a directed
# acyclic graph) using Kahn's algorithm.
# @param x An adjacency [`matrix`] to be tested.
# @return A [`logical`] scalar.
# @references
#  Kahn, A. B. (1962). Topological sorting of large networks. *Communications
#  of the ACM*, 5(11), p. 558-562. \doi{10.1145/368996.369025}.
# @family predicates
# @name predicate-graph
# @rdname predicate-graph
# @keywords internal
NULL

# @export
# @rdname predicate-graph
# is_dag <- function(x) {
#   # Get edges
#   G <- matrix2edges(x)
#   # Find nodes which have no incoming edges
#   S <- which(colSums(x) == 0)
#   # List that will contain the sorted elements
#   L <- list()
#
#   if (length(S) == 0)
#     return(FALSE)
#
#   k <- 1L
#   while (k == 1 || length(S) != 0) {
#     # Remove a node n from S and add n to tail of L
#     n <- S[[1]]
#     S <- S[-1]
#     L <- append(L, n)
#     # For each node m with an edge e from n to m
#     e <- which(G[, 1] == n)
#     m <- G[e, 2]
#     # Do remove edge e from the graph
#     G <- G[-e, , drop = FALSE]
#     # If m has no other incoming edges then insert m into S
#     if (nrow(G) != 0) {
#       m <- m[!(m %in% G[, 2])]
#       if (length(m) != 0)
#         S <- append(S, m)
#     }
#     k <- k + 1
#   }
#   return(nrow(G) == 0)
# }

# matrix2edges <- function(from) {
#   edges <- matrix(data = NA, nrow = 0, ncol = 2)
#   nodes <- seq_len(nrow(from))
#   for (i in nodes) {
#     to <- which(from[i, ])
#     if (length(to) != 0) {
#       e <- cbind(form = i, to = to)
#       edges <- rbind(edges, e)
#     }
#   }
#
#   edges
# }