feat: use_dbitest()

DESCRIPTION

@@ -54,6 +54,7 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.1
 Collate: 
     'DBItest.R'
+    'compat-purrr.R'
     'context.R'
     'dbi.R'
     'expectations.R'
@@ -127,6 +128,7 @@ Collate:
     'test-compliance.R'
     'test-stress.R'
     'tweaks.R'
+    'use.R'
     'utf8.R'
     'utils.R'
     'zzz.R'

NAMESPACE

@@ -3,21 +3,54 @@
 S3method("$",DBItest_tweaks)
 S3method(format,DBItest_tweaks)
 S3method(print,DBItest_tweaks)
+export(check_df)
+export(connect)
+export(dbi_generics)
+export(expect_all_args_have_default_values)
+export(expect_ellipsis_in_formals)
+export(expect_equal_df)
+export(expect_has_class_method)
+export(expect_invisible_true)
 export(get_default_context)
+export(get_key_methods)
+export(get_penguins)
+export(get_pkg_path)
+export(get_placeholder_funs)
+export(get_texts)
+export(has_utf8_or_ascii_encoding)
+export(local_connection)
+export(local_remove_test_table)
+export(local_result)
 export(make_context)
+export(new_bind_tester_extra)
+export(package_name)
+export(random_table_name)
+export(s4_methods)
 export(set_default_context)
+export(sql_union)
 export(test_all)
 export(test_compliance)
 export(test_connection)
+export(test_data_type)
 export(test_driver)
 export(test_getting_started)
 export(test_meta)
 export(test_result)
+export(test_select)
+export(test_select_bind)
+export(test_select_with_null)
 export(test_some)
 export(test_sql)
 export(test_stress)
+export(test_table_roundtrip)
+export(test_table_roundtrip_one)
 export(test_transaction)
+export(trivial_df)
+export(trivial_query)
+export(trivial_values)
+export(try_silent)
 export(tweaks)
+export(unrowname)
 import(testthat)
 importFrom(DBI,Id)
 importFrom(DBI,SQL)
@@ -61,7 +94,6 @@ importFrom(DBI,dbUnquoteIdentifier)
 importFrom(DBI,dbWithTransaction)
 importFrom(DBI,dbWriteTable)
 importFrom(callr,r)
-importFrom(desc,desc_get_deps)
 importFrom(lubridate,with_tz)
 importFrom(methods,extends)
 importFrom(methods,findMethod)
@@ -70,8 +102,10 @@ importFrom(methods,getClasses)
 importFrom(methods,hasMethod)
 importFrom(methods,is)
 importFrom(methods,new)
+importFrom(rlang,"%||%")
 importFrom(rlang,":=")
 importFrom(rlang,abort)
+importFrom(rlang,as_function)
 importFrom(rlang,enexpr)
 importFrom(rlang,enquo)
 importFrom(rlang,enquos)
@@ -80,7 +114,10 @@ importFrom(rlang,expr)
 importFrom(rlang,has_length)
 importFrom(rlang,is_interactive)
 importFrom(rlang,list2)
+importFrom(rlang,local_options)
 importFrom(rlang,quo)
+importFrom(rlang,seq2)
+importFrom(rlang,set_names)
 importFrom(stats,setNames)
 importFrom(utils,head)
 importFrom(withr,with_output_sink)

R/compat-purrr.R

