#' @rdname utils
#' @title Utility Functions
#'
#' @description Utility functions useful for package default behavior.
#' `pkg_test` returns the path to tests from the `dbtest` package.
#' `pkg_config` returns the path to connection config from the `dbtest`
#' package. `all_tests` returns the path to all .yml or .yaml files in a given
#' directory. The default is to return all tests in the `dbtest` package
#'
#' @param file optional The file to reference at the default location
#' @param dir optional The directory for which to show all_tests
#'
#' @export
pkg_test <- function(file = "simple-tests.yml") {
system.file("extdata", "tests", path_file(file), package = "dbtest")
}
#' @rdname utils
#' @export
all_tests <- function(dir = system.file("extdata", "tests", package = "dbtest")) {
dir_ls(dir) %>% keep(tolower(path_ext(.)) %in% c("yml", "yaml"))
}
#' @rdname utils
#' @export
pkg_config <- function(file = "config.yml") {
system.file("extdata", "connections", file, package = "dbtest")
}
#' @rdname utils
#' @export
pkg_skip <- function(file = "skip-example.yml") {
system.file("extdata", "skip", path_file(file), package = "dbtest")
}
#' @title Write Tests
#'
#' @description A utility to make writing tests a bit easier
#' and more reproducible
#'
#' @param file The file the tests should be written to
#' @param header The header to name the test section. Preferably short
#' @param expr The expression to use for writing tests
#' @param overwrite optional Whether to overwrite the existing file or
#' append. Defaults to FALSE
#' @param comparison optional The type of comparison to use for filter
#' when creating the test. Currently ignored
#'
#' @return The input filename
#'
#' @export
write_test <- function(
file
, header
, expr
, overwrite = FALSE
, comparison = " > 10") {
existing <- if (file_exists(file) && !overwrite) read_yaml(file) else list()
# compare <- enquo(comparison)
# print(compare)
# need to figure out rlang semantics
new <- list(
setNames(
list(
list(
"mutate" = expr
, "filter" = paste(expr, comparison)
# , "summarize" = paste0("sum(",expression,", na.rm = TRUE)")
, "summarize" = paste0("n_distinct(", expr, ")")
, "group_by" = expr
, "arrange" = expr
)
)
, header
)
)
write_yaml(
c(existing, new)
, file
)
invisible(file)
}
#' @title Write Skip
#'
#' @description A utility to make writing skips a bit easier
#' and more reproducible
#'
#' @param file The file that skips should be written to
#' @param text The text used to note the skip
#' @param db optional The db that should be skipped
#' @param skip_file optional The file that should be skipped
#' @param context optional The context that should be skipped
#' @param test optional The test or verb that should be skipped
#' @param overwrite optional Whether to overwrite the file in question (defaults to false)
#'
#' @return The input filename
#'
#' @export
write_skip <- function(
file
, text
, db = NULL
, skip_file = NULL
, context = NULL
, test = NULL
, overwrite = FALSE ) {
existing <- if(file_exists(file) && !overwrite) read_yaml(file) else list()
new <- list(
list(
text = text
, db = db
, file = skip_file
, context = context
, test = test
)
)
# ugly... replace the nulls
new[[1]][as.logical(lapply(new[[1]], is.null))] <- NULL
write_yaml(
c(existing, new)
, file
)
invisible(file)
}
new_test_data <- function(numrow = 10, seed=NULL) {
set_seed(seed)
tibble(
fld_factor = new_factor_col(numrow)
, fld_datetime = paste(
new_date_col(numrow)
, new_time_col(numrow)
)
, fld_date = new_date_col(numrow)
, fld_time = new_time_col(numrow)
, fld_binary = sample(c(1, 0), numrow, TRUE)
, fld_integer = new_integer_col(numrow)
, fld_integer_alt = new_integer_col(numrow)
, fld_double = runif(numrow, -10000, 10000)
, fld_double_alt = new_double_col(numrow)
, fld_logical = new_logical_col(numrow)
, fld_logical_alt = new_logical_col(numrow)
, fld_character = new_character_col(numrow = numrow)
, fld_character_symbol = new_character_col(
numrow
, strsplit("~!@#$%^&*(){}|[]\\;'./,?><-_==+", "")[[1]]
)
, fld_character_lead_trail_whitespace = paste0(
new_character_col(numrow, " ", 7)
, new_character_col(numrow, maxlength = 10)
, new_character_col(numrow, " ", 7)
)
, fld_datetime_utc = paste(
new_date_col(numrow)
, new_time_col(numrow)
, "UTC"
)
) %>%
lapply(na_portion) %>%
as_tibble()
}
new_integer_col <- function(numrow = 10, magnitude=10000) {
as.integer(sample(-magnitude:magnitude, numrow, TRUE))
}
new_double_col <- function(numrow = 10, magnitude = 10000) {
runif(numrow, -magnitude, magnitude)
}
new_date_col <- function(numrow = 10) {
paste(
sprintf(sample(1:12, numrow, TRUE), fmt = "%02d")
, sprintf(sample(1:28, numrow, TRUE), fmt = "%02d")
, sample(1990:2020, numrow, TRUE)
,
sep = "/"
)
}
new_time_col <- function(numrow = 10) {
paste(sprintf(sample(1:24, numrow, TRUE), fmt = "%02d")
, sprintf(sample(0:60, numrow, TRUE), fmt = "%02d")
, sprintf(sample(0:60, numrow, TRUE), fmt = "%02d")
,
sep = ":"
)
}
new_character <- function(charset = c(LETTERS, tolower(LETTERS))
, maxlength = 20
, minlength = 10) {
paste(
sample(
charset
, sample(minlength:maxlength, 1)
, TRUE
)
,
collapse = ""
)
}
new_factor_col <- function(
numrow = 10
, charset = c(LETTERS, tolower(LETTERS))
, maxlength = 20) {
raw_chr <- new_character_col(numrow = numrow, charset = charset, maxlength = maxlength)
return(factor(raw_chr, levels = raw_chr))
}
new_character_col <- function(numrow = 10
, charset = c(LETTERS, tolower(LETTERS))
, maxlength = 20
, minlength = 1) {
as.character(lapply(1:numrow
, new_character
, charset = charset
, maxlength = maxlength
, minlength = minlength
))
}
new_logical_col <- function(numrow = 10) {
sample(c(TRUE, FALSE), numrow, TRUE)
}
na_portion <- function(input, minpct = 0.1, maxpct = 0.4) {
sel <- sample(1:length(input)
,
size = sample(pmax(3, length(input) * minpct):(length(input) * maxpct), 1)
, replace = FALSE
)
input[sel] <- NA
return(input)
}
set_seed <- function(seed=NULL) {
if (!missing(seed)) {
set.seed(seed)
}
invisible()
}
build_remote_tbl <- function(
conn
, data
, name = new_character(maxlength = 1, charset = tolower(LETTERS))
, verbose = FALSE
) {
output <- tryCatch({
# try to build the table
output_tbl <- suppressMessages(dplyr::copy_to(
conn
, data
, name = name
))
output_tbl
}
, error = function(e){
if (grepl('Table.*exists in database',e)) {
# try referencing the table
output_tbl <- tryCatch({
output <- dplyr::tbl(conn, name)
if(verbose) message("Using existing table")
output
}
, error = function(e){
# try creating the table with a new name
name <- paste0(name,sample(tolower(LETTERS),1,FALSE))
tbl <- suppressMessages(dplyr::copy_to(conn, data, name = name))
if(verbose) message(paste0("created new table name: ",name))
return(tbl)
})
return(output_tbl)
} else {
stop(e)
}
}
)
return(output)
}
force_failed_tests <- function(msg, label, tests) {
return(
test_single_database_impl(
datasource = NULL
, tests = tests
, label = label
, fail = msg
)
)
}
safe_read_yaml <- function(file) {
if (fs::file_exists(file)) {
return(yaml::read_yaml(file))
} else {
return(NULL)
}
}
read_skip_data <- function(file) {
if (is.null(file)){
return(NULL)
} else {
return(
unlist(
lapply(file, safe_read_yaml)
, recursive = FALSE
)
)
}
}
integer64_fix <- function(x){
if(is.integer64(x)){
return(as.integer(x))
} else {
return(x)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.