Nothing
#' Make a set indicator node.
#'
#' Create a new column indicating the membership of another column in a given set.
#'
#'
#' @param source source to select from.
#' @param rescol name of column to land indicator in.
#' @param testcol name of column to check.
#' @param testvalues values to check for.
#' @param ... force later arguments to bind by name
#' @param translate_quotes logical if TRUE translate quotes to SQL choice (simple replacement, no escaping).
#' @param env environment to look to.
#' @return set_indicator node.
#'
#' @examples
#'
#' if (requireNamespace("DBI", quietly = TRUE) && requireNamespace("RSQLite", quietly = TRUE)) {
#' my_db <- DBI::dbConnect(RSQLite::SQLite(),
#' ":memory:")
#'
#' d <- rq_copy_to(my_db, 'd',
#' data.frame(a = c("1", "2", "1", "3"),
#' b = c("1", "1", "3", "2"),
#' q = 1,
#' stringsAsFactors = FALSE),
#' temporary = TRUE,
#' overwrite = TRUE)
#' # example
#' set <- c("1", "2")
#' op_tree <- d %.>%
#' set_indicator(., "one_two", "a", set) %.>%
#' set_indicator(., "z", "a", c())
#' print(column_names(op_tree))
#' print(columns_used(op_tree))
#' cat(format(op_tree))
#' sql <- to_sql(op_tree, my_db)
#' cat(sql)
#' print(DBI::dbGetQuery(my_db, sql))
#'
#' op_tree2 <- d %.>%
#' set_indicator(., "one_two", "a", set) %.>%
#' set_indicator(., "z", "b", c()) %.>%
#' select_columns(., c("z", "one_two"))
#' print(column_names(op_tree2))
#' print(columns_used(op_tree2))
#'
#' # cleanup
#' DBI::dbDisconnect(my_db)
#' }
#'
#' @export
#'
set_indicator <- function(source,
rescol,
testcol,
testvalues,
...,
translate_quotes = FALSE,
env = parent.frame()) {
force(env)
wrapr::stop_if_dot_args(substitute(list(...)), "set_indicator")
UseMethod("set_indicator", source)
}
#' @export
set_indicator.relop <- function(source,
rescol,
testcol,
testvalues,
...,
translate_quotes = FALSE,
env = parent.frame()) {
force(env)
wrapr::stop_if_dot_args(substitute(list(...)), "set_indicator")
testvname <- rquery_deparse(substitute(testvalues))
cols <- column_names(source)
if(rescol %in% cols) {
stop("rquery::set_indicator.relop rescol must not be a column name of source data")
}
if(!(testcol %in% cols)) {
stop("rquery::set_indicator.relop testcol must be a column name of source data")
}
display_form <- paste0("set_indicator(., ",
rescol,
" = ",
testcol,
" IN ",
testvname,
")")
if(length(testvalues)>0) {
terms = list(as.name(testcol), " IN ( ")
for(i in seq_len(length(testvalues))) {
if(i>1) {
terms <- c(terms, " , ")
}
terms <- c(terms, list(list(testvalues[[i]])))
}
terms <- c(terms, list(" ) "))
terms <- list(terms)
names(terms) <- rescol
} else {
terms <- rescol %:=% 0
}
r <- list(source = list(source),
table_name = NULL,
parsed = NULL,
rescol = rescol,
testcol = testcol,
testvalues = testvalues,
display_form = display_form,
terms = terms,
translate_quotes = translate_quotes)
r <- relop_decorate("relop_set_indicator", r)
r
}
#' @export
set_indicator.data.frame <- function(source,
rescol,
testcol,
testvalues,
...,
translate_quotes = FALSE,
env = parent.frame()) {
force(env)
wrapr::stop_if_dot_args(substitute(list(...)), "set_indicator")
tmp_name <- mk_tmp_name_source("rquery_tmp")()
dnode <- mk_td(tmp_name, colnames(source))
enode <- set_indicator(source = dnode,
rescol = rescol,
testcol = testcol,
testvalues = testvalues,
env = env)
rquery_apply_to_data_frame(source, enode, env = env)
}
#' @export
format_node.relop_set_indicator <- function(node) {
paste0(node$display_form,
"\n")
}
calc_used_relop_set_indicator <- function(x,
using = NULL) {
cols <- column_names(x)
if(length(using)>0) {
cols <- using
}
if(!(x$testcol %in% cols)) {
cols <- c(cols, x$testcol)
}
cols
}
#' @export
columns_used.relop_set_indicator <- function (x, ...,
using = NULL) {
wrapr::stop_if_dot_args(substitute(list(...)),
"rquery::columns_used.relop_set_indicator")
cols <- calc_used_relop_set_indicator(x,
using = using)
cols <- setdiff(cols, x$rescol)
columns_used(x$source[[1]],
using = cols)
}
#' @export
column_names.relop_set_indicator <- function (x, ...) {
wrapr::stop_if_dot_args(substitute(list(...)),
"rquery::column_names.relop_set_indicator")
cols <- column_names(x$source[[1]])
if(!(x$testcol %in% cols)) {
cols <- c(cols, x$testcol)
}
if(!(x$rescol %in% cols)) {
cols <- c(cols, x$rescol)
}
cols
}
#' @export
to_sql.relop_set_indicator <- function (x,
db,
...,
limit = NULL,
source_limit = NULL,
indent_level = 0,
tnum = mk_tmp_name_source('tsql'),
append_cr = TRUE,
using = NULL) {
wrapr::stop_if_dot_args(substitute(list(...)), "rquery::to_sql.relop_set_indicator")
dispatch_to_sql_method(
method_name = "to_sql.relop_set_indicator",
x = x,
db = db,
limit = limit,
source_limit = source_limit,
indent_level = indent_level,
tnum = tnum,
append_cr = append_cr,
using = using)
}
to_sql_relop_set_indicator <- function(
x,
db,
...,
limit = NULL,
source_limit = NULL,
indent_level = 0,
tnum = mk_tmp_name_source('tsql'),
append_cr = TRUE,
using = NULL) {
wrapr::stop_if_dot_args(substitute(list(...)),
"rquery::to_sql.relop_set_indicator")
cols1 <- column_names(x$source[[1]])
qexample = quote_string(db, "a")
qlen = as.numeric(regexec("a", qexample, fixed = TRUE)) - 1
qsym = substr(qexample, 1, qlen)
sqlexprs <- vapply(x$terms,
function(ei) {
prep_sql_toks(db, ei,
translate_quotes = x$translate_quotes,
qsym = qsym)
}, character(1))
if(length(sqlexprs)!=1) {
stop("rquery::to_sql.relop_set_indicator expected indicator calculation to be length 1")
}
subsql_list <- to_sql(x$source[[1]],
db = db,
limit = limit,
source_limit = source_limit,
indent_level = indent_level + 1,
tnum = tnum,
append_cr = FALSE,
using = cols1) # TODO: double check using calculation
subsql <- subsql_list[[length(subsql_list)]]
tab <- tnum()
prefix <- paste(rep(' ', indent_level), collapse = '')
q <- paste0(prefix, "SELECT *, ",
sqlexprs[[1]], " AS ", quote_identifier(db, names(sqlexprs)),
" FROM (\n",
subsql, "\n",
prefix, ") ",
tab)
if(!is.null(limit)) {
q <- paste(q, "LIMIT",
format(ceiling(limit), scientific = FALSE))
}
if(append_cr) {
q <- paste0(q, "\n")
}
c(subsql_list[-length(subsql_list)], q)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.