tests/testthat/helper_expects.R

In rbioapi: User-Friendly R Interface to Biologic Web Services' API

expect_list_classes <- function(obj, classes) {
  stopifnot(inherits(obj, "list"))

  obj_classes <- vapply(
    X = obj,
    FUN = function(x) {
      class(x)
    },
    FUN.VALUE = character(1),
    USE.NAMES = FALSE
  )

  if (identical(obj_classes, classes)) {
    testthat::succeed()
    return(invisible(obj_classes))
  } else {
    testthat::fail(sprintf(
      "objects elements' classes are: %s but expected classes are: %s",
      paste0(obj_classes, collapse = ", "), paste0(classes, collapse = ", ")
    ))
  }
}


expect_call_regex <- function(obj, pattern, ...) {
  obj <- paste0(deparse(obj), collapse = "")
  out <- grepl(pattern = pattern, x = obj, ...)

  if (out) {
    testthat::succeed()
    return(invisible(out))
  } else {
    testthat::fail(sprintf(
      "The regex pattern \"%s\" did not match the call object:\n \"%s\"",
      pattern, obj
    ))
  }
}

expect_regex <- function(obj, pattern, invert = FALSE, ...) {
  out <- vapply(
    X = obj,
    FUN = function(x, ...) {
      grepl(pattern = pattern, x = x, ...)
    },
    FUN.VALUE = logical(1),
    USE.NAMES = FALSE,
    ...
  )
  if (invert) {
    out <- !out
  }
  if (all(out)) {
    testthat::succeed()
    return(invisible(out))
  } else {
    testthat::fail(sprintf(
      "The regex pattern \"%s\" did not match the string vector:\n \"%s\"",
      pattern, paste0(obj, collapse = ", ")
    ))
  }
}

expect_class <- function(obj, expected, ...) {
  if (inherits(obj, expected)) {
    testthat::succeed()
    return(invisible(class(obj)))
  } else {
    testthat::fail(sprintf(
      "Your object's class is `%s`` but `%s`` is expected.",
      class(obj), expected
    ))
  }
}

expect_has_names <- function(obj, expected) {
  in_obj_not_expected <- setdiff(names(obj), expected)
  in_expected_not_obj <- setdiff(expected, names(obj))
  if (length(c(in_obj_not_expected, in_expected_not_obj)) == 0) {
    testthat::succeed()
    return(invisible(expected))
  } else {
    testthat::fail(sprintf(
      "The names does not match:\n names in object but not expected: %s\n expected name not in object: %s",
      paste0(in_obj_not_expected, collapse = ", "),
      paste0(in_expected_not_obj, collapse = ", ")
    ))
  }
}

expect_na <- function(obj) {
  if (all(is.na(obj))) {
    testthat::succeed()
    return(invisible(TRUE))
  } else {
    testthat::fail("The object contain non-NA elements..")
  }
}

expect_error2 <- function(obj, pattern = NULL, invert = FALSE, ...) {
  obj <- try(obj,
    silent = TRUE
  )
  if (inherits(obj, "try-error")) {
    if (is.null(pattern)) {
      testthat::succeed()
      return(invisible(TRUE))
    } else {
      out <- vapply(
        X = pattern,
        FUN = function(patt) {
          grepl(pattern = patt, x = obj, ...)
        },
        FUN.VALUE = logical(1)
      )
      if (invert) {
        out <- !out
      }
      if (all(out)) {
        testthat::succeed()
        return(invisible(out))
      } else {
        testthat::fail(sprintf(
          "Error was prodced but the regex pattern(s) %s didn't match.",
          which(!out)
        ))
      }
    }
  } else {
    testthat::fail("obj runs with no error.")
  }
}