Exports and inlines

NAMESPACE

@@ -8,13 +8,16 @@ 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)
@@ -32,17 +35,21 @@ 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)

R/expectations.R

@@ -48,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/spec-meta-bind-.R

@@ -95,7 +95,7 @@ BindTester <- R6::R6Class(
       ret_values <- trivial_values(2)
       placeholder <- placeholder_fun(length(values))
       is_na <- vapply(values, is_na_or_null, logical(1))
-      placeholder_values <- vapply(values, function(x) quote_literal(con, x[1]), character(1))
+      placeholder_values <- vapply(values, function(x) DBI::dbQuoteLiteral(con, x[1]), character(1))
       result_names <- letters[seq_along(values)]
 
       query <- paste0(

R/spec-result-roundtrip.R

@@ -46,15 +46,25 @@ spec_result_roundtrip <- list(
       skip("tweak: omit_blob_tests")
     }
 
+    is_raw_list <- function(x) {
+      is.list(x) && is.raw(x[[1L]])
+    }
+
     values <- list(is_raw_list)
-    sql_names <- ctx$tweaks$blob_cast(quote_literal(con, list(raw(1))))
+    sql_names <- ctx$tweaks$blob_cast(DBI::dbQuoteLiteral(con, list(raw(1))))
 
     #' with [NULL] entries for SQL NULL values
     test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names))
   },
 
   data_date = function(ctx, con) {
     #' - coercible using [as.Date()] for dates,
+    as_date_equals_to <- function(x) {
+      lapply(x, function(xx) {
+        function(value) as.Date(value) == xx
+      })
+    }
+
     char_values <- paste0("2015-01-", sprintf("%.2d", 1:12))
     values <- as_date_equals_to(as.Date(char_values))
     sql_names <- ctx$tweaks$date_cast(char_values)
@@ -73,6 +83,12 @@ spec_result_roundtrip <- list(
 
   data_time = function(ctx, con) {
     #' - coercible using [hms::as_hms()] for times,
+    as_hms_equals_to <- function(x) {
+      lapply(x, function(xx) {
+        function(value) hms::as_hms(value) == xx
+      })
+    }
+
     char_values <- c("00:00:00", "12:34:56")
     time_values <- as_hms_equals_to(hms::as_hms(char_values))
     sql_names <- ctx$tweaks$time_cast(char_values)
@@ -91,6 +107,11 @@ spec_result_roundtrip <- list(
 
   data_timestamp = function(ctx, con) {
     #' - coercible using [as.POSIXct()] for timestamps,
+    coercible_to_timestamp <- function(x) {
+      x_timestamp <- try_silent(as.POSIXct(x))
+      !is.null(x_timestamp) && all(is.na(x) == is.na(x_timestamp))
+    }
+
     char_values <- c("2015-10-11 00:00:00", "2015-10-11 12:34:56")
     time_values <- rep(list(coercible_to_timestamp), 2L)
     sql_names <- ctx$tweaks$timestamp_cast(char_values)
@@ -101,6 +122,15 @@ spec_result_roundtrip <- list(
 
   data_timestamp_current = function(ctx, con) {
     #'   (also applies to the return value of the SQL function `current_timestamp`)
+    coercible_to_timestamp <- function(x) {
+      x_timestamp <- try_silent(as.POSIXct(x))
+      !is.null(x_timestamp) && all(is.na(x) == is.na(x_timestamp))
+    }
+
+    is_roughly_current_timestamp <- function(x) {
+      coercible_to_timestamp(x) && (Sys.time() - as.POSIXct(x, tz = "UTC") <= hms::hms(2))
+    }
+
     test_select_with_null(
       .ctx = ctx, con,
       "current_timestamp" ~ is_roughly_current_timestamp
@@ -170,6 +200,12 @@ spec_result_roundtrip <- list(
   #' - Coercion to numeric always returns a number that is as close as possible
   #'   to the true value
   data_64_bit_numeric = function(ctx, con) {
+    as_numeric_identical_to <- function(x) {
+      lapply(x, function(xx) {
+        function(value) as.numeric(value) == xx
+      })
+    }
+
     char_values <- c("10000000000", "-10000000000")
     test_values <- as_numeric_identical_to(as.numeric(char_values))
 
@@ -178,6 +214,12 @@ spec_result_roundtrip <- list(
 
   #' - Loss of precision when converting to numeric gives a warning
   data_64_bit_numeric_warning = function(ctx, con) {
+    as_numeric_equals_to <- function(x) {
+      lapply(x, function(xx) {
+        function(value) isTRUE(all.equal(as.numeric(value), xx))
+      })
+    }
+
     char_values <- c(" 1234567890123456789", "-1234567890123456789")
     num_values <- as.numeric(char_values)
     test_values <- as_numeric_equals_to(num_values)
@@ -202,6 +244,12 @@ spec_result_roundtrip <- list(
   #' - Conversion to character always returns a lossless decimal representation
   #'   of the data
   data_64_bit_lossless = function(ctx, con) {
+    as_character_equals_to <- function(x) {
+      lapply(x, function(xx) {
+        function(value) as.character(value) == xx
+      })
+    }
+
     char_values <- c("1234567890123456789", "-1234567890123456789")
     test_values <- as_character_equals_to(char_values)
 
@@ -219,6 +267,7 @@ test_select_with_null <- function(...) {
   test_select(..., .add_null = "below")
 }
 
+#' @export
 test_select <- function(con, ..., .dots = NULL, .add_null = "none",
                         .ctx, .envir = parent.frame()) {
   values <- c(list(...), .dots)
@@ -308,6 +357,7 @@ all_have_utf8_or_ascii_encoding <- function(x) {
   all(vapply(x, has_utf8_or_ascii_encoding, logical(1L)))
 }
 
+#' @export
 has_utf8_or_ascii_encoding <- function(x) {
   if (Encoding(x) == "UTF-8") {
     TRUE
@@ -323,21 +373,11 @@ has_utf8_or_ascii_encoding <- function(x) {
   }
 }
 
-is_raw_list <- function(x) {
-  is.list(x) && is.raw(x[[1L]])
-}
-
 coercible_to_date <- function(x) {
   x_date <- try_silent(as.Date(x))
   !is.null(x_date) && all(is.na(x) == is.na(x_date))
 }
 
-as_date_equals_to <- function(x) {
-  lapply(x, function(xx) {
-    function(value) as.Date(value) == xx
-  })
-}
-
 is_roughly_current_date <- function(x) {
   coercible_to_date(x) && (abs(Sys.Date() - as.Date(x)) <= 1)
 }
@@ -347,45 +387,12 @@ coercible_to_time <- function(x) {
   !is.null(x_hms) && all(is.na(x) == is.na(x_hms))
 }
 
-as_hms_equals_to <- function(x) {
-  lapply(x, function(xx) {
-    function(value) hms::as_hms(value) == xx
-  })
-}
-
-coercible_to_timestamp <- function(x) {
-  x_timestamp <- try_silent(as.POSIXct(x))
-  !is.null(x_timestamp) && all(is.na(x) == is.na(x_timestamp))
-}
-
 as_timestamp_equals_to <- function(x) {
   lapply(x, function(xx) {
     function(value) as.POSIXct(value) == xx
   })
 }
 
-as_numeric_identical_to <- function(x) {
-  lapply(x, function(xx) {
-    function(value) as.numeric(value) == xx
-  })
-}
-
-as_numeric_equals_to <- function(x) {
-  lapply(x, function(xx) {
-    function(value) isTRUE(all.equal(as.numeric(value), xx))
-  })
-}
-
-as_character_equals_to <- function(x) {
-  lapply(x, function(xx) {
-    function(value) as.character(value) == xx
-  })
-}
-
-is_roughly_current_timestamp <- function(x) {
-  coercible_to_timestamp(x) && (Sys.time() - as.POSIXct(x, tz = "UTC") <= hms::hms(2))
-}
-
 is_date <- function(x) {
   inherits(x, "Date")
 }
@@ -406,7 +413,3 @@ as_numeric_date <- function(d) {
   d <- as.Date(d)
   structure(as.numeric(unclass(d)), class = class(d))
 }
-
-quote_literal <- function(con, x) {
-  DBI::dbQuoteLiteral(con, x)
-}

R/spec-sql-quote-string.R

@@ -67,6 +67,11 @@ spec_sql_quote_string <- list(
       expect_identical(unlist(unname(x_out)), x)
     }
 
+    expand_char <- function(...) {
+      df <- expand.grid(..., stringsAsFactors = FALSE)
+      do.call(paste0, df)
+    }
+
     test_chars <- c(
       #' even if `x` contains
       "",

R/spec-sql-write-table.R

@@ -822,12 +822,14 @@ spec_sql_write_table <- list(
   NULL
 )
 
+#' @export
 test_table_roundtrip <- function(...) {
   test_table_roundtrip_one(..., .add_na = "none")
   test_table_roundtrip_one(..., .add_na = "above")
   test_table_roundtrip_one(..., .add_na = "below")
 }
 
+#' @export
 test_table_roundtrip_one <- function(con, tbl_in, tbl_expected = tbl_in, transform = identity,
                                      name = NULL, field.types = NULL, use_append = FALSE, .add_na = "none") {
   force(tbl_expected)

R/use.R

@@ -24,31 +24,41 @@ use_dbitest <- function(path) {
   ))
   usethis::use_import_from("DBItest", c(
     "get_default_context",
+    "connect",
     "local_connection",
     "local_result",
-    "connect",
-    "trivial_query",
+    "local_remove_test_table",
     "try_silent",
     "package_name",
     "get_pkg_path",
-    "test_data_type",
-    "expect_invisible_true",
     "s4_methods",
+    "expect_invisible_true",
+    "expect_equal_df",
     "expect_all_args_have_default_values",
     "expect_ellipsis_in_formals",
     "expect_has_class_method",
     "get_key_methods",
     "dbi_generics",
     "check_df",
-    "test_select_bind",
-    "new_bind_tester_extra",
     "random_table_name",
-    "local_remove_test_table",
     "get_placeholder_funs",
+    "has_utf8_or_ascii_encoding",
+    #
+    "trivial_query",
     "trivial_df",
     "trivial_values",
-    "test_select_with_null",
+    "get_penguins",
+    #
     "get_texts",
+    "unrowname",
+    #
+    "test_data_type",
+    "test_select_with_null",
+    "test_select",
+    "test_select_bind",
+    "new_bind_tester_extra",
+    "test_table_roundtrip",
+    "test_table_roundtrip_one",
     NULL
   ))
 

R/utils.R

@@ -53,6 +53,7 @@ local_remove_test_table <- function(con, name, frame = rlang::caller_env()) {
   )
 }
 
+#' @export
 get_penguins <- function(ctx) {
   datasets_penguins <- unrowname(palmerpenguins::penguins[c(1, 153, 277), ])
   if (!isTRUE(ctx$tweaks$strict_identifier)) {
@@ -61,6 +62,7 @@ get_penguins <- function(ctx) {
   as.data.frame(datasets_penguins)
 }
 
+#' @export
 unrowname <- function(x) {
   rownames(x) <- NULL
   x
@@ -76,10 +78,6 @@ compact <- function(x) {
   x[!vapply(x, is.null, logical(1L))]
 }
 
-expand_char <- function(...) {
-  df <- expand.grid(..., stringsAsFactors = FALSE)
-  do.call(paste0, df)
-}
 
 #' @export
 try_silent <- function(code) {