R/is.R

In peterhurford/checkr: Automatically Test R Functions

#' Test for class membership
#'
#' @param match_object ANY. The object to test for class.
#' @param expected_class character. The name of the expected class.
#' @examples
#'   1 %is% numeric
#'   1.0 %is% double
#'   1L %is% integer
#'   iris %is% dataframe
#'   c("a", "b", "c") %is% vector
#'   "pizza" %is% simple_string
#'   list(a = "pizza", b = "pie") %is% c("character", "list")
#' @return Boolean whether or not the match_object is the expected_class.
#' @export
`%is%` <- function(match_object, expected_class) {
  if (is.name(substitute(expected_class))) {
    expected_class <- deparse(substitute(expected_class))
  }
  checkr:::`%is_%`(match_object, expected_class)
}


`%is_%` <- function(match_object, expected_class) {
  if (length(expected_class) > 1) {
    return(all(vapply(expected_class, `%is%`,
      match_object = match_object, logical(1))))
  }


  if (identical(expected_class, NULL)) {
    expected_class <- "NULL"
  }
  if (identical(expected_class, NA)) {
    expected_class <- "NA"
  }
  if (identical(expected_class, "string")) {
    expected_class <- "character"
  }
  if (identical(expected_class, "dataframe")) {
    expected_class <- "data.frame"
  }

  if (identical(tolower(expected_class), "any")) {
    return(TRUE)
  }
  if (identical(expected_class, "simple_string")) {
    return(checkr::is.simple_string(match_object))
  }
  if (identical(expected_class, "double")) {
    return(is.double(match_object))
  }
  if (identical(expected_class, "empty")) {
    return(checkr::is.empty(match_object))
  }
  if (identical(expected_class, "NA")) {
    return(!is.null(match_object) && is.na(match_object))
  }
  if (identical(expected_class, "vector")) {
    return(is.vector(match_object) && !methods::is(match_object, "list"))
  }
  if (identical(expected_class, "atomic")) {
    return(is.atomic(match_object))
  }
  methods::is(match_object, expected_class)
}

#' Test whether a match object is not a member of a particular class.
#' @rdname grapes-is-grapes
#' @export
`%isnot%` <- function(match_object, expected_class) {
  if (is.name(substitute(expected_class))) {
    expected_class <- deparse(substitute(expected_class))
  }
  !(checkr:::`%is_%`(match_object, expected_class))
}