Nothing
test_connection_string <- function(db) {
testthat::skip_on_cran()
var <- paste0("ODBC_CS_", db)
cs <- Sys.getenv(var)
if (cs == "") {
skip(paste0("env var '", var, "' not set"))
}
list(.connection_string = cs)
}
test_con <- function(db, ...) {
dbConnect(
odbc::odbc(),
.connection_string = test_connection_string(db),
...
)
}
local_table <- function(con, name, df, ..., envir = parent.frame()) {
dbWriteTable(con, name, df, ...)
withr::defer(dbRemoveTable(con, name), envir = envir)
name
}
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, columns = "", invert = TRUE, force_sorted = FALSE) {
dbms <- dbGetInfo(con)$dbms.name
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)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.