1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
|
deparse_all <- function(x) {
x <- purrr::map_if(x, is_formula, f_rhs)
purrr::map_chr(x, expr_text, width = 500L)
}
#' Provides comma-separated string out of the parameters
#' @export
#' @keywords internal
named_commas <- function(x) {
if (is.list(x)) {
x <- purrr::map_chr(x, as_label)
} else {
x <- as.character(x)
}
nms <- names2(x)
out <- ifelse(nms == "", x, paste0(nms, " = ", x))
paste0(out, collapse = ", ")
}
commas <- function(...) paste0(..., collapse = ", ")
unique_table_name <- function(prefix = "") {
vals <- c(letters, LETTERS, 0:9)
name <- paste0(sample(vals, 10, replace = TRUE), collapse = "")
paste0(prefix, "dbplyr_", name)
}
unique_subquery_name <- function() {
# Needs to use option so can reset at the start of each query
i <- getOption("dbplyr_subquery_name", 0) + 1
options(dbplyr_subquery_name = i)
sprintf("q%02i", i)
}
unique_column_name <- function() {
# Needs to use option so can reset at the start of each query
i <- getOption("dbplyr_column_name", 0) + 1
options(dbplyr_column_name = i)
sprintf("col%02i", i)
}
unique_subquery_name_reset <- function() {
options(dbplyr_subquery_name = 0)
}
unique_column_name_reset <- function() {
options(dbplyr_column_name = 0)
}
succeeds <- function(x, quiet = FALSE) {
tryCatch(
{
x
TRUE
},
error = function(e) {
if (!quiet)
message("Error: ", e$message) # nocov
FALSE
}
)
}
c_character <- function(...) {
x <- c(...)
if (length(x) == 0) {
return(character())
}
if (!is.character(x)) {
cli_abort("Character input expected")
}
x
}
cat_line <- function(...) cat(paste0(..., "\n"), sep = "")
# nocov start
res_warn_incomplete <- function(res, hint = "n = -1") {
if (dbHasCompleted(res)) return()
rows <- big_mark(dbGetRowCount(res))
cli::cli_warn("Only first {rows} results retrieved. Use {hint} to retrieve all.")
}
add_temporary_prefix <- function(con, table, temporary = TRUE) {
check_table_path(table)
if (!temporary) {
return(table)
}
pieces <- table_path_components(table, con)[[1]]
table_name <- pieces[length(pieces)]
if (substr(table_name, 1, 1) != "#") {
new_name <- paste0("#", table_name)
cli::cli_inform(
paste0("Created a temporary table named ", new_name),
class = c("dbplyr_message_temp_table", "dbplyr_message")
)
pieces[[length(pieces)]] <- new_name
table <- make_table_path(pieces, con)
}
table
}
# nocov end
# Helper for testing
local_methods <- function(..., .frame = caller_env()) {
local_bindings(..., .env = global_env(), .frame = .frame)
}
local_db_table <- function(con, value, name, ..., temporary = TRUE, envir = parent.frame()) {
if (inherits(con, "Microsoft SQL Server") && temporary) {
name <- paste0("#", name)
}
withr::defer(DBI::dbRemoveTable(con, name), envir = envir)
copy_to(con, value, name, temporary = temporary, ...)
tbl(con, name)
}
local_sqlite_connection <- function(envir = parent.frame()) {
withr::local_db_connection(
DBI::dbConnect(RSQLite::SQLite(), ":memory:"),
.local_envir = envir
)
}
|