@@ -0,0 +1,222 @@
+# nocov start - compat-purrr.R
+# Latest version: https://github.com/r-lib/rlang/blob/main/R/compat-purrr.R
+
+# This file provides a minimal shim to provide a purrr-like API on top of
+# base R functions. They are not drop-in replacements but allow a similar style
+# of programming.
+#
+# Changelog:
+#
+# 2022-06-07:
+# * `transpose()` is now more consistent with purrr when inner names
+#   are not congruent (#1346).
+#
+# 2021-12-15:
+# * `transpose()` now supports empty lists.
+#
+# 2021-05-21:
+# * Fixed "object `x` not found" error in `imap()` (@mgirlich)
+#
+# 2020-04-14:
+# * Removed `pluck*()` functions
+# * Removed `*_cpl()` functions
+# * Used `as_function()` to allow use of `~`
+# * Used `.` prefix for helpers
+
+map <- function(.x, .f, ...) {
+  .f <- as_function(.f, env = global_env())
+  lapply(.x, .f, ...)
+}
+walk <- function(.x, .f, ...) {
+  map(.x, .f, ...)
+  invisible(.x)
+}
+
+map_lgl <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, logical(1), ...)
+}
+map_int <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, integer(1), ...)
+}
+map_dbl <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, double(1), ...)
+}
+map_chr <- function(.x, .f, ...) {
+  .rlang_purrr_map_mold(.x, .f, character(1), ...)
+}
+.rlang_purrr_map_mold <- function(.x, .f, .mold, ...) {
+  .f <- as_function(.f, env = global_env())
+  out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE)
+  names(out) <- names(.x)
+  out
+}
+
+map2 <- function(.x, .y, .f, ...) {
+  .f <- as_function(.f, env = global_env())
+  out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE)
+  if (length(out) == length(.x)) {
+    set_names(out, names(.x))
+  } else {
+    set_names(out, NULL)
+  }
+}
+map2_lgl <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "logical")
+}
+map2_int <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "integer")
+}
+map2_dbl <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "double")
+}
+map2_chr <- function(.x, .y, .f, ...) {
+  as.vector(map2(.x, .y, .f, ...), "character")
+}
+imap <- function(.x, .f, ...) {
+  map2(.x, names(.x) %||% seq_along(.x), .f, ...)
+}
+
+pmap <- function(.l, .f, ...) {
+  .f <- as.function(.f)
+  args <- .rlang_purrr_args_recycle(.l)
+  do.call("mapply", c(
+    FUN = list(quote(.f)),
+    args, MoreArgs = quote(list(...)),
+    SIMPLIFY = FALSE, USE.NAMES = FALSE
+  ))
+}
+.rlang_purrr_args_recycle <- function(args) {
+  lengths <- map_int(args, length)
+  n <- max(lengths)
+
+  stopifnot(all(lengths == 1L | lengths == n))
+  to_recycle <- lengths == 1L
+  args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n))
+
+  args
+}
+
+keep <- function(.x, .f, ...) {
+  .x[.rlang_purrr_probe(.x, .f, ...)]
+}
+discard <- function(.x, .p, ...) {
+  sel <- .rlang_purrr_probe(.x, .p, ...)
+  .x[is.na(sel) | !sel]
+}
+map_if <- function(.x, .p, .f, ...) {
+  matches <- .rlang_purrr_probe(.x, .p)
+  .x[matches] <- map(.x[matches], .f, ...)
+  .x
+}
+.rlang_purrr_probe <- function(.x, .p, ...) {
+  if (is_logical(.p)) {
+    stopifnot(length(.p) == length(.x))
+    .p
+  } else {
+    .p <- as_function(.p, env = global_env())
+    map_lgl(.x, .p, ...)
+  }
+}
+
+compact <- function(.x) {
+  Filter(length, .x)
+}
+
+transpose <- function(.l) {
+  if (!length(.l)) {
+    return(.l)
+  }
+
+  inner_names <- names(.l[[1]])
+
+  if (is.null(inner_names)) {
+    fields <- seq_along(.l[[1]])
+  } else {
+    fields <- set_names(inner_names)
+    .l <- map(.l, function(x) {
+      if (is.null(names(x))) {
+        set_names(x, inner_names)
+      } else {
+        x
+      }
+    })
+  }
+
+  # This way missing fields are subsetted as `NULL` instead of causing
+  # an error
+  .l <- map(.l, as.list)
+
+  map(fields, function(i) {
+    map(.l, .subset2, i)
+  })
+}
+
+every <- function(.x, .p, ...) {
+  .p <- as_function(.p, env = global_env())
+
+  for (i in seq_along(.x)) {
+    if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE)
+  }
+  TRUE
+}
+some <- function(.x, .p, ...) {
+  .p <- as_function(.p, env = global_env())
+
+  for (i in seq_along(.x)) {
+    if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE)
+  }
+  FALSE
+}
+negate <- function(.p) {
+  .p <- as_function(.p, env = global_env())
+  function(...) !.p(...)
+}
+
+reduce <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(x, y, ...)
+  Reduce(f, .x, init = .init)
+}
+reduce_right <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(y, x, ...)
+  Reduce(f, .x, init = .init, right = TRUE)
+}
+accumulate <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(x, y, ...)
+  Reduce(f, .x, init = .init, accumulate = TRUE)
+}
+accumulate_right <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(y, x, ...)
+  Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE)
+}
+
+detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) {
+  .p <- as_function(.p, env = global_env())
+  .f <- as_function(.f, env = global_env())
+
+  for (i in .rlang_purrr_index(.x, .right)) {
+    if (.p(.f(.x[[i]], ...))) {
+      return(.x[[i]])
+    }
+  }
+  NULL
+}
+detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) {
+  .p <- as_function(.p, env = global_env())
+  .f <- as_function(.f, env = global_env())
+
+  for (i in .rlang_purrr_index(.x, .right)) {
+    if (.p(.f(.x[[i]], ...))) {
+      return(i)
+    }
+  }
+  0L
+}
+.rlang_purrr_index <- function(x, right = FALSE) {
+  idx <- seq_along(x)
+  if (right) {
+    idx <- rev(idx)
+  }
+  idx
+}
+
+# nocov end

