Refactoring multiple backend tests

.travis.yml

@@ -3,9 +3,11 @@ sudo: false
 cache: packages
 
 warnings_are_errors: false
-
 env:
 - _R_CHECK_FORCE_SUGGESTS_=false
 
+before_script:
+  - psql -c 'create database test;' -U postgres
+
 after_success:
 - Rscript -e 'covr::codecov()'

NAMESPACE

@@ -165,9 +165,6 @@ S3method(rename_,data.frame)
 S3method(rename_,grouped_df)
 S3method(rename_,tbl_cube)
 S3method(rename_,tbl_sql)
-S3method(reset,default)
-S3method(reset,list)
-S3method(reset,src_sql)
 S3method(right_join,data.frame)
 S3method(right_join,tbl_df)
 S3method(right_join,tbl_sql)
@@ -446,7 +443,9 @@ export(tbl_cube)
 export(tbl_df)
 export(tbl_sql)
 export(tbl_vars)
-export(temp_srcs)
+export(test_frame)
+export(test_load)
+export(test_register_src)
 export(tibble)
 export(top_n)
 export(translate_sql)

NEWS.md

@@ -1,5 +1,9 @@
 # dplyr 0.4.3.9000
 
+* The backend testing system has been improved. This lead to the removal of 
+  `temp_srcs()`. In the unlikely event that you were using this function,
+  you can instead use `test_register_src()` and `test_load()`.
+
 * `filter()` throws an error if you supply an named arguments. This is usually
   a type: `filter(df, x = 1)` instead of `filter(df, x == 1)` (#1529).
 

R/data-temp.r

@@ -1,73 +1,64 @@
-#' Connect to temporary data sources.
+#' Infrastructure for testing dplyr
 #'
-#' These functions make it easy to take a local data frame and make available
-#' as a tbl in every known src. All local srcs will work on any computer.
-#' DBMS srcs will only currently work on Hadley's computer.
+#' Register testing sources, then use \code{test_load} to load an existing
+#' data frame into each source. To create a new table in each source,
+#' use \code{test_frame}.
 #'
 #' @keywords internal
-#' @export
 #' @examples
 #' \dontrun{
-#' local <- c("df", "dt")
-#' db <- c("sqlite", "mysql", "postgres")
+#' test_register_src("df", src_df(env = new.env()))
+#' test_register_src("sqlite", src_sqlite(":memory:", create = TRUE))
 #'
-#' temp_srcs(local)
-#' temp_srcs(db)
+#' test_frame(x = 1:3, y = 3:1)
+#' test_load(mtcars)
 #' }
-temp_srcs <- function(..., quiet = NULL) {
-  load_srcs(temp_src, c(...), quiet = quiet)
-}
-
-temp_src <- function(type, ...) {
-  cache_name <- paste("temp", type, "src", collapse = "-")
-  if (is_cached(cache_name)) return(get_cache(cache_name))
+#' @name testing
+NULL
 
-  env <- new.env(parent = emptyenv())
-  src <- switch(type,
-    df =       src_df(env = env),
-    dt =       dtplyr::src_dt(env = env),
-    sqlite =   src_sqlite(tempfile(), create = TRUE),
-    mysql =    src_mysql("test", ...),
-    postgres = src_postgres("test", ...),
-    stop("Unknown src type ", type, call. = FALSE)
-  )
 
-  set_cache(cache_name, src)
+#' @export
+#' @rdname testing
+test_register_src <- function(name, src) {
+  message("Registering testing src: ", name)
+  test_srcs$add(name, src)
 }
 
-reset <- function(x) UseMethod("reset")
-#' @export
-reset.default <- function(x) NULL
 #' @export
-reset.src_sql <- function(x) {
-  for (tbl in src_tbls(x)) {
-    dbRemoveTable(x$con, tbl)
-  }
+#' @rdname testing
+test_load <- function(df, name = random_table_name(), srcs = test_srcs$get(),
+                      ignore = character()) {
+  stopifnot(is.data.frame(df))
+  stopifnot(is.character(ignore))
+
+  srcs <- srcs[setdiff(names(srcs), ignore)]
+  lapply(srcs, copy_to, df, name = name)
 }
+
 #' @export
-reset.list <- function(x) {
-  for (y in x) reset(y)
+#' @rdname testing
+test_frame <- function(..., srcs = test_srcs$get()) {
+  df <- data_frame(...)
+  test_load(df, srcs = srcs)
 }
 
-#' @rdname temp_srcs
-temp_load <- function(srcs, df, name = NULL) {
-  if (is.character(srcs)) {
-    srcs <- temp_srcs(srcs)
-  }
+# Manage cache of testing srcs
+test_srcs <- local({
+  e <- new.env(parent = emptyenv())
+  e$srcs <- list()
 
-  if (is.data.frame(df)) {
-    if (is.null(name)) name <- random_table_name()
-    lapply(srcs, copy_to, df, name = name)
-  } else {
-    if (is.null(name)) {
-      name <- replicate(length(df), random_table_name())
-    } else {
-      stopifnot(length(name) == length(df))
-    }
+  list(
+    get = function() e$srcs,
 
-    lapply(srcs, function(x) {
-      Map(function(df, name) copy_to(x, df, name), df, name)
-    })
-  }
-}
+    add = function(name, src) {
+      stopifnot(is.src(src))
+      e$srcs[[name]] <- src
+    },
 
+    set = function(...) {
+      old <- e$srcs
+      e$srcs <- list(...)
+      invisible(old)
+    }
+  )
+})

R/src-postgres.r

@@ -108,19 +108,6 @@ src_postgres <- function(dbname = NULL, host = NULL, port = NULL, user = NULL,
     info = info, disco = db_disconnector(con, "postgres"))
 }
 
-
-has_postgres <- function(...) {
-  tryCatch(
-    {
-      src <- src_postgres(...)
-      dbDisconnect(src$con)
-      TRUE
-    },
-    error = function(e) {
-      FALSE
-  })
-}
-
 #' @export
 #' @rdname src_postgres
 tbl.src_postgres <- function(src, from, ...) {

tests/testthat.R

@@ -1,4 +1,4 @@
-library("testthat")
-library("dplyr")
+library(testthat)
+library(dplyr)
 
 test_check("dplyr")

tests/testthat/helper-src.R

@@ -0,0 +1,9 @@
+test_register_src("df", src_df(env = new.env(parent = emptyenv())))
+test_register_src("sqlite", src_sqlite(":memory:", create = TRUE))
+
+if (identical(Sys.info()[["user"]], "hadley")) {
+  test_register_src("postgres", src_postgres("test"))
+} else if (identical(Sys.getenv("TRAVIS"), "true")) {
+  test_register_src("postgres", src_postgres("test", user = "travis", password = ""))
+}
+

tests/testthat/test-arrange.r

@@ -50,7 +50,7 @@ test_that("local arrange sorts missing values to end", {
 test_that("two arranges equivalent to one", {
   single <- arrange(df1, a, b)
 
-  tbls <- temp_load(c(local, db), df1)
+  tbls <- test_load(df1)
   compare_tbls(tbls, ref = single, compare = equal_df,
     function(x) x %>% arrange(b) %>% arrange(a))
 })

tests/testthat/test-compute.R

@@ -1,18 +1,15 @@
 context("Compute")
 
-df <- data_frame(x = 5:1, y = 1:5, z = "a")
-
-srcs <- temp_srcs(c("df", "sqlite", "postgres"))
-tbls <- temp_load(srcs, df)
-
 test_that("compute doesn't change representation", {
-  compare_tbls(tbls, . %>% compute,
-               compare = equal_data_frame, convert = TRUE)
-  compare_tbls(tbls, . %>% mutate(a = x) %>% compute,
-               compare = equal_data_frame, convert = TRUE)
+  tbls <- test_frame(x = 5:1, y = 1:5, z = "a")
+
+  compare_tbls(tbls, . %>% compute, convert = TRUE)
+  compare_tbls(tbls, . %>% mutate(a = x) %>% compute, convert = TRUE)
 })
 
 test_that("compute can create indexes", {
+  tbls <- test_frame(x = 5:1, y = 1:5, z = "a")
+
   compare_tbls(tbls, . %>% compute(indexes = c("x", "y")),
                compare = equal_data_frame, convert = TRUE)
   compare_tbls(tbls, . %>% compute(indexes = list("x", "y", c("x", "y"))),

tests/testthat/test-distinct.R

@@ -5,7 +5,7 @@ df <- data.frame(
   y = c(1, 1, 2, 2),
   z = c(1, 1, 2, 2)
 )
-tbls <- temp_load(c("df", "sqlite"), df)
+tbls <- test_load(df)
 
 test_that("distinct equivalent to local unique", {
   compare_tbls(tbls, function(x) x %>% distinct(), ref = unique(df))

tests/testthat/test-do.R

@@ -8,8 +8,7 @@ df <- data.frame(
   y = 6:1
 )
 
-srcs <- temp_srcs(c("df", "sqlite"))
-tbls <- temp_load(srcs, df)
+tbls <- test_load(df)
 grp <- lapply(tbls, function(x) x %>% group_by(g))
 
 test_that("can't use both named and unnamed args", {

tests/testthat/test-equiv-manip.r

@@ -1,17 +1,26 @@
 context("Equivalence (manip)")
 
-df <- data.frame(x = 5:1, y = 1:5)
-
-srcs <- temp_srcs(c("df", "sqlite", "postgres"))
-tbls <- temp_load(srcs, df)
 
 test_that("mutate happens before summarise", {
-  # FIXME: only needed because postgresql returns integer for sum
-  compare_tbls(tbls, function(x) {
-    mutate(x, z = x + y) %>% summarise(sum_z = sum(z))
-  }, compare = equal_data_frame, convert = TRUE)
+  test_f <- function(tbl) {
+    res <- tbl %>%
+      mutate(x, z = x + y) %>%
+      summarise(sum_z = sum(z)) %>%
+      collect()
+    expect_equal(res$sum_z, 30)
+  }
+
+  test_frame(x = 5:1, y = 1:5) %>% lapply(test_f)
 })
 
 test_that("select operates on mutated vars", {
-  compare_tbls(tbls, function(x) mutate(x, z = x + y) %>% select(z))
+  test_f <- function(tbl) {
+    res <- tbl %>%
+      mutate(x, z = x + y) %>%
+      select(z) %>%
+      collect()
+    expect_equal(res$z, rep(4, 3))
+  }
+
+  test_frame(x = 1:3, y = 3:1) %>% lapply(test_f)
 })