glubort <- function(..., .sep = "", .envir = caller_env(), .call = .envir) {
abort(glue(..., .sep = .sep, .envir = .envir), call = .call)
}
glue_quote_collapse <- function(x) {
glue::glue_collapse(glue::single_quote(x), sep = ", ")
}
simplify_terms <- function(x) {
# This is like stats:::terms.default
# but doesn't look at x$terms.
is_terms <- inherits(x, "terms")
if (!is_terms) {
abort("`x` must be a terms object")
}
# It removes the environment
# (which could be large)
# - it is not needed for prediction
# - it is used in model.matrix(data = environment(object))
# but you should never need that
# - I guess it could be used to look up global variables in a formula,
# but don't we want to guard against that?
# - It is used in model.frame() to evaluate the predvars, but that is also
# evaluated in the presence of the data so that should always suffice?
attr(x, ".Environment") <- NULL
x
}
# - RHS `.` should be expanded ahead of time by `expand_formula_dot_notation()`
# - Can't use `get_all_vars()` because it chokes on formulas with variables with
# spaces like ~ `x y`
get_all_predictors <- function(formula, data) {
predictor_formula <- new_formula(
lhs = NULL,
rhs = f_rhs(formula),
env = f_env(formula)
)
predictors <- all.vars(predictor_formula)
extra_predictors <- setdiff(predictors, names(data))
if (length(extra_predictors) > 0) {
extra_predictors <- glue_quote_collapse(extra_predictors)
glubort("The following predictors were not found in `data`: {extra_predictors}.")
}
predictors
}
# LHS `.` are NOT expanded by `expand_formula_dot_notation()`, and should be
# considered errors
get_all_outcomes <- function(formula, data) {
outcome_formula <- new_formula(
lhs = f_lhs(formula),
rhs = 1,
env = f_env(formula)
)
outcomes <- all.vars(outcome_formula)
if ("." %in% outcomes) {
abort("The left hand side of the formula cannot contain `.`")
}
extra_outcomes <- setdiff(outcomes, names(data))
if (length(extra_outcomes) > 0) {
extra_outcomes <- glue_quote_collapse(extra_outcomes)
glubort("The following outcomes were not found in `data`: {extra_outcomes}.")
}
outcomes
}
remove_formula_intercept <- function(formula, intercept) {
if (intercept) {
return(formula)
}
rhs <- f_rhs(formula)
lhs <- f_lhs(formula)
env <- f_env(formula)
rhs <- expr(!!rhs + 0)
new_formula(
lhs = lhs,
rhs = rhs,
env = env
)
}
check_unique_names <- function(x,
...,
arg = caller_arg(x),
call = caller_env()) {
if (has_unique_names(x)) {
return(invisible(NULL))
}
cli::cli_abort(
"All elements of {.arg {arg}} must have unique names.",
call = call
)
}
check_unique_column_names <- function(x,
...,
arg = caller_arg(x),
call = caller_env()) {
if (has_unique_column_names(x)) {
return(invisible(NULL))
}
cli::cli_abort(
"All columns of {.arg {arg}} must have unique names.",
call = call
)
}
has_unique_names <- function(x) {
nms <- names(x)
if (length(nms) != length(x)) {
return(FALSE)
}
if (any(is.na(nms) | nms == "")) {
return(FALSE)
}
!anyDuplicated(nms)
}
has_unique_column_names <- function(x) {
nms <- colnames(x)
if (length(nms) != NCOL(x)) {
return(FALSE)
}
if (any(is.na(nms) | nms == "")) {
return(FALSE)
}
!anyDuplicated(nms)
}
class1 <- function(x) {
class(x)[1]
}
# ------------------------------------------------------------------------------
check_data_frame_or_matrix <- function(x,
...,
arg = caller_arg(x),
call = caller_env()) {
if (!missing(x)) {
if (is.data.frame(x) || is.matrix(x)) {
return(invisible(NULL))
}
}
stop_input_type(
x = x,
what = "a data frame or a matrix",
arg = arg,
call = call
)
}
coerce_to_tibble <- function(x) {
# Only to be used after calling `check_data_frame_or_matrix()`.
# Coerces matrices and bare data frames to tibbles.
# Avoids calling `as_tibble()` on data frames, as that is more expensive than
# you'd think, even on tibbles. Need to call `hardhat_new_tibble()` even on
# existing tibbles to ensure subclasses are dropped (#228).
if (is.data.frame(x)) {
hardhat_new_tibble(x, size = vec_size(x))
} else {
tibble::as_tibble(x, .name_repair = "minimal")
}
}
# ------------------------------------------------------------------------------
hardhat_new_tibble <- function (x, size) {
# Faster than `tibble::new_tibble()`, and it drops extra attributes
new_data_frame(x = x, n = size, class = c("tbl_df", "tbl"))
}
# ------------------------------------------------------------------------------
with_na_pass <- function(expr) {
# TODO: This helper is only used because `withr::defer()` is somewhat slow
# right now. Remove this helper and use `rlang::with_options()` once the next
# version of withr/rlang is on CRAN https://github.com/r-lib/withr/pull/221.
old <- options(na.action = "na.pass")
on.exit(options(old), add = TRUE, after = FALSE)
expr
}
# ------------------------------------------------------------------------------
vec_paste0 <- function(...) {
args <- vec_recycle_common(...)
exec(paste0, !!!args)
}
# ------------------------------------------------------------------------------
check_inherits <- function(x,
what,
...,
allow_null = FALSE,
arg = caller_arg(x),
call = caller_env()) {
if (!missing(x)) {
if (inherits(x, what)) {
return(invisible(NULL))
}
if (allow_null && is_null(x)) {
return(invisible(NULL))
}
}
stop_input_type(
x = x,
what = cli::format_inline("a <{what}>"),
arg = arg,
call = call
)
}
# ------------------------------------------------------------------------------
vec_cast_named <- function(x, to, ..., call = caller_env()) {
# vec_cast() drops names currently
# https://github.com/r-lib/vctrs/issues/623
out <- vec_cast(x, to, ..., call = call)
names <- vec_names(x)
if (!is.null(names)) {
out <- vec_set_names(out, names)
}
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.