WIP: Inline test_select()

R/expectations.R

@@ -48,10 +48,10 @@ expect_invisible_true <- function(code) {
 
 expect_equal_df <- function(actual, expected) {
   factor_cols <- map_lgl(expected, is.factor)
-  expected[factor_cols] <- lapply(expected[factor_cols], as.character)
+  expected[factor_cols] <- map(expected[factor_cols], as.character)
 
   asis_cols <- map_lgl(expected, inherits, "AsIs")
-  expected[asis_cols] <- lapply(expected[asis_cols], unclass)
+  expected[asis_cols] <- map(expected[asis_cols], unclass)
 
   list_cols <- map_lgl(expected, is.list)
 

R/run.R

@@ -108,7 +108,7 @@ get_skip_names <- function(skip) {
   }
   names_all <- names(spec_all)
   names_all <- names_all[names_all != ""]
-  skip_flags_all <- lapply(paste0("(?:^(?:", skip, ")(?:|_[0-9]+)$)"), grepl, names_all, perl = TRUE)
+  skip_flags_all <- map(paste0("(?:^(?:", skip, ")(?:|_[0-9]+)$)"), grepl, names_all, perl = TRUE)
   skip_used <- map_lgl(skip_flags_all, any)
   if (!all(skip_used)) {
     warning("Unused skip expressions: ", paste(skip[!skip_used], collapse = ", "),
@@ -129,7 +129,7 @@ get_run_only_tests <- function(tests, run_only) {
     return(tests)
   }
 
-  run_only_flags_all <- lapply(paste0("(?:^(?:", run_only, ")$)"), grepl, names_all, perl = TRUE)
+  run_only_flags_all <- map(paste0("(?:^(?:", run_only, ")$)"), grepl, names_all, perl = TRUE)
   run_only_flag_all <- Reduce(`|`, run_only_flags_all)
   run_only_tests <- names_all[run_only_flag_all]
 

R/spec-arrow-append-table-arrow.R

@@ -465,16 +465,16 @@ spec_arrow_append_table_arrow <- list(
   arrow_append_table_arrow_roundtrip_mixed = function(con) {
     #' Mixing column types in the same table is supported.
     data <- list("a", 1L, 1.5)
-    data <- lapply(data, c, NA)
+    data <- map(data, c, NA)
     expanded <- expand.grid(a = data, b = data, c = data)
-    tbl_in_list <- lapply(
+    tbl_in_list <- map(
       seq_len(nrow(expanded)),
       function(i) {
-        data.frame(lapply(expanded[i, ], unlist, recursive = FALSE))
+        data.frame(map(expanded[i, ], unlist, recursive = FALSE))
       }
     )
 
-    lapply(tbl_in_list, test_arrow_roundtrip, con = con)
+    map(tbl_in_list, test_arrow_roundtrip, con = con)
   },
 
   arrow_append_table_arrow_name = function(ctx, con) {

R/spec-arrow-write-table-arrow.R

@@ -698,16 +698,16 @@ spec_arrow_write_table_arrow <- list(
   arrow_write_table_arrow_roundtrip_mixed = function(ctx, con) {
     #' Mixing column types in the same table is supported.
     data <- list("a", 1L, 1.5)
-    data <- lapply(data, c, NA)
+    data <- map(data, c, NA)
     expanded <- expand.grid(a = data, b = data, c = data)
-    tbl_in_list <- lapply(
+    tbl_in_list <- map(
       seq_len(nrow(expanded)),
       function(i) {
-        as.data.frame(lapply(expanded[i, ], unlist, recursive = FALSE))
+        as.data.frame(map(expanded[i, ], unlist, recursive = FALSE))
       }
     )
 
-    lapply(tbl_in_list, test_arrow_roundtrip, con = con)
+    map(tbl_in_list, test_arrow_roundtrip, con = con)
   },
 
   #

R/spec-driver-data-type.R

@@ -87,7 +87,7 @@ test_data_type <- function(ctx, dbObj) {
     }
   )
 
-  lapply(
+  map(
     compact(expected_data_types),
     expect_has_data_type
   )
@@ -96,7 +96,7 @@ test_data_type <- function(ctx, dbObj) {
 
   #' As-is objects (i.e., wrapped by [I()]) must be
   #' supported and return the same results as their unwrapped counterparts.
-  lapply(
+  map(
     compact(expected_data_types),
     function(value) {
       if (!is.null(value)) {

R/spec-meta-bind-.R

@@ -77,7 +77,7 @@ test_select_bind_expr <- function(
 get_placeholder_funs <- function(ctx, requires_names = NULL) {
   placeholder_fun <- ctx$tweaks$placeholder_pattern
   if (is.character(placeholder_fun)) {
-    placeholder_funs <- lapply(placeholder_fun, make_placeholder_fun)
+    placeholder_funs <- map(placeholder_fun, make_placeholder_fun)
   } else if (is.function(placeholder_fun)) {
     placeholder_funs <- list(placeholder_fun)
   } else {

R/spec-meta-bind-expr.R

@@ -361,7 +361,7 @@ spec_meta_bind_expr <- function(
       test_select_bind_expr(
         arrow = arrow,
         bind = bind,
-        lapply(c(get_texts(), NA_character_), factor),
+        map(c(get_texts(), NA_character_), factor),
         warn = if (bind == "df") TRUE,
         dbitest_version = if (arrow == "query" && bind == "df") "1.7.99.13"
       )

R/spec-result-roundtrip.R

@@ -26,7 +26,7 @@ spec_result_roundtrip <- list(
     sql_names <- paste0("CAST(", int_values, " AS ", dbDataType(con, logical()), ")")
 
     #' with NA for SQL `NULL` values
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(values, sql_names))
   },
 
   data_character = function(ctx, con) {
@@ -36,8 +36,8 @@ spec_result_roundtrip <- list(
     sql_names <- as.character(dbQuoteString(con, values))
 
     #' with NA for SQL `NULL` values
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names))
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(test_funs, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(test_funs, sql_names))
   },
 
   data_raw = function(ctx, con) {
@@ -54,13 +54,13 @@ spec_result_roundtrip <- list(
     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))
+    test_select_with_null(.ctx = ctx, con, !!!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) {
+      map(x, function(xx) {
         function(value) as.Date(value) == xx
       })
     }
@@ -70,11 +70,14 @@ spec_result_roundtrip <- list(
     sql_names <- ctx$tweaks$date_cast(char_values)
 
     #' with NA for SQL `NULL` values
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(values, sql_names))
   },
 
   data_date_current = function(ctx, con) {
     #'   (also applies to the return value of the SQL function `current_date`)
+    # FIXME: Turn into two checks, each with a separate skip
+    # depending on the tweak, to avoid mangling the query at run time
+    # Same with current_time and current_timestamp
     test_select_with_null(
       .ctx = ctx, con,
       "current_date" ~ is_roughly_current_date
@@ -84,7 +87,7 @@ 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) {
+      map(x, function(xx) {
         function(value) hms::as_hms(value) == xx
       })
     }
@@ -94,7 +97,7 @@ spec_result_roundtrip <- list(
     sql_names <- ctx$tweaks$time_cast(char_values)
 
     #' with NA for SQL `NULL` values
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(time_values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(time_values, sql_names))
   },
 
   data_time_current = function(ctx, con) {
@@ -117,7 +120,7 @@ spec_result_roundtrip <- list(
     sql_names <- ctx$tweaks$timestamp_cast(char_values)
 
     #' with NA for SQL `NULL` values
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(time_values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(time_values, sql_names))
   },
 
   data_timestamp_current = function(ctx, con) {
@@ -145,10 +148,10 @@ spec_result_roundtrip <- list(
     }
 
     char_values <- paste0("2015-01-", sprintf("%.2d", 1:12))
-    values <- lapply(char_values, as_numeric_date)
+    values <- map(char_values, as_numeric_date)
     sql_names <- ctx$tweaks$date_cast(char_values)
 
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(values, sql_names))
   },
 
   data_date_current_typed = function(ctx, con) {
@@ -173,7 +176,7 @@ spec_result_roundtrip <- list(
     timestamp_values <- rep(list(is_timestamp), 2L)
     sql_names <- ctx$tweaks$timestamp_cast(char_values)
 
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(timestamp_values, sql_names))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(timestamp_values, sql_names))
   },
 
   data_timestamp_current_typed = function(ctx, con) {
@@ -199,21 +202,21 @@ spec_result_roundtrip <- list(
   #'   to the true value
   data_64_bit_numeric = function(ctx, con) {
     as_numeric_identical_to <- function(x) {
-      lapply(x, function(xx) {
+      map(x, function(xx) {
         function(value) as.numeric(value) == xx
       })
     }
 
     char_values <- c("10000000000", "-10000000000")
     test_values <- as_numeric_identical_to(as.numeric(char_values))
 
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(test_values, char_values))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(test_values, char_values))
   },
 
   #' - 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) {
+      map(x, function(xx) {
         function(value) isTRUE(all.equal(as.numeric(value), xx))
       })
     }
@@ -224,17 +227,17 @@ spec_result_roundtrip <- list(
 
     suppressWarnings(
       expect_warning(
-        test_select(.ctx = ctx, con, .dots = setNames(test_values, char_values), .add_null = "none")
+        test_select(.ctx = ctx, con, !!!setNames(test_values, char_values), .add_null = "none")
       )
     )
     suppressWarnings(
       expect_warning(
-        test_select(.ctx = ctx, con, .dots = setNames(test_values, char_values), .add_null = "above")
+        test_select(.ctx = ctx, con, !!!setNames(test_values, char_values), .add_null = "above")
       )
     )
     suppressWarnings(
       expect_warning(
-        test_select(.ctx = ctx, con, .dots = setNames(test_values, char_values), .add_null = "below")
+        test_select(.ctx = ctx, con, !!!setNames(test_values, char_values), .add_null = "below")
       )
     )
   },
@@ -243,15 +246,15 @@ spec_result_roundtrip <- list(
   #'   of the data
   data_64_bit_lossless = function(ctx, con) {
     as_character_equals_to <- function(x) {
-      lapply(x, function(xx) {
+      map(x, function(xx) {
         function(value) as.character(value) == xx
       })
     }
 
     char_values <- c("1234567890123456789", "-1234567890123456789")
     test_values <- as_character_equals_to(char_values)
 
-    test_select_with_null(.ctx = ctx, con, .dots = setNames(test_values, char_values))
+    test_select_with_null(.ctx = ctx, con, !!!setNames(test_values, char_values))
   },
   #
   NULL
@@ -264,31 +267,43 @@ test_select_with_null <- function(...) {
   test_select(..., .add_null = "below")
 }
 
-test_select <- function(con, ..., .dots = NULL, .add_null = "none",
-                        .ctx, .envir = parent.frame()) {
-  values <- c(list(...), .dots)
+test_select <- function(
+    # Run time
+    con,
+    # Spec time
+    ...,
+    .add_null = "none",
+    # Run time
+    .ctx,
+    .envir = parent.frame()) {
+
+  values <- list2(...)
 
   value_is_formula <- map_lgl(values, is.call)
-  names(values)[value_is_formula] <- lapply(values[value_is_formula], "[[", 2L)
-  values[value_is_formula] <- lapply(
+  names(values)[value_is_formula] <- map(values[value_is_formula], "[[", 2L)
+  values[value_is_formula] <- map(
     values[value_is_formula],
     function(x) {
       eval(x[[3]], envir = .envir)
     }
   )
 
   if (is.null(names(values))) {
-    sql_values <- lapply(values, as.character)
+    sql_values <- map(values, as.character)
   } else {
     sql_values <- names(values)
   }
 
-  if (isTRUE(.ctx$tweaks$current_needs_parens)) {
-    sql_values <- gsub(
-      "^(current_(?:date|time|timestamp))$", "\\1()",
-      sql_values
-    )
-  }
+  sql_values_expr <- expr({
+    sql_values <- !!construct_expr(sql_values)
+
+    if (isTRUE(.ctx$tweaks$current_needs_parens)) {
+      sql_values <- gsub(
+        "^(current_(?:date|time|timestamp))$", "\\1()",
+        sql_values
+      )
+    }
+  })
 
   sql_names <- letters[seq_along(sql_values)]
 
@@ -383,7 +398,7 @@ coercible_to_time <- function(x) {
 }
 
 as_timestamp_equals_to <- function(x) {
-  lapply(x, function(xx) {
+  map(x, function(xx) {
     function(value) as.POSIXct(value) == xx
   })
 }

R/spec-sql-append-table.R

@@ -470,16 +470,16 @@ spec_sql_append_table <- list(
   append_roundtrip_mixed = function(con) {
     #' Mixing column types in the same table is supported.
     data <- list("a", 1L, 1.5)
-    data <- lapply(data, c, NA)
+    data <- map(data, c, NA)
     expanded <- expand.grid(a = data, b = data, c = data)
-    tbl_in_list <- lapply(
+    tbl_in_list <- map(
       seq_len(nrow(expanded)),
       function(i) {
-        as.data.frame(lapply(expanded[i, ], unlist, recursive = FALSE))
+        as.data.frame(map(expanded[i, ], unlist, recursive = FALSE))
       }
     )
 
-    lapply(tbl_in_list, test_table_roundtrip, con = con)
+    map(tbl_in_list, test_table_roundtrip, con = con)
   },
 
   append_table_name = function(ctx, con) {

R/spec-sql-list-objects.R

@@ -25,7 +25,7 @@ spec_sql_list_objects <- list(
     #' The `table` column is of type list.
     expect_equal(typeof(objects$table), "list")
     #' Each object in this list is suitable for use as argument in [dbQuoteIdentifier()].
-    expect_error(lapply(objects$table, dbQuoteIdentifier, conn = con), NA)
+    expect_error(map(objects$table, dbQuoteIdentifier, conn = con), NA)
 
     #' The `is_prefix` column is a logical.
     expect_type(objects$is_prefix, "logical")

R/spec-sql-quote-literal.R

@@ -84,9 +84,9 @@ spec_sql_quote_literal <- list(
       expect_equal(nrow(x_out), 1L)
 
       is_logical <- map_lgl(x, is.logical)
-      x_out[is_logical] <- lapply(x_out[is_logical], as.logical)
+      x_out[is_logical] <- map(x_out[is_logical], as.logical)
       is_numeric <- map_lgl(x, is.numeric)
-      x_out[is_numeric] <- lapply(x_out[is_numeric], as.numeric)
+      x_out[is_numeric] <- map(x_out[is_numeric], as.numeric)
       expect_equal(as.list(unname(x_out)), x)
     }