tests/testthat/helper-src.R

In implyr: R Interface for Apache Impala

java_home <- Sys.getenv("JAVA_HOME", unset = NA)
jdbc_url <- Sys.getenv("IMPLYR_TEST_JDBC", unset = NA)
jdbc_host <- Sys.getenv("IMPLYR_TEST_HOST", unset = NA)
jdbc_port <- Sys.getenv("IMPLYR_TEST_PORT", unset = NA)
jdbc_user <- Sys.getenv("IMPLYR_TEST_USER", unset = NA)
jdbc_pass <- Sys.getenv("IMPLYR_TEST_PASS", unset = NA)

if (!is.na(java_home) & !is.na(jdbc_url) & !is.na(jdbc_host) &
    !is.na(jdbc_port) & !is.na(jdbc_user) & !is.na(jdbc_pass)) {
  run_tests <- TRUE
} else {
  run_tests <- FALSE
}

check_impala <- function() {
  if (!run_tests) {
    skip("This environment is not configured to run implyr tests")
  }
}

skip_on_travis <- function() {
  if (identical(Sys.getenv("TRAVIS"), "true")) {
    skip("Skipping test on Travis CI")
  }
}

skip_for_codecov <- function() {
  if (identical(Sys.getenv("R_COVR"), "true")) {
    skip("Skipping for on Codecov")
  }
}

column_type <- function(x) {
  if (ncol(x) > 1) {
    stop("Argument to function column_type() must have only one column")
  }
  x %>%
    select(test_column = 1) %>%
    transmute(datatype = typeof(test_column)) %>%
    head(1) %>%
    pull() %>%
    tolower()
}

eval_tbls <- function (tbls, op)
{
  # adapted from dplyr::eval_tbls
  lapply(tbls, function(x) as.data.frame(op(x)))
}

eval_tbls2 <- function(tbls_x, tbls_y, op)
{
  # adapted from dplyr::eval_tbls2
  Map(function(x, y) as.data.frame(op(x, y)), tbls_x, tbls_y)
}

expect_equal_tbls <- function (results, ref = NULL, ...)
{
  # adapted from dplyr::expect_equal_tbls
  if (length(results) < 2 && is.null(ref)) {
    skip("Need at least two srcs to compare")
  }
  if (is.null(ref)) {
    ref <- results[[1]]
    ref_name <- names(results)[1]
    rest <- results[-1]
  }
  else {
    rest <- results
    ref_name <- "supplied comparison"
  }
  for (i in seq_along(rest)) {
    ok <- all.equal(ref, rest[[i]], ...)
    msg <- paste0(names(rest)[[i]], " not equal to ", ref_name,
                  "\n", ok)
    expect_true(ok, info = msg)
  }
  invisible(TRUE)
}

compare <- all.equal

compare_tbls <- function (tbls, op, ref = NULL, ...)
{
  # adapted from dplyr::compare_tbls
  results <- eval_tbls(tbls, op)
  expect_equal_tbls(results, ...)
}

compare_tbls2 <- function (tbls_x, tbls_y, op, ref = NULL, compare = compare, ...)
{
  # adapted from dplyr::compare_tbls2
  results <- eval_tbls2(tbls_x, tbls_y, op)
  expect_equal_tbls(results, ...)
}