R/context.R

@@ -78,10 +78,12 @@ get_default_context <- function() {
   .ctx_env$default_context
 }
 
+#' @export
 package_name <- function(ctx) {
   attr(class(ctx$drv), "package")
 }
 
+#' @export
 connect <- function(ctx, ...) {
   quos <- enquos(...)
   eval_tidy(quo(dbConnect(ctx$cnr, !!!quos)))

R/dbi.R

@@ -29,6 +29,7 @@ create_generics <- function() {
   writeLines(text, "R/generics.R")
 }
 
+#' @export
 dbi_generics <- function(version) {
   version <- as.package_version(version)
 

R/expectations.R

@@ -9,6 +9,7 @@ expect_arglist_is_empty <- function(object) {
   invisible(act$val)
 }
 
+#' @export
 expect_all_args_have_default_values <- function(object) {
   act <- quasi_label(rlang::enquo(object), arg = "object")
   act$args <- formals(act$val)
@@ -38,6 +39,7 @@ expect_visible <- function(code) {
   ret$value
 }
 
+#' @export
 expect_invisible_true <- function(code) {
   ret <- withVisible(code)
   expect_true(ret$value)
@@ -46,6 +48,7 @@ expect_invisible_true <- function(code) {
   invisible(ret$value)
 }
 
+#' @export
 expect_equal_df <- function(actual, expected) {
   factor_cols <- vapply(expected, is.factor, logical(1L))
   expected[factor_cols] <- lapply(expected[factor_cols], as.character)

R/import-testthat.R

@@ -1,6 +1,7 @@
 #' @import testthat
 #' @importFrom rlang quo enquo enquos expr enexpr eval_tidy list2 has_length :=
-#' @importFrom rlang abort is_interactive
+#' @importFrom rlang abort is_interactive as_function local_options seq2 set_names
+#' @importFrom rlang %||%
 NULL
 
 #' @importFrom methods findMethod getClasses getClass extends

R/s4.R

@@ -1,4 +1,5 @@
 # http://stackoverflow.com/a/39880324/946850
+#' @export
 s4_methods <- function(env, pkg_fun = NULL) {
   generics <- methods::getGenerics(env)