tests/testthat/helper.R

In odbc: Connect to ODBC Compatible Databases (using the DBI Interface)

skip_unless_has_test_db <- function(expr) {
  if (!identical(Sys.getenv("NOT_CRAN"), "true")) {
    return(skip("On CRAN"))
  }

  # Failing database connection should fail the test in DBItest backends
  if (nzchar(Sys.getenv("DBITEST_BACKENDS"))) {
    con <- DBItest:::connect(expr)
    DBI::dbDisconnect(con)
    TRUE
  } else {
    tryCatch({
      con <- DBItest:::connect(expr)
      DBI::dbDisconnect(con)
      TRUE
    }, error = function(e) {
      skip(paste0("Test database not available:\n'", conditionMessage(e), "'"))
    })
  }
}

skip_if_no_drivers <- function() {
  if (nrow(odbcListDrivers()) == 0) {
    skip("No drivers installed")
  }
}

#' Test round tripping a simple table
#'
#' This tests all the supported data types, including missing values. It first
#' writes them to the database, then reads them back and verifies the data is
#' identical to the original.
#'
#' This function is not exported and should only be used during tests and as a
#' sanity check when writing new `odbcDataType()` methods.
#'
#' @param con An established DBI connection.
#' @param columns Table columns to exclude (default) or include, dependent on
#' the value of `invert`. One of `datetime`, `date`, `binary`,
#' `integer`, `double`, `character`, `logical`.
#' @param invert If `TRUE`, change the definition of columns to be exclusive,
#' rather than inclusive.
#' @param force_sorted If `TRUE`, a sorted `id` column is added to the sent
#' data, and the received data is sorted by this column before doing the
#' comparison. This is necessary for some databases that do not preserve row
#' order.
#' @examples
#' \dontrun{
#' test_roundtrip(con)
#'
#' # exclude a few columns
#' test_roundtrip(con, c("integer", "double"))
#'
#' # Only test a specific column
#' test_roundtrip(con, "integer", invert = FALSE)
#' }
test_roundtrip <- function(con = DBItest:::connect(DBItest::get_default_context()), columns = "", invert = TRUE, force_sorted = FALSE) {
  dbms <- dbGetInfo(con)$dbms.name
  testthat::context(paste0("roundtrip[", dbms, "]"))
  res <- list()
  testthat::test_that(paste0("[", dbms, "] round tripping data.frames works"), {
    #on.exit(try(DBI::dbRemoveTable(con, "test_table"), silent = TRUE))
    set.seed(42)

    iris <- datasets::iris

    # We can't use the data.frame constructor directly as list columns don't work there.
    sent <- list(

      # We always return strings as factors
      #factor = iris$Species,

      datetime = as.POSIXct(as.numeric(iris$Petal.Length * 10), origin = "2016-01-01", tz = "UTC"),
      date = as.Date(iris$Sepal.Width * 100, origin = Sys.time()),
      time = hms::hms(seconds = sample.int(24 * 60 * 60, NROW(iris))),
      binary = blob::as_blob(lapply(seq_len(NROW(iris)), function(x) as.raw(sample(0:100, size = sample(0:25, 1))))),
      integer = as.integer(iris$Petal.Width * 100),
      double = iris$Sepal.Length,
      character = as.character(iris$Species),
      logical = sample(c(TRUE, FALSE), size = nrow(iris), replace = T)
    )
    attributes(sent) <- list(names = names(sent), row.names = c(NA_integer_, -length(sent[[1]])), class = "data.frame")

    # Add a proportion of NA values to a data frame
    add_na <- function(x, p = .1) { is.na(x) <- stats::runif(length(x)) < p; x}
    sent[] <- lapply(sent, add_na, p = .1)
    if (isTRUE(invert)) {
      sent <- sent[, !names(sent) %in% columns]
    } else {
      sent <- sent[, names(sent) %in% columns]
    }
    if (force_sorted) sent$id <- seq_len(NROW(iris))

    DBI::dbWriteTable(con, "test_table", sent, overwrite = TRUE)
    received <- DBI::dbReadTable(con, "test_table")
    if (force_sorted) received <- received[order(received$id),]
    row.names(received) <- NULL
    testthat::expect_equal(sent, received)
    res <<- list(sent = sent, received = received)
  })
  invisible(res)
}