# utility functions that make it easier to support both standard and non-standard evaluation
# turn quo and expr into text in a controlled way
# this is because rlang::as_label cuts too short
get_quo_text <- function(q) {
stopifnot(rlang::is_quosure(q) || rlang::is_expression(q))
rlang::expr_text(q) %>%
stringr::str_replace("\n.*$", "...") %>%
stringr::str_remove("^~")
}
# resolve default cols in a list of quos
# note: since these functions are within isoreader, they need to receive quos instead of expressions,
# otherwise they will try to use the local default function leading to the wrong results!
# @fixme: not sure how to, could consider having a copy of get_column_names and resolve_defaults
# in isoprocessor but that seems redundant too
resolve_defaults <- isoreader:::resolve_defaults
# Test quo expressions by confirming they can create a valid column in a mutate
# @TODO: should this be locally evaluated or at least with tidy_eval just to insert the data frame rather than the whole call stack?
# @note that global variables will be interpreted even in the context of the data frame
# ideally this will be only within the data frame - is that correct?
# see isoreader::local_select_eval for example
check_expressions <- function(df, ...) {
# df name and data frame test
if (missing(df)) stop("no data frame supplied", call. = FALSE)
df_name <- enquo(df) %>% rlang::as_label()
df <- enquo(df) %>% eval_tidy()
if (!is.data.frame(df))
glue("parameter {df_name} is not a data frame") %>% stop(call. = FALSE)
# use a safe version of mutate to check all expressions
# (use mutate instead of eval_tidy to make sure it's absolutely valid)
safe_eval <- safely(mutate)
expr_quos <- quos(!!!list(...)) %>%
# make sure to evaluate calls to default
resolve_defaults() %>%
# make sure that the expressions are locally evaluated
map(~quo(!!get_expr(.x)))
expr_quos <- expr_quos[!map_lgl(expr_quos, quo_is_null)]
expr_errors <- map(expr_quos, ~safe_eval(df, !!.x)$error)
# check results
ok <- map_lgl(expr_errors, ~is.null(.x))
# summarize if there were any errors
if (!all(ok)) {
params <-
map2_chr(names(expr_quos)[!ok], expr_quos[!ok], function(var, val) {
if (nchar(var) > 0 && var != rlang::as_label(val)) str_c(var, " = ", rlang::as_label(val))
else rlang::as_label(val)
}) %>%
collapse("', '", last = "' and '")
errors <- map_chr(expr_errors[!ok], ~.x$message) %>% collapse("\n- ")
err_msg <-
if (sum(!ok) > 1)
glue("'{params}' are invalid expressions in data frame '{df_name}':\n- {errors}")
else
glue("'{params}' is not a valid expression in data frame '{df_name}':\n- {errors}")
stop(err_msg, call. = FALSE)
}
return(invisible(df))
}
# column name =====
# Get the column names for a set of parameters referencing columns in a data frame. Compatible with all dplyr type column selection
# criteria including both standard and non-standard evaluation. Throws errors if expressions cannot be evaluated or if an incorrect
# number of columns are identified for a given parameter.
# @param df the data frame
# @param ... named expressions with variable selection criteria (anything that tidyselect::eval_select supports)
# @param n_reqs named list to specify how many columns are allowed/required for each selection criterion, default for all that are not specified is 1.
# Allowed values are a specific number 1,2,3,4, etc. "*" for any number, "?" for 0 or 1 and "+" for at least one.
# @param type_reqs named list to specify what types certain columns must be, allowed: "list" (also includes "vctrs_list_of"), "numeric", "integer", "character", "logical"
# @param cols_must_exist - if TRUE, will throw an error if a column does not exist, otherwise just warning
# @return list of column names for each entry (may contain multiple depending on selection conditions)
get_column_names <- isoreader:::get_column_names
# Get new columns names
# Resolves defaults and checks to make sure that the column name refers to a valid single symbol.
# @param ... named quos
# @return list of named strings for each new column
get_new_column_names <- function(...) {
# make sure to evaluate calls to default
cols_quos <- quos(!!!list(...)) %>% resolve_defaults()
# get columns text names
cols_quos %>% purrr::map(
~{
if (rlang::is_symbol(.x)) rlang::as_name(.x)
else if (rlang::is_quosure(.x) && rlang::quo_is_symbol(.x)) rlang::as_name(.x)
else if (rlang::is_quosure(.x) && quo_is_value(.x)) as.character(rlang::eval_tidy(.x))
else if (is.character(.x)) .x
else stop("not a valid column name '", rlang::as_label(.x), "'", call. = FALSE)
}
)
}
# aesthetics quos ========
# convert an aesthetics quo into quos for generating mutate quos to make all the columns necessary for the aesthetics
# can deal with multiple expressions encapsulated by c() and list()
aesthetics_quo_to_mutate_quos <- function(q, drop_null = TRUE, drop_missing = TRUE) {
if (rlang::quo_is_call(q) && rlang::call_name(q) %in% c("c", "list")) {
qs <- quos(!!!rlang::call_args(q))
} else {
qs <- quos(!!q)
}
if (drop_null)
qs <- qs[!map_lgl(qs, rlang::quo_is_null)]
if (drop_missing)
qs <- qs[!map_lgl(qs, rlang::quo_is_missing)]
names(qs)[names(qs) == ""] <- purrr::map_chr(qs[names(qs) == ""], rlang::as_label)
return(qs)
}
# check if a quo is non-symbolic, non-call
quo_is_value <- function(q) {
return(!rlang::quo_is_symbol(q) && !rlang::quo_is_call(q))
}
# check if quos are non-symbolic, non-call
quos_are_values <- function(qs) {
return(map_lgl(qs, quo_is_value))
}
# check if quos are unnamed non-symbolic, non-call
# here: unnamed = name != value
quos_are_unnamed_values <- function(qs) {
return(quos_are_values(qs) & names(qs) == map_chr(qs, rlang::as_label))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.