From ac7e067fe774de8e8f39291560f98a7dc800c107 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Fri, 2 May 2025 13:55:54 +0200 Subject: [PATCH 1/8] Script to determine functions to be inlined --- tools/internal.R | 88 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 88 insertions(+) create mode 100644 tools/internal.R diff --git a/tools/internal.R b/tools/internal.R new file mode 100644 index 00000000..18d848bd --- /dev/null +++ b/tools/internal.R @@ -0,0 +1,88 @@ +pkgload::load_all() +library(tidyverse) + +check_missing_objects <- function(fun, env = parent.frame()) { + if (!is.function(fun)) stop("Input must be a function.") + + # Get the function's body and formal arguments + body_expr <- body(fun) + arg_names <- names(formals(fun)) + + # Collect all symbols (names) in the function body + all_symbols <- all.names(body_expr, functions = TRUE, unique = TRUE) + + # Symbols used in function calls + call_symbols <- unique(unlist(lapply(all_calls(body_expr), function(call) as.character(call[[1]])))) + + # Identify symbols not used as function names (i.e., likely values) + value_symbols <- setdiff(all_symbols, call_symbols) + + # Remove function arguments from value_symbols + value_symbols <- setdiff(value_symbols, arg_names) + + # Find assigned variables in the function body + assigned_vars <- find_assigned_vars(body_expr) + + # Remove assigned variables from value_symbols + value_symbols <- setdiff(value_symbols, assigned_vars) + + # Now check existence in the environment + missing_values <- value_symbols[!vapply(value_symbols, exists, logical(1), envir = env, inherits = TRUE)] + missing_calls <- call_symbols[!vapply(call_symbols, function(f) exists(f, mode = "function", envir = env, inherits = TRUE), logical(1))] + + list( + missing_values = missing_values, + missing_calls = missing_calls + ) +} + +# Helper function to extract all function calls from an expression +all_calls <- function(expr) { + calls <- list() + recurse <- function(e) { + if (is.call(e)) { + calls <<- c(calls, list(e)) + lapply(e[-1], recurse) + } + } + recurse(expr) + calls +} + +# Helper function to find variables being assigned to in the function body +find_assigned_vars <- function(expr) { + assigned <- character() + + find_assignments <- function(e) { + if (is.call(e)) { + # Check for assignment operators: <- and = + if (is.symbol(e[[1]]) && as.character(e[[1]]) %in% c("<-", "=")) { + # If left side is a name, add it to assigned vars + if (is.name(e[[2]])) { + assigned <<- c(assigned, as.character(e[[2]])) + } + } + # Recursively check all parts of the call + for (i in seq_along(e)[-1]) { + find_assignments(e[[i]]) + } + } + } + + find_assignments(expr) + unique(assigned) +} + +# check_missing_objects(spec_all[[3]]) + +base <- ls(baseenv()) +DBI <- getNamespaceExports("DBI") +testthat <- getNamespaceExports("testthat") + +base_values <- mget(base, ifnotfound = list(NULL), envir = baseenv()) +DBI_values <- mget(DBI, ifnotfound = list(NULL), envir = asNamespace("DBI")) +testthat_values <- mget(testthat, ifnotfound = list(NULL), envir = asNamespace("testthat")) + +values <- base_values |> modifyList(DBI_values) |> modifyList(testthat_values) + +missing <- purrr::map(compact(spec_all), check_missing_objects, as.environment(values), .progress = TRUE) From b93dad90317365112cdc38214a0e7f1c65de0a35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Fri, 2 May 2025 14:07:28 +0200 Subject: [PATCH 2/8] Second try --- tools/internal.R | 160 ++++++++++++++++++++++++++++------------------- 1 file changed, 94 insertions(+), 66 deletions(-) diff --git a/tools/internal.R b/tools/internal.R index 18d848bd..2ab53ce1 100644 --- a/tools/internal.R +++ b/tools/internal.R @@ -1,88 +1,116 @@ pkgload::load_all() library(tidyverse) -check_missing_objects <- function(fun, env = parent.frame()) { - if (!is.function(fun)) stop("Input must be a function.") - - # Get the function's body and formal arguments - body_expr <- body(fun) - arg_names <- names(formals(fun)) - - # Collect all symbols (names) in the function body - all_symbols <- all.names(body_expr, functions = TRUE, unique = TRUE) - - # Symbols used in function calls - call_symbols <- unique(unlist(lapply(all_calls(body_expr), function(call) as.character(call[[1]])))) +walk_ast <- function( + expr, + env = parent.frame(), + known_values = character(), + unknown_funcs = character(), + unknown_vars = character() +) { + is_known <- function(name) { + name %in% known_values || exists(name, envir = env, inherits = TRUE) + } - # Identify symbols not used as function names (i.e., likely values) - value_symbols <- setdiff(all_symbols, call_symbols) + process_call <- function(call_expr) { + fn <- call_expr[[1]] - # Remove function arguments from value_symbols - value_symbols <- setdiff(value_symbols, arg_names) + if (is.symbol(fn)) { + fn_name <- as.character(fn) + # Handle unknown function calls + if (!is_known(fn_name) && !exists(fn_name, mode = "function", envir = env, inherits = TRUE)) { + unknown_funcs <<- union(unknown_funcs, fn_name) + } + } else if (is.call(fn) && fn[[1]] == quote(`::`)) { + # Handle package::function form + if (length(fn) == 3 && is.symbol(fn[[3]])) { + fn_name <- as.character(fn[[3]]) + # Consider function from package known, but still check args + # Do nothing for fn_name here + } + } else { + # Walk over anonymous or nested function call + walk(expr = fn) + } - # Find assigned variables in the function body - assigned_vars <- find_assigned_vars(body_expr) + # Recursively walk through arguments + for (i in 2:length(call_expr)) { + walk(call_expr[[i]]) + } + } - # Remove assigned variables from value_symbols - value_symbols <- setdiff(value_symbols, assigned_vars) + walk <- function(expr) { + if (is.function(expr)) { + # Handle function definitions + fun_args <- as.character(names(formals(expr))) + child <- walk_ast(body(expr), env = env, known_values = fun_args) + unknown_funcs <<- union(unknown_funcs, child$unknown_functions) + unknown_vars <<- union(unknown_vars, child$unknown_variables) + } + if (is.call(expr)) { + if (identical(expr[[1]], quote(`<-`)) && length(expr) == 3) { + lhs <- expr[[2]] + rhs <- expr[[3]] + if (is.symbol(lhs)) { + lhs_name <- as.character(lhs) + known_values <<- union(known_values, lhs_name) + } + walk(rhs) + } else if (identical(expr[[1]], quote(`function`))) { + # Handle closures with a fresh set of known values + fun_args <- as.character(names(expr[[2]])) + child <- walk_ast(expr[[3]], env = env, known_values = fun_args) + unknown_funcs <<- union(unknown_funcs, child$unknown_functions) + unknown_vars <<- union(unknown_vars, child$unknown_variables) + } else { + process_call(expr) + } + } else if (is.name(expr)) { + var_name <- as.character(expr) + if (!is_known(var_name)) { + unknown_vars <<- union(unknown_vars, var_name) + } + } else if (is.pairlist(expr) || is.expression(expr)) { + for (e in expr) { + walk(e) + } + } else if (is.list(expr)) { + for (e in expr) { + walk(e) + } + } + } - # Now check existence in the environment - missing_values <- value_symbols[!vapply(value_symbols, exists, logical(1), envir = env, inherits = TRUE)] - missing_calls <- call_symbols[!vapply(call_symbols, function(f) exists(f, mode = "function", envir = env, inherits = TRUE), logical(1))] + walk(expr) list( - missing_values = missing_values, - missing_calls = missing_calls + unknown_functions = unknown_funcs, + unknown_variables = unknown_vars, + known_values = known_values ) } -# Helper function to extract all function calls from an expression -all_calls <- function(expr) { - calls <- list() - recurse <- function(e) { - if (is.call(e)) { - calls <<- c(calls, list(e)) - lapply(e[-1], recurse) - } - } - recurse(expr) - calls +fun1 <- function(x) { + foo::bar(x) } -# Helper function to find variables being assigned to in the function body -find_assigned_vars <- function(expr) { - assigned <- character() +walk_ast(fun1) - find_assignments <- function(e) { - if (is.call(e)) { - # Check for assignment operators: <- and = - if (is.symbol(e[[1]]) && as.character(e[[1]]) %in% c("<-", "=")) { - # If left side is a name, add it to assigned vars - if (is.name(e[[2]])) { - assigned <<- c(assigned, as.character(e[[2]])) - } - } - # Recursively check all parts of the call - for (i in seq_along(e)[-1]) { - find_assignments(e[[i]]) - } - } - } - - find_assignments(expr) - unique(assigned) +fun2 <- function(x) { + foo::bar(y) } -# check_missing_objects(spec_all[[3]]) +walk_ast(fun2) -base <- ls(baseenv()) -DBI <- getNamespaceExports("DBI") -testthat <- getNamespaceExports("testthat") +fun3 <- function(x) { + bar(x) +} -base_values <- mget(base, ifnotfound = list(NULL), envir = baseenv()) -DBI_values <- mget(DBI, ifnotfound = list(NULL), envir = asNamespace("DBI")) -testthat_values <- mget(testthat, ifnotfound = list(NULL), envir = asNamespace("testthat")) +walk_ast(fun3) -values <- base_values |> modifyList(DBI_values) |> modifyList(testthat_values) +fun4 <- function(x) { + y <- x + fun3(y) +} -missing <- purrr::map(compact(spec_all), check_missing_objects, as.environment(values), .progress = TRUE) +walk_ast(fun4) From 06d77fce9ae4594a2bb52aadcb9d306a3a35c1f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Fri, 2 May 2025 14:24:15 +0200 Subject: [PATCH 3/8] Tweaks --- tools/internal.R | 47 +++++++++++++++++++++++++++++++++++------------ 1 file changed, 35 insertions(+), 12 deletions(-) diff --git a/tools/internal.R b/tools/internal.R index 2ab53ce1..3ed30000 100644 --- a/tools/internal.R +++ b/tools/internal.R @@ -9,7 +9,7 @@ walk_ast <- function( unknown_vars = character() ) { is_known <- function(name) { - name %in% known_values || exists(name, envir = env, inherits = TRUE) + name == "" || name %in% known_values || exists(name, envir = env, inherits = TRUE) } process_call <- function(call_expr) { @@ -30,24 +30,21 @@ walk_ast <- function( } } else { # Walk over anonymous or nested function call - walk(expr = fn) + walk_node(expr = fn) } # Recursively walk through arguments - for (i in 2:length(call_expr)) { - walk(call_expr[[i]]) - } + walk(call_expr[-1], walk_node) } - walk <- function(expr) { + walk_node <- function(expr) { if (is.function(expr)) { # Handle function definitions fun_args <- as.character(names(formals(expr))) child <- walk_ast(body(expr), env = env, known_values = fun_args) unknown_funcs <<- union(unknown_funcs, child$unknown_functions) unknown_vars <<- union(unknown_vars, child$unknown_variables) - } - if (is.call(expr)) { + } else if (is.call(expr)) { if (identical(expr[[1]], quote(`<-`)) && length(expr) == 3) { lhs <- expr[[2]] rhs <- expr[[3]] @@ -55,7 +52,7 @@ walk_ast <- function( lhs_name <- as.character(lhs) known_values <<- union(known_values, lhs_name) } - walk(rhs) + walk_node(rhs) } else if (identical(expr[[1]], quote(`function`))) { # Handle closures with a fresh set of known values fun_args <- as.character(names(expr[[2]])) @@ -72,16 +69,16 @@ walk_ast <- function( } } else if (is.pairlist(expr) || is.expression(expr)) { for (e in expr) { - walk(e) + walk_node(e) } } else if (is.list(expr)) { for (e in expr) { - walk(e) + walk_node(e) } } } - walk(expr) + walk_node(expr) list( unknown_functions = unknown_funcs, @@ -114,3 +111,29 @@ fun4 <- function(x) { } walk_ast(fun4) + +fun5 <- function(con) { + invisible() +} + +walk_ast(fun5) + +fun6 <- function(x) { + x[1, , 2] +} + +walk_ast(fun6) + +base <- ls(baseenv()) +DBI <- getNamespaceExports("DBI") +testthat <- getNamespaceExports("testthat") + +base_values <- mget(base, ifnotfound = list(NULL), envir = baseenv()) +DBI_values <- mget(DBI, ifnotfound = list(NULL), envir = asNamespace("DBI")) +testthat_values <- mget(testthat, ifnotfound = list(NULL), envir = asNamespace("testthat")) + +values <- base_values |> modifyList(DBI_values) |> modifyList(testthat_values) + +walk_ast(compact(spec_all)[[42]], as.environment(values)) + +missing <- purrr::map(compact(spec_all), walk_ast, as.environment(values), .progress = TRUE) From 09991d5b357ff3ab36aff06fcce1dddb2c0af826 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Fri, 2 May 2025 15:14:46 +0200 Subject: [PATCH 4/8] Work is known --- tools/internal.R | 148 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 142 insertions(+), 6 deletions(-) diff --git a/tools/internal.R b/tools/internal.R index 3ed30000..cb1e202e 100644 --- a/tools/internal.R +++ b/tools/internal.R @@ -17,11 +17,16 @@ walk_ast <- function( if (is.symbol(fn)) { fn_name <- as.character(fn) + if (fn_name %in% c("bquote", "$", "@", "test_select_with_null")) { + # Do nothing for NSE + return() + } + # Handle unknown function calls if (!is_known(fn_name) && !exists(fn_name, mode = "function", envir = env, inherits = TRUE)) { unknown_funcs <<- union(unknown_funcs, fn_name) } - } else if (is.call(fn) && fn[[1]] == quote(`::`)) { + } else if (is.call(fn) && fn[[1]] == "::") { # Handle package::function form if (length(fn) == 3 && is.symbol(fn[[3]])) { fn_name <- as.character(fn[[3]]) @@ -53,12 +58,31 @@ walk_ast <- function( known_values <<- union(known_values, lhs_name) } walk_node(rhs) + } else if (identical(expr[[1]], quote(`=`)) && length(expr) == 3) { + lhs <- expr[[2]] + if (is.symbol(lhs)) { + lhs_name <- as.character(lhs) + known_values <<- union(known_values, lhs_name) + } + rhs <- expr[[3]] + walk_node(rhs) + } else if (identical(expr[[1]], quote(`for`))) { + # Handle for loops + lhs <- expr[[2]] + if (is.symbol(lhs)) { + lhs_name <- as.character(lhs) + known_values <<- union(known_values, lhs_name) + } + walk_node(expr[[3]]) + walk_node(expr[[4]]) } else if (identical(expr[[1]], quote(`function`))) { # Handle closures with a fresh set of known values fun_args <- as.character(names(expr[[2]])) - child <- walk_ast(expr[[3]], env = env, known_values = fun_args) + child <- walk_ast(expr[[3]], env = env, known_values = union(known_values, fun_args)) unknown_funcs <<- union(unknown_funcs, child$unknown_functions) unknown_vars <<- union(unknown_vars, child$unknown_variables) + } else if (identical(expr[[1]], quote(`::`))) { + # Do nothing } else { process_call(expr) } @@ -124,16 +148,128 @@ fun6 <- function(x) { walk_ast(fun6) -base <- ls(baseenv()) +fun7 <- function(x) { + bquote(.(a)) +} + +walk_ast(fun7) + +fun8 <- function(x) { + a$b +} + +walk_ast(fun8) + +fun9 <- function(x) { + for (i in x) { + i + j + } +} + +walk_ast(fun9) + +fun10 <- function(x) { + f <- function(y) { + x + y + } + f(3) +} + +walk_ast(fun10) + +fun11 <- function(x) { + y <- datasets::mtcars +} + +walk_ast(fun11) + +fun12 <- function(x) { + x %>% fun11() +} + +walk_ast(fun12, asNamespace("magrittr")) + +base <- ls(baseenv(), all.names = TRUE) +stats <- c("setNames") +utils <- c("head") +methods <- c("extends", "getClasses", "is") DBI <- getNamespaceExports("DBI") testthat <- getNamespaceExports("testthat") +magrittr <- c("%>%") +DBItest <- c( + "get_pkg_path", + "package_name", + "expect_all_args_have_default_values", + "expect_arglist_is_empty", + "test_data_type", + "connect", + "local_connection", + "expect_invisible_true", + "trivial_query", + "check_df", + "get_placeholder_funs", + "trivial_values", + "trivial_df", + "local_result", + "sql_union", + "unrowname", + "skip_if_not_dbitest", + "trivial_statement", + "random_table_name", + "local_remove_test_table", + "test_select_with_null", + "get_texts", + "map", + "try_silent", + "test_select", + "map_chr", + "map_lgl", + "get_penguins", + "expect_equal_df", + "local_closed_connection", + "local_invalid_connection", + "test_table_roundtrip", + "test_table_roundtrip_one", + "as_numeric_date", + "walk", + "check_arrow", + "stream_frame", + "test_arrow_roundtrip", + "test_arrow_roundtrip_one", + "expect_equal_arrow", + "get_key_methods", + "expect_has_class_method", + "dbi_generics", + "s4_methods", + "has_utf8_or_ascii_encoding", + "is_timestamp", + "expect_ellipsis_in_formals", + NULL +) +DBItest <- character() base_values <- mget(base, ifnotfound = list(NULL), envir = baseenv()) +stats_values <- mget(stats, ifnotfound = list(NULL), envir = asNamespace("stats")) +utils_values <- mget(utils, ifnotfound = list(NULL), envir = asNamespace("utils")) +methods_values <- mget(methods, ifnotfound = list(NULL), envir = asNamespace("methods")) DBI_values <- mget(DBI, ifnotfound = list(NULL), envir = asNamespace("DBI")) testthat_values <- mget(testthat, ifnotfound = list(NULL), envir = asNamespace("testthat")) +magrittr_values <- mget(magrittr, ifnotfound = list(NULL), envir = asNamespace("magrittr")) +DBItest_values <- mget(DBItest, ifnotfound = list(NULL), envir = asNamespace("DBItest")) -values <- base_values |> modifyList(DBI_values) |> modifyList(testthat_values) - -walk_ast(compact(spec_all)[[42]], as.environment(values)) +values <- base_values |> + modifyList(stats_values) |> + modifyList(utils_values) |> + modifyList(methods_values) |> + modifyList(DBI_values) |> + modifyList(testthat_values) |> + modifyList(magrittr_values) |> + modifyList(DBItest_values) missing <- purrr::map(compact(spec_all), walk_ast, as.environment(values), .progress = TRUE) + +counts <- missing |> map(lengths) |> map_int(sum) + +true_missing <- missing[counts > 0] + +true_missing From b984324b93c136d04c50a55fdb2a942548024d81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Sat, 3 May 2025 08:11:46 +0200 Subject: [PATCH 5/8] Rmd --- tools/internal.R | 34 +- tools/missing_functions.Rmd | 933 ++++++++++++++++++++++++++++++++++++ 2 files changed, 966 insertions(+), 1 deletion(-) create mode 100644 tools/missing_functions.Rmd diff --git a/tools/internal.R b/tools/internal.R index cb1e202e..9f0dbb4c 100644 --- a/tools/internal.R +++ b/tools/internal.R @@ -272,4 +272,36 @@ counts <- missing |> map(lengths) |> map_int(sum) true_missing <- missing[counts > 0] -true_missing +# No unknown values +true_missing |> + purrr::map("unknown_values") |> + enframe(value = "value_name") |> + unnest(value_name) |> + count(value_name) |> + arrange(n) + +true_missing_functions_df <- + true_missing |> + purrr::map("unknown_functions") |> + enframe(value = "function_name") |> + unnest(function_name) |> + count(function_name) |> + arrange(n) + +true_missing_functions_df |> + mutate(code = map_chr( + function_name, + ~ paste(capture.output(print(get(.x, asNamespace("DBItest")))), collapse = "\n") + )) |> + mutate(text = glue::glue(" + # {function_name} ({n}) + + `r d(DBItest:::{function_name})` + + ```r + {code} + ``` + ")) |> + summarize(rmd = paste(text, collapse = "\n\n")) |> + pull() |> + writeLines("tools/missing_functions.Rmd") diff --git a/tools/missing_functions.Rmd b/tools/missing_functions.Rmd new file mode 100644 index 00000000..acfb6a89 --- /dev/null +++ b/tools/missing_functions.Rmd @@ -0,0 +1,933 @@ +# dbi_generics (1) + +`r d(DBItest:::dbi_generics)` + +```r +function(version) { + version <- as.package_version(version) + + generics <- all_dbi_generics() + + if (version < "1.7.99.1") { + generics <- setdiff(generics, c( + "dbGetQueryArrow", + "dbAppendTableArrow", + "dbFetchArrow", + "dbFetchArrowChunk", + "dbWriteTableArrow", + "dbSendQueryArrow", + "dbReadTableArrow", + "dbCreateTableArrow" + )) + } + + if (version < "1.7.99.11") { + generics <- setdiff(generics, c( + "dbBindArrow", + NULL + )) + } + + generics +} + +``` + +# expect_all_args_have_default_values (1) + +`r d(DBItest:::expect_all_args_have_default_values)` + +```r +function(object) { + act <- quasi_label(enquo(object), arg = "object") + act$args <- formals(act$val) + act$args <- act$args[names(act$args) != "..."] + act$char_args <- purrr::map_chr(act$args, as.character) + expect( + all(nzchar(act$char_args, keepNA = FALSE)), + sprintf("%s has arguments without default values", act$lab) + ) + + invisible(act$val) +} + +``` + +# expect_arglist_is_empty (1) + +`r d(DBItest:::expect_arglist_is_empty)` + +```r +function(object) { + act <- quasi_label(enquo(object), arg = "object") + act$formals <- formals(act$val) + expect( + is.null(act$formals), + sprintf("%s has an empty argument list.", act$lab) + ) + + invisible(act$val) +} + +``` + +# expect_has_class_method (1) + +`r d(DBItest:::expect_has_class_method)` + +```r +function(name, class, args, driver_package) { + full_args <- c(class, args) + eval(bquote( + expect_true(hasMethod(.(name), signature = .(full_args), asNamespace(.(driver_package)))) + )) +} + +``` + +# get_key_methods (1) + +`r d(DBItest:::get_key_methods)` + +```r +function() { + list( + Driver = list( + "dbConnect" = NULL, + "dbDataType" = NULL + ), + Connection = list( + "dbDisconnect" = NULL, + "dbGetInfo" = NULL, + "dbSendQuery" = "character", + "dbListFields" = "character", + "dbListTables" = NULL, + "dbReadTable" = "character", + "dbWriteTable" = c("character", "data.frame"), + "dbExistsTable" = "character", + "dbRemoveTable" = "character", + "dbBegin" = NULL, + "dbCommit" = NULL, + "dbRollback" = NULL, + "dbIsValid" = NULL, + "dbQuoteString" = "character", + "dbQuoteIdentifier" = "character" + ), + Result = list( + "dbIsValid" = NULL, + "dbFetch" = NULL, + "dbClearResult" = NULL, + "dbColumnInfo" = NULL, + "dbGetRowsAffected" = NULL, + "dbGetRowCount" = NULL, + "dbHasCompleted" = NULL, + "dbGetStatement" = NULL, + "dbBind" = NULL + ) + ) +} + +``` + +# get_pkg_path (1) + +`r d(DBItest:::get_pkg_path)` + +```r +function(ctx) { + pkg_name <- package_name(ctx) + expect_type(pkg_name, "character") + + pkg_path <- find.package(pkg_name) + pkg_path +} + +``` + +# s4_methods (1) + +`r d(DBItest:::s4_methods)` + +```r +function(env, pkg_fun = NULL) { + generics <- methods::getGenerics(env) + + if (is.null(pkg_fun)) { + ok <- TRUE + } else { + ok <- pkg_fun(generics@package) + } + + + res <- Map( + generics@.Data[ok], generics@package[ok], + USE.NAMES = TRUE, + f = function(name, package) { + what <- methods::methodsPackageMetaName("T", paste(name, package, sep = ":")) + + table <- get(what, envir = env) + + mget(ls(table, all.names = TRUE), envir = table) + } + ) + unlist(res, recursive = FALSE) +} + +``` + +# test_select (1) + +`r d(DBItest:::test_select)` + +```r +function( + con, + ..., + .add_null = "none", + .ctx, + .envir = parent.frame() +) { + + values <- list2(...) + + value_is_formula <- purrr::map_lgl(values, is.call) + names(values)[value_is_formula] <- purrr::map(values[value_is_formula], "[[", 2L) + values[value_is_formula] <- purrr::map( + values[value_is_formula], + function(x) { + eval(x[[3]], envir = .envir) + } + ) + + if (is.null(names(values))) { + sql_values <- purrr::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_names <- letters[seq_along(sql_values)] + + query <- paste( + "SELECT", + paste(sql_values, "as", sql_names, collapse = ", ") + ) + if (.add_null != "none") { + query_null <- paste( + "SELECT", + paste("NULL as", sql_names, collapse = ", ") + ) + query <- c(query, query_null) + if (.add_null == "above") { + query <- rev(query) + } + query <- paste0(query, ", ", 1:2, " as id") + query <- sql_union(.ctx = .ctx, query) + } + + rows <- check_df(dbGetQuery(con, query)) + + if (.add_null != "none") { + rows <- rows[order(rows$id), -(length(sql_names) + 1L), drop = FALSE] + if (.add_null == "above") { + rows <- rows[2:1, , drop = FALSE] + } + } + + expect_named(rows, sql_names) + + for (i in seq_along(values)) { + value_or_testfun <- values[[i]] + if (is.function(value_or_testfun)) { + eval(bquote(expect_true(value_or_testfun(rows[1L, .(i)])))) + } else { + eval(bquote(expect_identical(rows[1L, .(i)], .(value_or_testfun)))) + } + } + + if (.add_null != "none") { + expect_equal(nrow(rows), 2L) + if (is.list(rows[[1L]])) { + expect_null(rows[2L, 1L][[1L]]) + } else { + expect_true(is.na(rows[2L, 1L])) + } + } else { + expect_equal(nrow(rows), 1L) + } +} + +``` + +# test_data_type (2) + +`r d(DBItest:::test_data_type)` + +```r +function(ctx, dbObj) { + #' @return + #' `dbDataType()` returns the SQL type that corresponds to the `obj` argument + check_data_type <- function(value) { + eval(bquote({ + #' as a non-empty + expect_match(dbDataType(dbObj, .(value)), ".") + #' character string. + if (is.data.frame(value)) { + #' For data frames, a character vector with one element per column + #' is returned. + expect_length(dbDataType(dbObj, value), .(ncol(value))) + } else { + expect_length(dbDataType(dbObj, .(value)), 1L) + } + expect_type(dbDataType(dbObj, .(value)), "character") + expect_visible(dbDataType(dbObj, .(value))) + })) + } + + #' + #' @section Failure modes: + #' An error is raised for invalid values for the `obj` argument such as a + #' `NULL` value. + expect_error(dbDataType(dbObj, NULL)) + + #' @section Specification: + #' The backend can override the [dbDataType()] generic + #' for its driver class. + #' + #' This generic expects an arbitrary object as second argument. + #' To query the values returned by the default implementation, + #' run `example(dbDataType, package = "DBI")`. + #' If the backend needs to override this generic, + #' it must accept all basic R data types as its second argument, namely + expect_has_data_type <- function(value) { + eval(bquote( + expect_error(check_data_type(.(value)), NA) + )) + } + + expected_data_types <- list( + #' [logical], + logical(1), + #' [integer], + integer(1), + #' [numeric], + numeric(1), + #' [character], + character(1), + #' dates (see [Dates]), + Sys.Date(), + #' date-time (see [DateTimeClasses]), + Sys.time(), + #' and [difftime]. + Sys.time() - Sys.time(), + #' If the database supports blobs, + if (!isTRUE(ctx$tweaks$omit_blob_tests)) { + #' this method also must accept lists of [raw] vectors, + list(as.raw(0:10)) + }, + if (!isTRUE(ctx$tweaks$omit_blob_tests)) { + #' and [blob::blob] objects. + blob::blob(as.raw(0:10)) + } + ) + + purrr::map( + compact(expected_data_types), + expect_has_data_type + ) + + expect_has_data_type(data.frame(a = 1, b = "2", stringsAsFactors = FALSE)) + + #' As-is objects (i.e., wrapped by [I()]) must be + #' supported and return the same results as their unwrapped counterparts. + purrr::map( + compact(expected_data_types), + function(value) { + if (!is.null(value)) { + eval(bquote( + expect_error( + expect_identical( + dbDataType(dbObj, I(.(value))), + dbDataType(dbObj, .(value)) + ), + NA + ) + )) + } + } + ) + + #' The SQL data type for [factor] and + expect_identical( + dbDataType(dbObj, letters), + dbDataType(dbObj, factor(letters)) + ) + #' [ordered] is the same as for character. + expect_identical( + dbDataType(dbObj, letters), + dbDataType(dbObj, ordered(letters)) + ) + + #' The behavior for other object types is not specified. +} + +``` + +# try_silent (2) + +`r d(DBItest:::try_silent)` + +```r +function(code) { + tryCatch( + code, + error = function(e) NULL + ) +} + +``` + +# local_closed_connection (3) + +`r d(DBItest:::local_closed_connection)` + +```r +function(ctx, ...) { + con <- connect(ctx, ...) + dbDisconnect(con) + con +} + +``` + +# local_invalid_connection (3) + +`r d(DBItest:::local_invalid_connection)` + +```r +function(ctx, ...) { + con <- connect(ctx, ...) + dbDisconnect(con) + unserialize(serialize(con, NULL)) +} + +``` + +# test_arrow_roundtrip_one (4) + +`r d(DBItest:::test_arrow_roundtrip_one)` + +```r +function(con, tbl_in, tbl_expected = tbl_in, transform = identity, + name = NULL, use_append = FALSE, .add_na = "none") { + # Need data frames here because streams can be collected only once + stopifnot(is.data.frame(tbl_in), is.data.frame(tbl_expected)) + + force(tbl_expected) + if (.add_na == "above") { + tbl_in <- stream_add_na_above(tbl_in) + tbl_expected <- stream_add_na_above(tbl_expected) + } else if (.add_na == "below") { + tbl_in <- stream_add_na_below(tbl_in) + tbl_expected <- stream_add_na_below(tbl_expected) + } + + if (is.null(name)) { + name <- random_table_name() + } + + local_remove_test_table(con, name = name) + + if (use_append) { + dbCreateTableArrow(con, name, tbl_in %>% stream_frame()) + dbAppendTableArrow(con, name, tbl_in %>% stream_frame()) + } else { + dbWriteTableArrow(con, name, tbl_in %>% stream_frame()) + } + + stream <- dbReadTableArrow(con, name) + tbl_out <- check_arrow(stream, transform) + expect_equal_df(tbl_out, tbl_expected) +} + +``` + +# test_table_roundtrip_one (4) + +`r d(DBItest:::test_table_roundtrip_one)` + +```r +function( + con, + tbl_in, + tbl_expected = tbl_in, + transform = identity, + name = NULL, + field.types = NULL, + use_append = FALSE, + .add_na = "none" +) { + force(tbl_expected) + if (.add_na == "above") { + tbl_in <- add_na_above(tbl_in) + tbl_expected <- add_na_above(tbl_expected) + } else if (.add_na == "below") { + tbl_in <- add_na_below(tbl_in) + tbl_expected <- add_na_below(tbl_expected) + } + + if (is.null(name)) { + name <- random_table_name() + } + + local_remove_test_table(con, name = name) + + if (use_append) { + dbCreateTable(con, name, field.types %||% tbl_in) + dbAppendTable(con, name, tbl_in) + } else { + dbWriteTable(con, name, tbl_in, field.types = field.types) + } + + tbl_read <- check_df(dbReadTable(con, name, check.names = FALSE)) + tbl_out <- transform(tbl_read) + expect_equal_df(tbl_out, tbl_expected) +} + +``` + +# trivial_values (4) + +`r d(DBItest:::trivial_values)` + +```r +function(n = 1L) { + seq_len(n) + 0.5 +} + +``` + +# package_name (5) + +`r d(DBItest:::package_name)` + +```r +function(ctx) { + attr(class(ctx$drv), "package") +} + +``` + +# sql_union (6) + +`r d(DBItest:::sql_union)` + +```r +function(..., .order_by = NULL, .ctx) { + queries <- c(...) + if (length(queries) == 1) { + query <- queries + } else { + stopifnot(!is.null(.ctx)) + query <- .ctx$tweaks$union(queries) + } + + if (!is.null(.order_by)) { + query <- paste0(query, " ORDER BY ", .order_by) + } + query +} + +``` + +# as_numeric_date (8) + +`r d(DBItest:::as_numeric_date)` + +```r +function(d) { + d <- as.Date(d) + structure(as.numeric(unclass(d)), class = class(d)) +} + +``` + +# connect (8) + +`r d(DBItest:::connect)` + +```r +function(ctx, ...) { + quos <- enquos(...) + eval_tidy(quo(dbConnect(ctx$cnr, !!!quos))) +} + +``` + +# expect_equal_arrow (8) + +`r d(DBItest:::expect_equal_arrow)` + +```r +function(actual, expected) { + expect_equal_df(as.data.frame(actual), as.data.frame(expected)) +} + +``` + +# trivial_statement (10) + +`r d(DBItest:::trivial_statement)` + +```r +function(ctx, table_name) { + ctx$tweaks$create_table_as(table_name) +} + +``` + +# get_texts (13) + +`r d(DBItest:::get_texts)` + +```r +function() { + c(text_cyrillic, text_latin, text_latin_encoded, text_chinese, text_ascii) +} + +``` + +# local_connection (13) + +`r d(DBItest:::local_connection)` + +```r +function(ctx, ..., .local_envir = parent.frame()) { + con <- connect(ctx, ...) + withr::local_db_connection(con, .local_envir = .local_envir) +} + +``` + +# unrowname (13) + +`r d(DBItest:::unrowname)` + +```r +function(x) { + rownames(x) <- NULL + x +} + +``` + +# expect_invisible_true (14) + +`r d(DBItest:::expect_invisible_true)` + +```r +function(code) { + ret <- withVisible(code) + expect_true(ret$value) + expect_false(ret$visible) + + invisible(ret$value) +} + +``` + +# check_arrow (18) + +`r d(DBItest:::check_arrow)` + +```r +function(stream, transform = identity) { + to <- function(schema, ptype) transform(ptype) + if (inherits(stream, "nanoarrow_array_stream")) { + on.exit(stream$release()) + df <- nanoarrow::convert_array_stream(stream, to) + } else if (inherits(stream, "nanoarrow_array")) { + df <- nanoarrow::convert_array(stream, to) + } else { + stop("Unexpected conversion of type ", class(stream), ".", call. = FALSE) + } + + check_df(df) +} + +``` + +# random_table_name (18) + +`r d(DBItest:::random_table_name)` + +```r +function(n = 10) { + # FIXME: Use parallel-safe sequence of numbers + paste0("dbit", paste(sample(letters, n, replace = TRUE), collapse = "")) +} + +``` + +# local_remove_test_table (31) + +`r d(DBItest:::local_remove_test_table)` + +```r +function(con, name, frame = caller_env()) { + table_name <- dbQuoteIdentifier(con, name) + withr::defer( + try_silent( + dbRemoveTable(con, table_name) + ), + envir = frame + ) +} + +``` + +# get_penguins (40) + +`r d(DBItest:::get_penguins)` + +```r +function(ctx) { + datasets_penguins <- unrowname(palmerpenguins::penguins[c(1, 153, 277), ]) + # FIXME: better handling of DBI backends that do support factors + datasets_penguins$species <- as.character(datasets_penguins$species) + datasets_penguins$island <- as.character(datasets_penguins$island) + datasets_penguins$sex <- as.character(datasets_penguins$sex) + as.data.frame(datasets_penguins) +} + +``` + +# test_arrow_roundtrip (40) + +`r d(DBItest:::test_arrow_roundtrip)` + +```r +function(...) { + test_arrow_roundtrip_one(..., .add_na = "none") + test_arrow_roundtrip_one(..., .add_na = "above") + test_arrow_roundtrip_one(..., .add_na = "below") +} + +``` + +# stream_frame (42) + +`r d(DBItest:::stream_frame)` + +```r +function(..., .select = NULL) { + data <- data.frame(..., stringsAsFactors = FALSE, check.names = FALSE) + as_is <- purrr::map_lgl(data, inherits, "AsIs") + data[as_is] <- purrr::map(data[as_is], function(.x) { + class(.x) <- setdiff(class(.x), "AsIs") + .x + }) + + if (!is.null(.select)) { + data <- data[.select] + } + + out <- nanoarrow::as_nanoarrow_array_stream(data) + + out +} + +``` + +# local_result (46) + +`r d(DBItest:::local_result)` + +```r +function(query, frame = caller_env()) { + res <- query + withr::defer( # nolint next: unnecessary_nesting_linter. The braces ensure the srcref. + { + dbClearResult(res) + }, + envir = frame + ) + res +} + +``` + +# test_table_roundtrip (47) + +`r d(DBItest:::test_table_roundtrip)` + +```r +function(...) { + test_table_roundtrip_one(..., .add_na = "none") + test_table_roundtrip_one(..., .add_na = "above") + test_table_roundtrip_one(..., .add_na = "below") +} + +``` + +# trivial_df (71) + +`r d(DBItest:::trivial_df)` + +```r +function(n = 1L, column = "a") { + values <- trivial_values(n) + if (length(column) == 1) { + df <- data.frame(a = values) + } else { + df <- as.data.frame(as.list(values)) + } + names(df) <- column + df +} + +``` + +# skip_if_not_dbitest (72) + +`r d(DBItest:::skip_if_not_dbitest)` + +```r +function(ctx, version) { + if (as.package_version(ctx$tweaks$dbitest_version) < version) { + skip(paste0("tweak: dbitest_version: required: ", version, ", available: ", ctx$tweaks$dbitest_version)) + } +} + +``` + +# trivial_query (73) + +`r d(DBItest:::trivial_query)` + +```r +function(n = 1L, column = "a", .order_by = NULL, .ctx = NULL) { + # Zero-row queries are hard-coded, search for 1 = 0 + stopifnot(n > 0) + value <- trivial_values(n) + if (length(column) == n) { + query <- paste0("SELECT ", paste0(value, " AS ", column, collapse = ", ")) + } else { + query <- sql_union( + paste0("SELECT ", value, " AS ", column), + .order_by = .order_by, + .ctx = .ctx + ) + } + + query +} + +``` + +# expect_equal_df (86) + +`r d(DBItest:::expect_equal_df)` + +```r +function(actual, expected) { + factor_cols <- purrr::map_lgl(expected, is.factor) + expected[factor_cols] <- purrr::map(expected[factor_cols], as.character) + + asis_cols <- purrr::map_lgl(expected, inherits, "AsIs") + expected[asis_cols] <- purrr::map(expected[asis_cols], unclass) + + list_cols <- purrr::map_lgl(expected, is.list) + + if (any(list_cols)) { + expect_false(all(list_cols)) + expect_equal(anyDuplicated(actual[!list_cols]), 0) + expect_equal(anyDuplicated(expected[!list_cols]), 0) + order_actual <- do.call(order, actual[!list_cols]) + order_expected <- do.call(order, expected[!list_cols]) + } else { + order_actual <- do.call(order, actual) + order_expected <- do.call(order, expected) + } + + has_rownames_actual <- is.character(attr(actual, "row.names")) + has_rownames_expected <- is.character(attr(expected, "row.names")) + expect_equal(has_rownames_actual, has_rownames_expected) + + if (has_rownames_actual) { + expect_equal(sort(row.names(actual)), sort(row.names(expected))) + } + + actual <- unrowname(actual[order_actual, ]) + expected <- unrowname(expected[order_expected, ]) + + expect_identical(actual, expected) +} + +``` + +# get_placeholder_funs (128) + +`r d(DBItest:::get_placeholder_funs)` + +```r +function(ctx, requires_names = NULL) { + placeholder_fun <- ctx$tweaks$placeholder_pattern + if (is.character(placeholder_fun)) { + placeholder_funs <- purrr::map(placeholder_fun, make_placeholder_fun) + } else if (is.function(placeholder_fun)) { + placeholder_funs <- list(placeholder_fun) + } else { + placeholder_funs <- placeholder_fun + } + + if (length(placeholder_funs) == 0) { + skip("Use the placeholder_pattern tweak, or skip all 'bind_.*' tests") + } + + if (!is.null(requires_names)) { + placeholder_fun_values <- purrr::map(placeholder_funs, ~ .x(1)) + placeholder_unnamed <- purrr::map_lgl(placeholder_fun_values, ~ is.null(names(.x))) + + # run_bind_tester$fun() + if (isTRUE(requires_names)) { + placeholder_funs <- placeholder_funs[!placeholder_unnamed] + } + + if (isFALSE(requires_names)) { + placeholder_funs <- placeholder_funs[placeholder_unnamed] + } + } + + placeholder_funs +} + +``` + +# check_df (214) + +`r d(DBItest:::check_df)` + +```r +function(df) { + expect_s3_class(df, "data.frame") + if (length(df) >= 1L) { + lengths <- unname(lengths(df)) + expect_equal(diff(lengths), rep(0L, length(lengths) - 1L)) + expect_equal(nrow(df), lengths[[1]]) + } + + df_names <- names(df) + expect_true(all(df_names != "")) + expect_false(anyNA(df_names)) + + df +} + +``` From a0a746a93e19a369549989c8fe711ec98af30dc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Sat, 3 May 2025 08:13:50 +0200 Subject: [PATCH 6/8] test_select_with_null --- tools/internal.R | 2 +- tools/missing_functions.Rmd | 41 ++++++++++++++++++++++++------------- 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/tools/internal.R b/tools/internal.R index 9f0dbb4c..fcba5233 100644 --- a/tools/internal.R +++ b/tools/internal.R @@ -17,7 +17,7 @@ walk_ast <- function( if (is.symbol(fn)) { fn_name <- as.character(fn) - if (fn_name %in% c("bquote", "$", "@", "test_select_with_null")) { + if (fn_name %in% c("bquote", "$", "@")) { # Do nothing for NSE return() } diff --git a/tools/missing_functions.Rmd b/tools/missing_functions.Rmd index acfb6a89..31493389 100644 --- a/tools/missing_functions.Rmd +++ b/tools/missing_functions.Rmd @@ -379,20 +379,6 @@ function(ctx, dbObj) { ``` -# try_silent (2) - -`r d(DBItest:::try_silent)` - -```r -function(code) { - tryCatch( - code, - error = function(e) NULL - ) -} - -``` - # local_closed_connection (3) `r d(DBItest:::local_closed_connection)` @@ -419,6 +405,20 @@ function(ctx, ...) { ``` +# try_silent (3) + +`r d(DBItest:::try_silent)` + +```r +function(code) { + tryCatch( + code, + error = function(e) NULL + ) +} + +``` + # test_arrow_roundtrip_one (4) `r d(DBItest:::test_arrow_roundtrip_one)` @@ -642,6 +642,19 @@ function(code) { ``` +# test_select_with_null (17) + +`r d(DBItest:::test_select_with_null)` + +```r +function(...) { + test_select(..., .add_null = "none") + test_select(..., .add_null = "above") + test_select(..., .add_null = "below") +} + +``` + # check_arrow (18) `r d(DBItest:::check_arrow)` From 4e33c0b5dccec032a70fc45bcc4dc602fd2d9b7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Sat, 3 May 2025 09:33:22 +0200 Subject: [PATCH 7/8] Classify --- tools/missing_functions.Rmd | 963 +++++++++++++++++++----------------- 1 file changed, 496 insertions(+), 467 deletions(-) diff --git a/tools/missing_functions.Rmd b/tools/missing_functions.Rmd index 31493389..b5d22b8d 100644 --- a/tools/missing_functions.Rmd +++ b/tools/missing_functions.Rmd @@ -1,135 +1,153 @@ -# dbi_generics (1) +# Check first -`r d(DBItest:::dbi_generics)` +## as_numeric_date (8): obsolete? + +`r d(DBItest:::as_numeric_date)` ```r -function(version) { - version <- as.package_version(version) +function(d) { + d <- as.Date(d) + structure(as.numeric(unclass(d)), class = class(d)) +} + +``` - generics <- all_dbi_generics() +## connect (8): inline? What about helper functions? - if (version < "1.7.99.1") { - generics <- setdiff(generics, c( - "dbGetQueryArrow", - "dbAppendTableArrow", - "dbFetchArrow", - "dbFetchArrowChunk", - "dbWriteTableArrow", - "dbSendQueryArrow", - "dbReadTableArrow", - "dbCreateTableArrow" - )) - } +`r d(DBItest:::connect)` - if (version < "1.7.99.11") { - generics <- setdiff(generics, c( - "dbBindArrow", - NULL - )) - } +```r +function(ctx, ...) { + quos <- enquos(...) + eval_tidy(quo(dbConnect(ctx$cnr, !!!quos))) +} + +``` - generics +## get_penguins (40): inline dynamically, with factor support? Look at duckdb skips + +`r d(DBItest:::get_penguins)` + +```r +function(ctx) { + datasets_penguins <- unrowname(palmerpenguins::penguins[c(1, 153, 277), ]) + # FIXME: better handling of DBI backends that do support factors + datasets_penguins$species <- as.character(datasets_penguins$species) + datasets_penguins$island <- as.character(datasets_penguins$island) + datasets_penguins$sex <- as.character(datasets_penguins$sex) + as.data.frame(datasets_penguins) } ``` -# expect_all_args_have_default_values (1) +## local_remove_test_table (31): inline try_silent, then inline dynamically or closure -`r d(DBItest:::expect_all_args_have_default_values)` +`r d(DBItest:::local_remove_test_table)` ```r -function(object) { - act <- quasi_label(enquo(object), arg = "object") - act$args <- formals(act$val) - act$args <- act$args[names(act$args) != "..."] - act$char_args <- purrr::map_chr(act$args, as.character) - expect( - all(nzchar(act$char_args, keepNA = FALSE)), - sprintf("%s has arguments without default values", act$lab) +function(con, name, frame = caller_env()) { + table_name <- dbQuoteIdentifier(con, name) + withr::defer( + try_silent( + dbRemoveTable(con, table_name) + ), + envir = frame ) - - invisible(act$val) } ``` -# expect_arglist_is_empty (1) -`r d(DBItest:::expect_arglist_is_empty)` + +## local_result (46): implement so that it's ready to be added to withr, export, inline + +`r d(DBItest:::local_result)` ```r -function(object) { - act <- quasi_label(enquo(object), arg = "object") - act$formals <- formals(act$val) - expect( - is.null(act$formals), - sprintf("%s has an empty argument list.", act$lab) +function(query, frame = caller_env()) { + res <- query + withr::defer( # nolint next: unnecessary_nesting_linter. The braces ensure the srcref. + { + dbClearResult(res) + }, + envir = frame ) + res +} + +``` - invisible(act$val) +## expect_equal_arrow (8): linked to expect_equal_df + +`r d(DBItest:::expect_equal_arrow)` + +```r +function(actual, expected) { + expect_equal_df(as.data.frame(actual), as.data.frame(expected)) } ``` -# expect_has_class_method (1) +## expect_equal_df (86): check and understand behavior carefully, decide -`r d(DBItest:::expect_has_class_method)` +`r d(DBItest:::expect_equal_df)` ```r -function(name, class, args, driver_package) { - full_args <- c(class, args) - eval(bquote( - expect_true(hasMethod(.(name), signature = .(full_args), asNamespace(.(driver_package)))) - )) +function(actual, expected) { + factor_cols <- purrr::map_lgl(expected, is.factor) + expected[factor_cols] <- purrr::map(expected[factor_cols], as.character) + + asis_cols <- purrr::map_lgl(expected, inherits, "AsIs") + expected[asis_cols] <- purrr::map(expected[asis_cols], unclass) + + list_cols <- purrr::map_lgl(expected, is.list) + + if (any(list_cols)) { + expect_false(all(list_cols)) + expect_equal(anyDuplicated(actual[!list_cols]), 0) + expect_equal(anyDuplicated(expected[!list_cols]), 0) + order_actual <- do.call(order, actual[!list_cols]) + order_expected <- do.call(order, expected[!list_cols]) + } else { + order_actual <- do.call(order, actual) + order_expected <- do.call(order, expected) + } + + has_rownames_actual <- is.character(attr(actual, "row.names")) + has_rownames_expected <- is.character(attr(expected, "row.names")) + expect_equal(has_rownames_actual, has_rownames_expected) + + if (has_rownames_actual) { + expect_equal(sort(row.names(actual)), sort(row.names(expected))) + } + + actual <- unrowname(actual[order_actual, ]) + expected <- unrowname(expected[order_expected, ]) + + expect_identical(actual, expected) } ``` -# get_key_methods (1) -`r d(DBItest:::get_key_methods)` + +# Inline + +## expect_has_class_method (1): inline + +`r d(DBItest:::expect_has_class_method)` ```r -function() { - list( - Driver = list( - "dbConnect" = NULL, - "dbDataType" = NULL - ), - Connection = list( - "dbDisconnect" = NULL, - "dbGetInfo" = NULL, - "dbSendQuery" = "character", - "dbListFields" = "character", - "dbListTables" = NULL, - "dbReadTable" = "character", - "dbWriteTable" = c("character", "data.frame"), - "dbExistsTable" = "character", - "dbRemoveTable" = "character", - "dbBegin" = NULL, - "dbCommit" = NULL, - "dbRollback" = NULL, - "dbIsValid" = NULL, - "dbQuoteString" = "character", - "dbQuoteIdentifier" = "character" - ), - Result = list( - "dbIsValid" = NULL, - "dbFetch" = NULL, - "dbClearResult" = NULL, - "dbColumnInfo" = NULL, - "dbGetRowsAffected" = NULL, - "dbGetRowCount" = NULL, - "dbHasCompleted" = NULL, - "dbGetStatement" = NULL, - "dbBind" = NULL - ) - ) +function(name, class, args, driver_package) { + full_args <- c(class, args) + eval(bquote( + expect_true(hasMethod(.(name), signature = .(full_args), asNamespace(.(driver_package)))) + )) } ``` -# get_pkg_path (1) +## get_pkg_path (1): inline `r d(DBItest:::get_pkg_path)` @@ -144,8 +162,8 @@ function(ctx) { ``` -# s4_methods (1) - +## s4_methods (1): inline +: in `r d(DBItest:::s4_methods)` ```r @@ -175,97 +193,168 @@ function(env, pkg_fun = NULL) { ``` -# test_select (1) +## try_silent (3): inline -`r d(DBItest:::test_select)` +`r d(DBItest:::try_silent)` ```r -function( - con, - ..., - .add_null = "none", - .ctx, - .envir = parent.frame() -) { +function(code) { + tryCatch( + code, + error = function(e) NULL + ) +} + +``` - values <- list2(...) +## trivial_statement (10): inline, simple forward to tweak - value_is_formula <- purrr::map_lgl(values, is.call) - names(values)[value_is_formula] <- purrr::map(values[value_is_formula], "[[", 2L) - values[value_is_formula] <- purrr::map( - values[value_is_formula], - function(x) { - eval(x[[3]], envir = .envir) - } - ) +`r d(DBItest:::trivial_statement)` - if (is.null(names(values))) { - sql_values <- purrr::map(values, as.character) - } else { - sql_values <- names(values) +```r +function(ctx, table_name) { + ctx$tweaks$create_table_as(table_name) +} + +``` + + +# Inline carefully + +## dbi_generics (1): inline + +`r d(DBItest:::dbi_generics)` + +```r +function(version) { + version <- as.package_version(version) + + generics <- all_dbi_generics() + + if (version < "1.7.99.1") { + generics <- setdiff(generics, c( + "dbGetQueryArrow", + "dbAppendTableArrow", + "dbFetchArrow", + "dbFetchArrowChunk", + "dbWriteTableArrow", + "dbSendQueryArrow", + "dbReadTableArrow", + "dbCreateTableArrow" + )) } - if (isTRUE(.ctx$tweaks$current_needs_parens)) { - sql_values <- gsub( - "^(current_(?:date|time|timestamp))$", "\\1()", - sql_values - ) + if (version < "1.7.99.11") { + generics <- setdiff(generics, c( + "dbBindArrow", + NULL + )) } - sql_names <- letters[seq_along(sql_values)] + generics +} + +``` - query <- paste( - "SELECT", - paste(sql_values, "as", sql_names, collapse = ", ") - ) - if (.add_null != "none") { - query_null <- paste( - "SELECT", - paste("NULL as", sql_names, collapse = ", ") +## get_key_methods (1): sync with dbi_generics + +`r d(DBItest:::get_key_methods)` + +```r +function() { + list( + Driver = list( + "dbConnect" = NULL, + "dbDataType" = NULL + ), + Connection = list( + "dbDisconnect" = NULL, + "dbGetInfo" = NULL, + "dbSendQuery" = "character", + "dbListFields" = "character", + "dbListTables" = NULL, + "dbReadTable" = "character", + "dbWriteTable" = c("character", "data.frame"), + "dbExistsTable" = "character", + "dbRemoveTable" = "character", + "dbBegin" = NULL, + "dbCommit" = NULL, + "dbRollback" = NULL, + "dbIsValid" = NULL, + "dbQuoteString" = "character", + "dbQuoteIdentifier" = "character" + ), + Result = list( + "dbIsValid" = NULL, + "dbFetch" = NULL, + "dbClearResult" = NULL, + "dbColumnInfo" = NULL, + "dbGetRowsAffected" = NULL, + "dbGetRowCount" = NULL, + "dbHasCompleted" = NULL, + "dbGetStatement" = NULL, + "dbBind" = NULL ) - query <- c(query, query_null) - if (.add_null == "above") { - query <- rev(query) - } - query <- paste0(query, ", ", 1:2, " as id") - query <- sql_union(.ctx = .ctx, query) - } + ) +} + +``` - rows <- check_df(dbGetQuery(con, query)) +## expect_all_args_have_default_values (1): inline - if (.add_null != "none") { - rows <- rows[order(rows$id), -(length(sql_names) + 1L), drop = FALSE] - if (.add_null == "above") { - rows <- rows[2:1, , drop = FALSE] - } - } +`r d(DBItest:::expect_all_args_have_default_values)` - expect_named(rows, sql_names) +```r +function(object) { + act <- quasi_label(enquo(object), arg = "object") + act$args <- formals(act$val) + act$args <- act$args[names(act$args) != "..."] + act$char_args <- purrr::map_chr(act$args, as.character) + expect( + all(nzchar(act$char_args, keepNA = FALSE)), + sprintf("%s has arguments without default values", act$lab) + ) - for (i in seq_along(values)) { - value_or_testfun <- values[[i]] - if (is.function(value_or_testfun)) { - eval(bquote(expect_true(value_or_testfun(rows[1L, .(i)])))) - } else { - eval(bquote(expect_identical(rows[1L, .(i)], .(value_or_testfun)))) - } - } + invisible(act$val) +} + +``` + +## expect_arglist_is_empty (1): inline, same as expect_all_args_have_default_values + +`r d(DBItest:::expect_arglist_is_empty)` + +```r +function(object) { + act <- quasi_label(enquo(object), arg = "object") + act$formals <- formals(act$val) + expect( + is.null(act$formals), + sprintf("%s has an empty argument list.", act$lab) + ) + + invisible(act$val) +} + +``` + +## local_connection (13): inline, after inlining connect - if (.add_null != "none") { - expect_equal(nrow(rows), 2L) - if (is.list(rows[[1L]])) { - expect_null(rows[2L, 1L][[1L]]) - } else { - expect_true(is.na(rows[2L, 1L])) - } - } else { - expect_equal(nrow(rows), 1L) - } +`r d(DBItest:::local_connection)` + +```r +function(ctx, ..., .local_envir = parent.frame()) { + con <- connect(ctx, ...) + withr::local_db_connection(con, .local_envir = .local_envir) } ``` -# test_data_type (2) + + +# Difficult + +## test_data_type (2): difficult inline exercise, leading to non-DRY spec, or difficult dynamic inline. Split? `r d(DBItest:::test_data_type)` @@ -379,243 +468,166 @@ function(ctx, dbObj) { ``` -# local_closed_connection (3) - -`r d(DBItest:::local_closed_connection)` - -```r -function(ctx, ...) { - con <- connect(ctx, ...) - dbDisconnect(con) - con -} - -``` - -# local_invalid_connection (3) +## test_select (1): dynamic inline, difficult -`r d(DBItest:::local_invalid_connection)` +`r d(DBItest:::test_select)` ```r -function(ctx, ...) { - con <- connect(ctx, ...) - dbDisconnect(con) - unserialize(serialize(con, NULL)) -} - -``` - -# try_silent (3) +function( + con, + ..., + .add_null = "none", + .ctx, + .envir = parent.frame() +) { -`r d(DBItest:::try_silent)` + values <- list2(...) -```r -function(code) { - tryCatch( - code, - error = function(e) NULL + value_is_formula <- purrr::map_lgl(values, is.call) + names(values)[value_is_formula] <- purrr::map(values[value_is_formula], "[[", 2L) + values[value_is_formula] <- purrr::map( + values[value_is_formula], + function(x) { + eval(x[[3]], envir = .envir) + } ) -} - -``` - -# test_arrow_roundtrip_one (4) - -`r d(DBItest:::test_arrow_roundtrip_one)` - -```r -function(con, tbl_in, tbl_expected = tbl_in, transform = identity, - name = NULL, use_append = FALSE, .add_na = "none") { - # Need data frames here because streams can be collected only once - stopifnot(is.data.frame(tbl_in), is.data.frame(tbl_expected)) - force(tbl_expected) - if (.add_na == "above") { - tbl_in <- stream_add_na_above(tbl_in) - tbl_expected <- stream_add_na_above(tbl_expected) - } else if (.add_na == "below") { - tbl_in <- stream_add_na_below(tbl_in) - tbl_expected <- stream_add_na_below(tbl_expected) + if (is.null(names(values))) { + sql_values <- purrr::map(values, as.character) + } else { + sql_values <- names(values) } - if (is.null(name)) { - name <- random_table_name() + if (isTRUE(.ctx$tweaks$current_needs_parens)) { + sql_values <- gsub( + "^(current_(?:date|time|timestamp))$", "\\1()", + sql_values + ) } - local_remove_test_table(con, name = name) + sql_names <- letters[seq_along(sql_values)] - if (use_append) { - dbCreateTableArrow(con, name, tbl_in %>% stream_frame()) - dbAppendTableArrow(con, name, tbl_in %>% stream_frame()) - } else { - dbWriteTableArrow(con, name, tbl_in %>% stream_frame()) + query <- paste( + "SELECT", + paste(sql_values, "as", sql_names, collapse = ", ") + ) + if (.add_null != "none") { + query_null <- paste( + "SELECT", + paste("NULL as", sql_names, collapse = ", ") + ) + query <- c(query, query_null) + if (.add_null == "above") { + query <- rev(query) + } + query <- paste0(query, ", ", 1:2, " as id") + query <- sql_union(.ctx = .ctx, query) } - stream <- dbReadTableArrow(con, name) - tbl_out <- check_arrow(stream, transform) - expect_equal_df(tbl_out, tbl_expected) -} - -``` - -# test_table_roundtrip_one (4) - -`r d(DBItest:::test_table_roundtrip_one)` - -```r -function( - con, - tbl_in, - tbl_expected = tbl_in, - transform = identity, - name = NULL, - field.types = NULL, - use_append = FALSE, - .add_na = "none" -) { - force(tbl_expected) - if (.add_na == "above") { - tbl_in <- add_na_above(tbl_in) - tbl_expected <- add_na_above(tbl_expected) - } else if (.add_na == "below") { - tbl_in <- add_na_below(tbl_in) - tbl_expected <- add_na_below(tbl_expected) - } + rows <- check_df(dbGetQuery(con, query)) - if (is.null(name)) { - name <- random_table_name() + if (.add_null != "none") { + rows <- rows[order(rows$id), -(length(sql_names) + 1L), drop = FALSE] + if (.add_null == "above") { + rows <- rows[2:1, , drop = FALSE] + } } - local_remove_test_table(con, name = name) + expect_named(rows, sql_names) - if (use_append) { - dbCreateTable(con, name, field.types %||% tbl_in) - dbAppendTable(con, name, tbl_in) - } else { - dbWriteTable(con, name, tbl_in, field.types = field.types) + for (i in seq_along(values)) { + value_or_testfun <- values[[i]] + if (is.function(value_or_testfun)) { + eval(bquote(expect_true(value_or_testfun(rows[1L, .(i)])))) + } else { + eval(bquote(expect_identical(rows[1L, .(i)], .(value_or_testfun)))) + } } - tbl_read <- check_df(dbReadTable(con, name, check.names = FALSE)) - tbl_out <- transform(tbl_read) - expect_equal_df(tbl_out, tbl_expected) -} - -``` - -# trivial_values (4) - -`r d(DBItest:::trivial_values)` - -```r -function(n = 1L) { - seq_len(n) + 0.5 -} - -``` - -# package_name (5) - -`r d(DBItest:::package_name)` - -```r -function(ctx) { - attr(class(ctx$drv), "package") -} - -``` - -# sql_union (6) - -`r d(DBItest:::sql_union)` - -```r -function(..., .order_by = NULL, .ctx) { - queries <- c(...) - if (length(queries) == 1) { - query <- queries + if (.add_null != "none") { + expect_equal(nrow(rows), 2L) + if (is.list(rows[[1L]])) { + expect_null(rows[2L, 1L][[1L]]) + } else { + expect_true(is.na(rows[2L, 1L])) + } } else { - stopifnot(!is.null(.ctx)) - query <- .ctx$tweaks$union(queries) - } - - if (!is.null(.order_by)) { - query <- paste0(query, " ORDER BY ", .order_by) + expect_equal(nrow(rows), 1L) } - query } ``` -# as_numeric_date (8) +## test_select_with_null (17): dynamic second-order inline -`r d(DBItest:::as_numeric_date)` +`r d(DBItest:::test_select_with_null)` ```r -function(d) { - d <- as.Date(d) - structure(as.numeric(unclass(d)), class = class(d)) +function(...) { + test_select(..., .add_null = "none") + test_select(..., .add_null = "above") + test_select(..., .add_null = "below") } ``` -# connect (8) +## test_arrow_roundtrip (40) -`r d(DBItest:::connect)` +`r d(DBItest:::test_arrow_roundtrip)` ```r -function(ctx, ...) { - quos <- enquos(...) - eval_tidy(quo(dbConnect(ctx$cnr, !!!quos))) +function(...) { + test_arrow_roundtrip_one(..., .add_na = "none") + test_arrow_roundtrip_one(..., .add_na = "above") + test_arrow_roundtrip_one(..., .add_na = "below") } ``` -# expect_equal_arrow (8) +## test_table_roundtrip (47) -`r d(DBItest:::expect_equal_arrow)` +`r d(DBItest:::test_table_roundtrip)` ```r -function(actual, expected) { - expect_equal_df(as.data.frame(actual), as.data.frame(expected)) +function(...) { + test_table_roundtrip_one(..., .add_na = "none") + test_table_roundtrip_one(..., .add_na = "above") + test_table_roundtrip_one(..., .add_na = "below") } ``` -# trivial_statement (10) -`r d(DBItest:::trivial_statement)` -```r -function(ctx, table_name) { - ctx$tweaks$create_table_as(table_name) -} - -``` +# Closure or export -# get_texts (13) +## local_closed_connection (3): define as closure, after resolving connect() -`r d(DBItest:::get_texts)` +`r d(DBItest:::local_closed_connection)` ```r -function() { - c(text_cyrillic, text_latin, text_latin_encoded, text_chinese, text_ascii) +function(ctx, ...) { + con <- connect(ctx, ...) + dbDisconnect(con) + con } ``` -# local_connection (13) +## local_invalid_connection (3): define as closure, after resolving connect() -`r d(DBItest:::local_connection)` +`r d(DBItest:::local_invalid_connection)` ```r -function(ctx, ..., .local_envir = parent.frame()) { +function(ctx, ...) { con <- connect(ctx, ...) - withr::local_db_connection(con, .local_envir = .local_envir) + dbDisconnect(con) + unserialize(serialize(con, NULL)) } ``` -# unrowname (13) +## unrowname (13): closure `r d(DBItest:::unrowname)` @@ -627,7 +639,7 @@ function(x) { ``` -# expect_invisible_true (14) +## expect_invisible_true (14): closure `r d(DBItest:::expect_invisible_true)` @@ -642,99 +654,149 @@ function(code) { ``` -# test_select_with_null (17) -`r d(DBItest:::test_select_with_null)` +# Inline dynamically + +## trivial_values (4): inline dynamically, easiest + +`r d(DBItest:::trivial_values)` ```r -function(...) { - test_select(..., .add_null = "none") - test_select(..., .add_null = "above") - test_select(..., .add_null = "below") +function(n = 1L) { + seq_len(n) + 0.5 } ``` -# check_arrow (18) +## get_texts (13): inline dynamically, easiest -`r d(DBItest:::check_arrow)` +`r d(DBItest:::get_texts)` ```r -function(stream, transform = identity) { - to <- function(schema, ptype) transform(ptype) - if (inherits(stream, "nanoarrow_array_stream")) { - on.exit(stream$release()) - df <- nanoarrow::convert_array_stream(stream, to) - } else if (inherits(stream, "nanoarrow_array")) { - df <- nanoarrow::convert_array(stream, to) - } else { - stop("Unexpected conversion of type ", class(stream), ".", call. = FALSE) - } - - check_df(df) +function() { + c(text_cyrillic, text_latin, text_latin_encoded, text_chinese, text_ascii) } ``` -# random_table_name (18) +## test_arrow_roundtrip_one (4): inline dynamically -`r d(DBItest:::random_table_name)` +`r d(DBItest:::test_arrow_roundtrip_one)` ```r -function(n = 10) { - # FIXME: Use parallel-safe sequence of numbers - paste0("dbit", paste(sample(letters, n, replace = TRUE), collapse = "")) +function(con, tbl_in, tbl_expected = tbl_in, transform = identity, + name = NULL, use_append = FALSE, .add_na = "none") { + # Need data frames here because streams can be collected only once + stopifnot(is.data.frame(tbl_in), is.data.frame(tbl_expected)) + + force(tbl_expected) + if (.add_na == "above") { + tbl_in <- stream_add_na_above(tbl_in) + tbl_expected <- stream_add_na_above(tbl_expected) + } else if (.add_na == "below") { + tbl_in <- stream_add_na_below(tbl_in) + tbl_expected <- stream_add_na_below(tbl_expected) + } + + if (is.null(name)) { + name <- random_table_name() + } + + local_remove_test_table(con, name = name) + + if (use_append) { + dbCreateTableArrow(con, name, tbl_in %>% stream_frame()) + dbAppendTableArrow(con, name, tbl_in %>% stream_frame()) + } else { + dbWriteTableArrow(con, name, tbl_in %>% stream_frame()) + } + + stream <- dbReadTableArrow(con, name) + tbl_out <- check_arrow(stream, transform) + expect_equal_df(tbl_out, tbl_expected) } ``` -# local_remove_test_table (31) +## test_table_roundtrip_one (4): inline dynamically -`r d(DBItest:::local_remove_test_table)` +`r d(DBItest:::test_table_roundtrip_one)` ```r -function(con, name, frame = caller_env()) { - table_name <- dbQuoteIdentifier(con, name) - withr::defer( - try_silent( - dbRemoveTable(con, table_name) - ), - envir = frame - ) +function( + con, + tbl_in, + tbl_expected = tbl_in, + transform = identity, + name = NULL, + field.types = NULL, + use_append = FALSE, + .add_na = "none" +) { + force(tbl_expected) + if (.add_na == "above") { + tbl_in <- add_na_above(tbl_in) + tbl_expected <- add_na_above(tbl_expected) + } else if (.add_na == "below") { + tbl_in <- add_na_below(tbl_in) + tbl_expected <- add_na_below(tbl_expected) + } + + if (is.null(name)) { + name <- random_table_name() + } + + local_remove_test_table(con, name = name) + + if (use_append) { + dbCreateTable(con, name, field.types %||% tbl_in) + dbAppendTable(con, name, tbl_in) + } else { + dbWriteTable(con, name, tbl_in, field.types = field.types) + } + + tbl_read <- check_df(dbReadTable(con, name, check.names = FALSE)) + tbl_out <- transform(tbl_read) + expect_equal_df(tbl_out, tbl_expected) } ``` -# get_penguins (40) +## sql_union (6): inline dynamically -`r d(DBItest:::get_penguins)` +`r d(DBItest:::sql_union)` ```r -function(ctx) { - datasets_penguins <- unrowname(palmerpenguins::penguins[c(1, 153, 277), ]) - # FIXME: better handling of DBI backends that do support factors - datasets_penguins$species <- as.character(datasets_penguins$species) - datasets_penguins$island <- as.character(datasets_penguins$island) - datasets_penguins$sex <- as.character(datasets_penguins$sex) - as.data.frame(datasets_penguins) +function(..., .order_by = NULL, .ctx) { + queries <- c(...) + if (length(queries) == 1) { + query <- queries + } else { + stopifnot(!is.null(.ctx)) + query <- .ctx$tweaks$union(queries) + } + + if (!is.null(.order_by)) { + query <- paste0(query, " ORDER BY ", .order_by) + } + query } ``` -# test_arrow_roundtrip (40) +## random_table_name (18): inline dynamically -`r d(DBItest:::test_arrow_roundtrip)` +`r d(DBItest:::random_table_name)` ```r -function(...) { - test_arrow_roundtrip_one(..., .add_na = "none") - test_arrow_roundtrip_one(..., .add_na = "above") - test_arrow_roundtrip_one(..., .add_na = "below") +function(n = 10) { + # FIXME: Use parallel-safe sequence of numbers + paste0("dbit", paste(sample(letters, n, replace = TRUE), collapse = "")) } ``` -# stream_frame (42) +## stream_frame (42): inline dynamically `r d(DBItest:::stream_frame)` @@ -758,38 +820,7 @@ function(..., .select = NULL) { ``` -# local_result (46) - -`r d(DBItest:::local_result)` - -```r -function(query, frame = caller_env()) { - res <- query - withr::defer( # nolint next: unnecessary_nesting_linter. The braces ensure the srcref. - { - dbClearResult(res) - }, - envir = frame - ) - res -} - -``` - -# test_table_roundtrip (47) - -`r d(DBItest:::test_table_roundtrip)` - -```r -function(...) { - test_table_roundtrip_one(..., .add_na = "none") - test_table_roundtrip_one(..., .add_na = "above") - test_table_roundtrip_one(..., .add_na = "below") -} - -``` - -# trivial_df (71) +## trivial_df (71): inline dynamically `r d(DBItest:::trivial_df)` @@ -807,20 +838,7 @@ function(n = 1L, column = "a") { ``` -# skip_if_not_dbitest (72) - -`r d(DBItest:::skip_if_not_dbitest)` - -```r -function(ctx, version) { - if (as.package_version(ctx$tweaks$dbitest_version) < version) { - skip(paste0("tweak: dbitest_version: required: ", version, ", available: ", ctx$tweaks$dbitest_version)) - } -} - -``` - -# trivial_query (73) +## trivial_query (73) `r d(DBItest:::trivial_query)` @@ -844,48 +862,21 @@ function(n = 1L, column = "a", .order_by = NULL, .ctx = NULL) { ``` -# expect_equal_df (86) - -`r d(DBItest:::expect_equal_df)` - -```r -function(actual, expected) { - factor_cols <- purrr::map_lgl(expected, is.factor) - expected[factor_cols] <- purrr::map(expected[factor_cols], as.character) - - asis_cols <- purrr::map_lgl(expected, inherits, "AsIs") - expected[asis_cols] <- purrr::map(expected[asis_cols], unclass) - - list_cols <- purrr::map_lgl(expected, is.list) - - if (any(list_cols)) { - expect_false(all(list_cols)) - expect_equal(anyDuplicated(actual[!list_cols]), 0) - expect_equal(anyDuplicated(expected[!list_cols]), 0) - order_actual <- do.call(order, actual[!list_cols]) - order_expected <- do.call(order, expected[!list_cols]) - } else { - order_actual <- do.call(order, actual) - order_expected <- do.call(order, expected) - } - has_rownames_actual <- is.character(attr(actual, "row.names")) - has_rownames_expected <- is.character(attr(expected, "row.names")) - expect_equal(has_rownames_actual, has_rownames_expected) +# Render time - if (has_rownames_actual) { - expect_equal(sort(row.names(actual)), sort(row.names(expected))) - } +## package_name (5): known at render time - actual <- unrowname(actual[order_actual, ]) - expected <- unrowname(expected[order_expected, ]) +`r d(DBItest:::package_name)` - expect_identical(actual, expected) +```r +function(ctx) { + attr(class(ctx$drv), "package") } ``` -# get_placeholder_funs (128) +## get_placeholder_funs (128): known at render time `r d(DBItest:::get_placeholder_funs)` @@ -923,7 +914,44 @@ function(ctx, requires_names = NULL) { ``` -# check_df (214) +## skip_if_not_dbitest (72): known at render time + +`r d(DBItest:::skip_if_not_dbitest)` + +```r +function(ctx, version) { + if (as.package_version(ctx$tweaks$dbitest_version) < version) { + skip(paste0("tweak: dbitest_version: required: ", version, ", available: ", ctx$tweaks$dbitest_version)) + } +} + +``` + + +# Export and fully qualify? + +## check_arrow (18): linked to check_df + +`r d(DBItest:::check_arrow)` + +```r +function(stream, transform = identity) { + to <- function(schema, ptype) transform(ptype) + if (inherits(stream, "nanoarrow_array_stream")) { + on.exit(stream$release()) + df <- nanoarrow::convert_array_stream(stream, to) + } else if (inherits(stream, "nanoarrow_array")) { + df <- nanoarrow::convert_array(stream, to) + } else { + stop("Unexpected conversion of type ", class(stream), ".", call. = FALSE) + } + + check_df(df) +} + +``` + +## check_df (214) `r d(DBItest:::check_df)` @@ -944,3 +972,4 @@ function(df) { } ``` + From 6992017575c7e9da5b268705169c666016ed3037 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Sat, 3 May 2025 18:14:09 +0200 Subject: [PATCH 8/8] Ignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index df1b636e..8c0b6b39 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ ^CRAN-SUBMISSION$ ^\.vscode$ ^tests/testthat/helper-dev\.R$ +^tools$