From 519267eef20a3a52268ff99f54405ca652e0d878 Mon Sep 17 00:00:00 2001 From: olivroy Date: Wed, 23 Oct 2024 09:08:04 -0400 Subject: [PATCH 1/6] `use_standalone("r-lib/rlang")` `purrr` and `obj-type` + update snapshots --- DESCRIPTION | 2 +- R/compat-type.R | 226 ----------- R/import-standalone-obj-type.R | 364 ++++++++++++++++++ ...mpat-purrr.R => import-standalone-purrr.R} | 55 ++- tests/testthat/_snaps/eval-select.md | 2 +- tests/testthat/_snaps/helpers-where.md | 4 +- tests/testthat/_snaps/helpers.md | 2 +- 7 files changed, 415 insertions(+), 240 deletions(-) delete mode 100644 R/compat-type.R create mode 100644 R/import-standalone-obj-type.R rename R/{compat-purrr.R => import-standalone-purrr.R} (84%) diff --git a/DESCRIPTION b/DESCRIPTION index d287e07b..b357b562 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,7 +19,7 @@ Imports: cli (>= 3.3.0), glue (>= 1.3.0), lifecycle (>= 1.0.3), - rlang (>= 1.0.4), + rlang (>= 1.1.0), vctrs (>= 0.5.2), withr Suggests: diff --git a/R/compat-type.R b/R/compat-type.R deleted file mode 100644 index f4dca981..00000000 --- a/R/compat-type.R +++ /dev/null @@ -1,226 +0,0 @@ -# nocov start --- r-lib/rlang compat-type -# -# Changelog -# ========= -# -# 2022-06-22: -# - `friendly_type_of()` is now `obj_type_friendly()`. -# - Added `obj_type_oo()`. -# -# 2021-12-20: -# - Added support for scalar values and empty vectors. -# - Added `stop_input_type()` -# -# 2021-06-30: -# - Added support for missing arguments. -# -# 2021-04-19: -# - Added support for matrices and arrays (#141). -# - Added documentation. -# - Added changelog. - - -#' Return English-friendly type -#' @param x Any R object. -#' @param value Whether to describe the value of `x`. -#' @param length Whether to mention the length of vectors and lists. -#' @return A string describing the type. Starts with an indefinite -#' article, e.g. "an integer vector". -#' @noRd -obj_type_friendly <- function(x, value = TRUE, length = FALSE) { - if (is_missing(x)) { - return("absent") - } - - if (is.object(x)) { - if (inherits(x, "quosure")) { - type <- "quosure" - } else { - type <- paste(class(x), collapse = "/") - } - return(sprintf("a <%s> object", type)) - } - - if (!rlang::is_vector(x)) { - return(.rlang_as_friendly_type(typeof(x))) - } - - n_dim <- length(dim(x)) - - if (value && !n_dim) { - if (is_na(x)) { - return(switch( - typeof(x), - logical = "`NA`", - integer = "an integer `NA`", - double = "a numeric `NA`", - complex = "a complex `NA`", - character = "a character `NA`", - .rlang_stop_unexpected_typeof(x) - )) - } - if (length(x) == 1 && !is_list(x)) { - return(switch( - typeof(x), - logical = if (x) "`TRUE`" else "`FALSE`", - integer = "an integer", - double = "a number", - complex = "a complex number", - character = if (nzchar(x)) "a string" else "`\"\"`", - raw = "a raw value", - .rlang_stop_unexpected_typeof(x) - )) - } - if (length(x) == 0) { - return(switch( - typeof(x), - logical = "an empty logical vector", - integer = "an empty integer vector", - double = "an empty numeric vector", - complex = "an empty complex vector", - character = "an empty character vector", - raw = "an empty raw vector", - list = "an empty list", - .rlang_stop_unexpected_typeof(x) - )) - } - } - - type <- .rlang_as_friendly_vector_type(typeof(x), n_dim) - - if (length && !n_dim) { - type <- paste0(type, sprintf(" of length %s", length(x))) - } - - type -} - -.rlang_as_friendly_vector_type <- function(type, n_dim) { - if (type == "list") { - if (n_dim < 2) { - return("a list") - } else if (n_dim == 2) { - return("a list matrix") - } else { - return("a list array") - } - } - - type <- switch( - type, - logical = "a logical %s", - integer = "an integer %s", - numeric = , - double = "a double %s", - complex = "a complex %s", - character = "a character %s", - raw = "a raw %s", - type = paste0("a ", type, " %s") - ) - - if (n_dim < 2) { - kind <- "vector" - } else if (n_dim == 2) { - kind <- "matrix" - } else { - kind <- "array" - } - sprintf(type, kind) -} - -.rlang_as_friendly_type <- function(type) { - switch( - type, - - list = "a list", - - NULL = "NULL", - environment = "an environment", - externalptr = "a pointer", - weakref = "a weak reference", - S4 = "an S4 object", - - name = , - symbol = "a symbol", - language = "a call", - pairlist = "a pairlist node", - expression = "an expression vector", - - char = "an internal string", - promise = "an internal promise", - ... = "an internal dots object", - any = "an internal `any` object", - bytecode = "an internal bytecode object", - - primitive = , - builtin = , - special = "a primitive function", - closure = "a function", - - type - ) -} - -.rlang_stop_unexpected_typeof <- function(x, call = rlang::caller_env()) { - rlang::abort( - sprintf("Unexpected type <%s>.", typeof(x)), - call = call - ) -} - -#' Return OO type -#' @param x Any R object. -#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, -#' `"R6"`, or `"R7"`. -#' @noRd -obj_type_oo <- function(x) { - if (!is.object(x)) { - return("bare") - } - - class <- inherits(x, c("R6", "R7_object"), which = TRUE) - - if (class[[1]]) { - "R6" - } else if (class[[2]]) { - "R7" - } else if (isS4(x)) { - "S4" - } else { - "S3" - } -} - -#' @param x The object type which does not conform to `what`. Its -#' `obj_type_friendly()` is taken and mentioned in the error message. -#' @param what The friendly expected type. -#' @param ... Arguments passed to [abort()]. -#' @inheritParams args_error_context -#' @noRd -stop_input_type <- function(x, - what, - ..., - arg = rlang::caller_arg(x), - call = rlang::caller_env()) { - # From compat-cli.R - format_arg <- rlang::env_get( - nm = "format_arg", - last = topenv(), - default = NULL, - inherit = TRUE - ) - if (!is.function(format_arg)) { - format_arg <- function(x) sprintf("`%s`", x) - } - - message <- sprintf( - "%s must be %s, not %s.", - format_arg(arg), - what, - obj_type_friendly(x) - ) - - rlang::abort(message, ..., call = call, arg = arg) -} - -# nocov end diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 00000000..47268d62 --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -0,0 +1,364 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R +# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-obj-type.R +# last-updated: 2024-02-14 +# license: https://unlicense.org +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 2024-02-14: +# - `obj_type_friendly()` now works for S7 objects. +# +# 2023-05-01: +# - `obj_type_friendly()` now only displays the first class of S3 objects. +# +# 2023-03-30: +# - `stop_input_type()` now handles `I()` input literally in `arg`. +# +# 2022-10-04: +# - `obj_type_friendly(value = TRUE)` now shows numeric scalars +# literally. +# - `stop_friendly_type()` now takes `show_value`, passed to +# `obj_type_friendly()` as the `value` argument. +# +# 2022-10-03: +# - Added `allow_na` and `allow_null` arguments. +# - `NULL` is now backticked. +# - Better friendly type for infinities and `NaN`. +# +# 2022-09-16: +# - Unprefixed usage of rlang functions with `rlang::` to +# avoid onLoad issues when called from rlang (#1482). +# +# 2022-08-11: +# - Prefixed usage of rlang functions with `rlang::`. +# +# 2022-06-22: +# - `friendly_type_of()` is now `obj_type_friendly()`. +# - Added `obj_type_oo()`. +# +# 2021-12-20: +# - Added support for scalar values and empty vectors. +# - Added `stop_input_type()` +# +# 2021-06-30: +# - Added support for missing arguments. +# +# 2021-04-19: +# - Added support for matrices and arrays (#141). +# - Added documentation. +# - Added changelog. +# +# nocov start + +#' Return English-friendly type +#' @param x Any R object. +#' @param value Whether to describe the value of `x`. Special values +#' like `NA` or `""` are always described. +#' @param length Whether to mention the length of vectors and lists. +#' @return A string describing the type. Starts with an indefinite +#' article, e.g. "an integer vector". +#' @noRd +obj_type_friendly <- function(x, value = TRUE) { + if (is_missing(x)) { + return("absent") + } + + if (is.object(x)) { + if (inherits(x, "quosure")) { + type <- "quosure" + } else { + type <- class(x)[[1L]] + } + return(sprintf("a <%s> object", type)) + } + + if (!is_vector(x)) { + return(.rlang_as_friendly_type(typeof(x))) + } + + n_dim <- length(dim(x)) + + if (!n_dim) { + if (!is_list(x) && length(x) == 1) { + if (is_na(x)) { + return(switch( + typeof(x), + logical = "`NA`", + integer = "an integer `NA`", + double = + if (is.nan(x)) { + "`NaN`" + } else { + "a numeric `NA`" + }, + complex = "a complex `NA`", + character = "a character `NA`", + .rlang_stop_unexpected_typeof(x) + )) + } + + show_infinites <- function(x) { + if (x > 0) { + "`Inf`" + } else { + "`-Inf`" + } + } + str_encode <- function(x, width = 30, ...) { + if (nchar(x) > width) { + x <- substr(x, 1, width - 3) + x <- paste0(x, "...") + } + encodeString(x, ...) + } + + if (value) { + if (is.numeric(x) && is.infinite(x)) { + return(show_infinites(x)) + } + + if (is.numeric(x) || is.complex(x)) { + number <- as.character(round(x, 2)) + what <- if (is.complex(x)) "the complex number" else "the number" + return(paste(what, number)) + } + + return(switch( + typeof(x), + logical = if (x) "`TRUE`" else "`FALSE`", + character = { + what <- if (nzchar(x)) "the string" else "the empty string" + paste(what, str_encode(x, quote = "\"")) + }, + raw = paste("the raw value", as.character(x)), + .rlang_stop_unexpected_typeof(x) + )) + } + + return(switch( + typeof(x), + logical = "a logical value", + integer = "an integer", + double = if (is.infinite(x)) show_infinites(x) else "a number", + complex = "a complex number", + character = if (nzchar(x)) "a string" else "\"\"", + raw = "a raw value", + .rlang_stop_unexpected_typeof(x) + )) + } + + if (length(x) == 0) { + return(switch( + typeof(x), + logical = "an empty logical vector", + integer = "an empty integer vector", + double = "an empty numeric vector", + complex = "an empty complex vector", + character = "an empty character vector", + raw = "an empty raw vector", + list = "an empty list", + .rlang_stop_unexpected_typeof(x) + )) + } + } + + vec_type_friendly(x) +} + +vec_type_friendly <- function(x, length = FALSE) { + if (!is_vector(x)) { + abort("`x` must be a vector.") + } + type <- typeof(x) + n_dim <- length(dim(x)) + + add_length <- function(type) { + if (length && !n_dim) { + paste0(type, sprintf(" of length %s", length(x))) + } else { + type + } + } + + if (type == "list") { + if (n_dim < 2) { + return(add_length("a list")) + } else if (is.data.frame(x)) { + return("a data frame") + } else if (n_dim == 2) { + return("a list matrix") + } else { + return("a list array") + } + } + + type <- switch( + type, + logical = "a logical %s", + integer = "an integer %s", + numeric = , + double = "a double %s", + complex = "a complex %s", + character = "a character %s", + raw = "a raw %s", + type = paste0("a ", type, " %s") + ) + + if (n_dim < 2) { + kind <- "vector" + } else if (n_dim == 2) { + kind <- "matrix" + } else { + kind <- "array" + } + out <- sprintf(type, kind) + + if (n_dim >= 2) { + out + } else { + add_length(out) + } +} + +.rlang_as_friendly_type <- function(type) { + switch( + type, + + list = "a list", + + NULL = "`NULL`", + environment = "an environment", + externalptr = "a pointer", + weakref = "a weak reference", + S4 = "an S4 object", + + name = , + symbol = "a symbol", + language = "a call", + pairlist = "a pairlist node", + expression = "an expression vector", + + char = "an internal string", + promise = "an internal promise", + ... = "an internal dots object", + any = "an internal `any` object", + bytecode = "an internal bytecode object", + + primitive = , + builtin = , + special = "a primitive function", + closure = "a function", + + type + ) +} + +.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { + abort( + sprintf("Unexpected type <%s>.", typeof(x)), + call = call + ) +} + +#' Return OO type +#' @param x Any R object. +#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, +#' `"R6"`, or `"S7"`. +#' @noRd +obj_type_oo <- function(x) { + if (!is.object(x)) { + return("bare") + } + + class <- inherits(x, c("R6", "S7_object"), which = TRUE) + + if (class[[1]]) { + "R6" + } else if (class[[2]]) { + "S7" + } else if (isS4(x)) { + "S4" + } else { + "S3" + } +} + +#' @param x The object type which does not conform to `what`. Its +#' `obj_type_friendly()` is taken and mentioned in the error message. +#' @param what The friendly expected type as a string. Can be a +#' character vector of expected types, in which case the error +#' message mentions all of them in an "or" enumeration. +#' @param show_value Passed to `value` argument of `obj_type_friendly()`. +#' @param ... Arguments passed to [abort()]. +#' @inheritParams args_error_context +#' @noRd +stop_input_type <- function(x, + what, + ..., + allow_na = FALSE, + allow_null = FALSE, + show_value = TRUE, + arg = caller_arg(x), + call = caller_env()) { + # From standalone-cli.R + cli <- env_get_list( + nms = c("format_arg", "format_code"), + last = topenv(), + default = function(x) sprintf("`%s`", x), + inherit = TRUE + ) + + if (allow_na) { + what <- c(what, cli$format_code("NA")) + } + if (allow_null) { + what <- c(what, cli$format_code("NULL")) + } + if (length(what)) { + what <- oxford_comma(what) + } + if (inherits(arg, "AsIs")) { + format_arg <- identity + } else { + format_arg <- cli$format_arg + } + + message <- sprintf( + "%s must be %s, not %s.", + format_arg(arg), + what, + obj_type_friendly(x, value = show_value) + ) + + abort(message, ..., call = call, arg = arg) +} + +oxford_comma <- function(chr, sep = ", ", final = "or") { + n <- length(chr) + + if (n < 2) { + return(chr) + } + + head <- chr[seq_len(n - 1)] + last <- chr[n] + + head <- paste(head, collapse = sep) + + # Write a or b. But a, b, or c. + if (n > 2) { + paste0(head, sep, final, " ", last) + } else { + paste0(head, " ", final, " ", last) + } +} + +# nocov end diff --git a/R/compat-purrr.R b/R/import-standalone-purrr.R similarity index 84% rename from R/compat-purrr.R rename to R/import-standalone-purrr.R index 3afaa860..5a21be5a 100644 --- a/R/compat-purrr.R +++ b/R/import-standalone-purrr.R @@ -1,22 +1,42 @@ -# nocov start - compat-purrr.R -# Latest version: https://github.com/r-lib/rlang/blob/master/R/compat-purrr.R - +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-purrr.R +# Generated by: usethis::use_standalone("r-lib/rlang", "purrr") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-purrr.R +# last-updated: 2023-02-23 +# license: https://unlicense.org +# imports: rlang +# --- +# # This file provides a minimal shim to provide a purrr-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # -# Changelog: +# ## Changelog +# +# 2023-02-23: +# * Added `list_c()` +# +# 2022-06-07: +# * `transpose()` is now more consistent with purrr when inner names +# are not congruent (#1346). +# +# 2021-12-15: +# * `transpose()` now supports empty lists. +# +# 2021-05-21: +# * Fixed "object `x` not found" error in `imap()` (@mgirlich) +# # 2020-04-14: # * Removed `pluck*()` functions # * Removed `*_cpl()` functions # * Used `as_function()` to allow use of `~` # * Used `.` prefix for helpers # -# 2021-05-21: -# * Fixed "object `x` not found" error in `imap()` (@mgirlich) -# -# 2021-12-15: -# * `transpose()` now supports empty lists. +# nocov start map <- function(.x, .f, ...) { .f <- as_function(.f, env = global_env()) @@ -121,13 +141,26 @@ transpose <- function(.l) { if (!length(.l)) { return(.l) } + inner_names <- names(.l[[1]]) + if (is.null(inner_names)) { fields <- seq_along(.l[[1]]) } else { fields <- set_names(inner_names) + .l <- map(.l, function(x) { + if (is.null(names(x))) { + set_names(x, inner_names) + } else { + x + } + }) } + # This way missing fields are subsetted as `NULL` instead of causing + # an error + .l <- map(.l, as.list) + map(fields, function(i) { map(.l, .subset2, i) }) @@ -201,4 +234,8 @@ detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { idx } +list_c <- function(x) { + inject(c(!!!x)) +} + # nocov end diff --git a/tests/testthat/_snaps/eval-select.md b/tests/testthat/_snaps/eval-select.md index 13264cf1..e87b1a04 100644 --- a/tests/testthat/_snaps/eval-select.md +++ b/tests/testthat/_snaps/eval-select.md @@ -101,7 +101,7 @@ Output Error in `select_loc()`: - ! Predicate must return `TRUE` or `FALSE`, not `""`. + ! Predicate must return `TRUE` or `FALSE`, not the empty string "". # eval_select() produces correct backtraces diff --git a/tests/testthat/_snaps/helpers-where.md b/tests/testthat/_snaps/helpers-where.md index d5c5a282..dcbbacf7 100644 --- a/tests/testthat/_snaps/helpers-where.md +++ b/tests/testthat/_snaps/helpers-where.md @@ -17,10 +17,10 @@ select_loc(iris, where(~1)) Condition Error in `where()`: - ! Predicate must return `TRUE` or `FALSE`, not a number. + ! Predicate must return `TRUE` or `FALSE`, not the number 1. Code select_loc(iris, where(mean)) Condition Error in `where()`: - ! Predicate must return `TRUE` or `FALSE`, not a number. + ! Predicate must return `TRUE` or `FALSE`, not the number 5.84. diff --git a/tests/testthat/_snaps/helpers.md b/tests/testthat/_snaps/helpers.md index 2518cb3c..148d1114 100644 --- a/tests/testthat/_snaps/helpers.md +++ b/tests/testthat/_snaps/helpers.md @@ -6,5 +6,5 @@ Output Error in `one_of()`: - ! Input 1 must be a vector of column names, not an integer. + ! Input 1 must be a vector of column names, not the number 1. From 05149d8eb1741f31793a2b47a41e42f8ab7d4b43 Mon Sep 17 00:00:00 2001 From: olivroy Date: Wed, 23 Oct 2024 09:25:47 -0400 Subject: [PATCH 2/6] Tweak function signature to be more consistent --- NEWS.md | 5 +---- R/eval-relocate.R | 5 +++-- R/eval-select.R | 2 +- R/utils.R | 4 ++-- man/eval_relocate.Rd | 8 ++++---- 5 files changed, 11 insertions(+), 13 deletions(-) diff --git a/NEWS.md b/NEWS.md index 0b551a14..2d4592e2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,6 @@ # tidyselect (development version) - -* `eval_select(allow_empty = FALSE)` gains a new argument to yield a better error - message in case of empty selection (@olivroy, #327) -* `eval_select()` and `eval_relocate()` gain a new `error_arg` argument that can be specified to throw a better error message when `allow_empty = FALSE`. +* `eval_select()` and `eval_relocate()` gain a new `error_arg` argument that can be specified to throw a better error message when `allow_empty = FALSE` (@olivroy, #327). * `eval_select()` and `eval_relocate()` throw a classed error message when `allow_empty = FALSE` (@olivroy, #347). diff --git a/R/eval-relocate.R b/R/eval-relocate.R index 2d1360d5..7fe60da6 100644 --- a/R/eval-relocate.R +++ b/R/eval-relocate.R @@ -68,9 +68,9 @@ eval_relocate <- function(expr, allow_rename = TRUE, allow_empty = TRUE, allow_predicates = TRUE, - error_arg = NULL, before_arg = "before", after_arg = "after", + error_arg = NULL, env = caller_env(), error_call = caller_env()) { check_dots_empty() @@ -79,6 +79,7 @@ eval_relocate <- function(expr, data <- tidyselect_data_proxy(data) expr <- as_quosure(expr, env = env) + sel <- eval_select_impl( x = data, names = names(data), @@ -88,8 +89,8 @@ eval_relocate <- function(expr, allow_rename = allow_rename, allow_empty = allow_empty, allow_predicates = allow_predicates, + error_arg = error_arg, type = "relocate", - error_arg = error_arg, error_call = error_call ) diff --git a/R/eval-select.R b/R/eval-select.R index f57a436c..db1b2de7 100644 --- a/R/eval-select.R +++ b/R/eval-select.R @@ -201,8 +201,8 @@ eval_select_impl <- function(x, allow_rename = allow_rename, allow_empty = allow_empty, allow_predicates = allow_predicates, - type = type, error_arg = error_arg, + type = type, error_call = error_call ), type = type diff --git a/R/utils.R b/R/utils.R index c5b2895e..5edaba01 100644 --- a/R/utils.R +++ b/R/utils.R @@ -53,9 +53,9 @@ relocate_loc <- function(x, name_spec = NULL, allow_rename = TRUE, allow_empty = TRUE, - error_arg = NULL, before_arg = "before", after_arg = "after", + error_arg = NULL, error_call = current_env()) { check_dots_empty() @@ -68,9 +68,9 @@ relocate_loc <- function(x, name_spec = name_spec, allow_rename = allow_rename, allow_empty = allow_empty, - error_arg = error_arg, before_arg = before_arg, after_arg = after_arg, + error_arg = error_arg, error_call = error_call ) } diff --git a/man/eval_relocate.Rd b/man/eval_relocate.Rd index 5c08dc06..3fdb7caf 100644 --- a/man/eval_relocate.Rd +++ b/man/eval_relocate.Rd @@ -15,9 +15,9 @@ eval_relocate( allow_rename = TRUE, allow_empty = TRUE, allow_predicates = TRUE, - error_arg = NULL, before_arg = "before", after_arg = "after", + error_arg = NULL, env = caller_env(), error_call = caller_env() ) @@ -60,13 +60,13 @@ use predicates (i.e. in \code{where()}). If \code{FALSE}, will error if \code{ex predicate. Will automatically be set to \code{FALSE} if \code{data} does not support predicates (as determined by \code{\link[=tidyselect_data_has_predicates]{tidyselect_data_has_predicates()}}).} +\item{before_arg, after_arg}{Argument names for \code{before} and \code{after}. These +are used in error messages.} + \item{error_arg}{Argument names for \code{expr}. These are used in error messages. (You can use \code{"..."} if \code{expr = c(...)}). For now, this is used when \code{allow_empty = FALSE}.} -\item{before_arg, after_arg}{Argument names for \code{before} and \code{after}. These -are used in error messages.} - \item{env}{The environment in which to evaluate \code{expr}. Discarded if \code{expr} is a \link[rlang:enquo]{quosure}.} From e734c6c832fa5c66a5ce3ec2ad4337aefccb811e Mon Sep 17 00:00:00 2001 From: olivroy Date: Wed, 23 Oct 2024 09:26:50 -0400 Subject: [PATCH 3/6] Use regular snapshot tests with `cnd_class` --- tests/testthat/_snaps/eval-relocate.md | 75 ++++++++++--------------- tests/testthat/_snaps/eval-select.md | 55 ++++++++---------- tests/testthat/_snaps/eval-walk.md | 32 +++++------ tests/testthat/_snaps/helpers-vector.md | 35 +++++------- tests/testthat/_snaps/helpers.md | 6 +- tests/testthat/_snaps/vars-pull.md | 13 ++--- tests/testthat/test-eval-relocate.R | 63 ++++++++++++--------- tests/testthat/test-eval-select.R | 44 ++++++++------- tests/testthat/test-eval-walk.R | 31 +++++----- tests/testthat/test-helpers-vector.R | 22 ++++---- tests/testthat/test-helpers.R | 11 ++-- tests/testthat/test-vars-pull.R | 11 ++-- 12 files changed, 183 insertions(+), 215 deletions(-) diff --git a/tests/testthat/_snaps/eval-relocate.md b/tests/testthat/_snaps/eval-relocate.md index 5c531e7f..27e4304d 100644 --- a/tests/testthat/_snaps/eval-relocate.md +++ b/tests/testthat/_snaps/eval-relocate.md @@ -18,31 +18,27 @@ # can't relocate with out-of-bounds variables by default Code - (expect_error(relocate_loc(x, c))) - Output - + relocate_loc(x, c) + Condition Error in `relocate_loc()`: ! Can't relocate columns that don't exist. x Column `c` doesn't exist. Code - (expect_error(relocate_loc(x, c(1, 3)))) - Output - + relocate_loc(x, c(1, 3)) + Condition Error in `relocate_loc()`: ! Can't relocate columns that don't exist. i Location 3 doesn't exist. i There are only 2 columns. Code - (expect_error(relocate_loc(x, a, before = c))) - Output - + relocate_loc(x, a, before = c) + Condition Error in `relocate_loc()`: ! Can't select columns that don't exist. x Column `c` doesn't exist. Code - (expect_error(relocate_loc(x, a, after = c))) - Output - + relocate_loc(x, a, after = c) + Condition Error in `relocate_loc()`: ! Can't select columns that don't exist. x Column `c` doesn't exist. @@ -50,16 +46,14 @@ # can relocate with out-of-bounds variables in `expr` if `strict = FALSE` Code - (expect_error(relocate_loc(x, a, before = c, strict = FALSE))) - Output - + relocate_loc(x, a, before = c, strict = FALSE) + Condition Error in `relocate_loc()`: ! Can't select columns that don't exist. x Column `c` doesn't exist. Code - (expect_error(relocate_loc(x, a, after = c, strict = FALSE))) - Output - + relocate_loc(x, a, after = c, strict = FALSE) + Condition Error in `relocate_loc()`: ! Can't select columns that don't exist. x Column `c` doesn't exist. @@ -67,36 +61,31 @@ # can forbid rename syntax Code - (expect_error(relocate_loc(x, c(foo = b), allow_rename = FALSE))) - Output - + relocate_loc(x, c(foo = b), allow_rename = FALSE) + Condition Error in `relocate_loc()`: ! Can't rename variables in this context. Code - (expect_error(relocate_loc(x, c(b, foo = b), allow_rename = FALSE))) - Output - + relocate_loc(x, c(b, foo = b), allow_rename = FALSE) + Condition Error in `relocate_loc()`: ! Can't rename variables in this context. # can forbid empty selections Code - (expect_error(relocate_loc(x, allow_empty = FALSE, error_arg = "..."))) - Output - + relocate_loc(x, allow_empty = FALSE, error_arg = "...") + Condition Error in `relocate_loc()`: ! `...` must select at least one column. Code - (expect_error(relocate_loc(mtcars, integer(), allow_empty = FALSE))) - Output - + relocate_loc(mtcars, integer(), allow_empty = FALSE) + Condition Error in `relocate_loc()`: ! Must select at least one item. Code - (expect_error(relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE))) - Output - + relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE) + Condition Error in `relocate_loc()`: ! Must select at least one item. @@ -116,27 +105,23 @@ # `before` and `after` forbid renaming Code - (expect_error(relocate_loc(x, b, before = c(new = c)))) - Output - + relocate_loc(x, b, before = c(new = c)) + Condition Error in `relocate_loc()`: ! Can't rename variables when `before` is supplied. Code - (expect_error(relocate_loc(x, b, before = c(new = c), before_arg = ".before"))) - Output - + relocate_loc(x, b, before = c(new = c), before_arg = ".before") + Condition Error in `relocate_loc()`: ! Can't rename variables when `.before` is supplied. Code - (expect_error(relocate_loc(x, b, after = c(new = c)))) - Output - + relocate_loc(x, b, after = c(new = c)) + Condition Error in `relocate_loc()`: ! Can't rename variables when `after` is supplied. Code - (expect_error(relocate_loc(x, b, after = c(new = c), after_arg = ".after"))) - Output - + relocate_loc(x, b, after = c(new = c), after_arg = ".after") + Condition Error in `relocate_loc()`: ! Can't rename variables when `.after` is supplied. diff --git a/tests/testthat/_snaps/eval-select.md b/tests/testthat/_snaps/eval-select.md index e87b1a04..745e4c1d 100644 --- a/tests/testthat/_snaps/eval-select.md +++ b/tests/testthat/_snaps/eval-select.md @@ -2,49 +2,42 @@ Code x <- list(a = 1, b = 2, c = 3) - (expect_error(select_loc(x, "a", include = 1))) - Output - + select_loc(x, "a", include = 1) + Condition Error in `select_loc()`: ! `include` must be a character vector. Code - (expect_error(select_loc(x, "a", include = "d"))) - Output - + select_loc(x, "a", include = "d") + Condition Error in `select_loc()`: ! `include` must only include variables found in `data`. i Unknown variables: d Code - (expect_error(select_loc(x, "a", exclude = 1))) - Output - + select_loc(x, "a", exclude = 1) + Condition Error in `select_loc()`: ! `include` must be a character vector. # can forbid rename syntax (#178) Code - (expect_error(select_loc(mtcars, c(foo = cyl), allow_rename = FALSE))) - Output - + select_loc(mtcars, c(foo = cyl), allow_rename = FALSE) + Condition Error in `select_loc()`: ! Can't rename variables in this context. Code - (expect_error(select_loc(mtcars, c(cyl, foo = cyl), allow_rename = FALSE))) - Output - + select_loc(mtcars, c(cyl, foo = cyl), allow_rename = FALSE) + Condition Error in `select_loc()`: ! Can't rename variables in this context. Code - (expect_error(select_loc(mtcars, c(cyl, foo = mpg), allow_rename = FALSE))) - Output - + select_loc(mtcars, c(cyl, foo = mpg), allow_rename = FALSE) + Condition Error in `select_loc()`: ! Can't rename variables in this context. Code - (expect_error(select_loc(mtcars, c(foo = mpg, cyl), allow_rename = FALSE))) - Output - + select_loc(mtcars, c(foo = mpg, cyl), allow_rename = FALSE) + Condition Error in `select_loc()`: ! Can't rename variables in this context. @@ -87,9 +80,8 @@ # eval_select() errors mention correct calls Code - (expect_error(select_loc(mtcars, f()))) - Output - + select_loc(mtcars, f()) + Condition Error in `select_loc()`: Caused by error in `f()`: ! foo @@ -97,9 +89,8 @@ # predicate outputs are type-checked Code - (expect_error(select_loc(mtcars, function(x) ""))) - Output - + select_loc(mtcars, function(x) "") + Condition Error in `select_loc()`: ! Predicate must return `TRUE` or `FALSE`, not the empty string "". @@ -174,18 +165,16 @@ # eval_select() produces correct chained errors Code - (expect_error(select_loc(mtcars, 1 + ""))) - Output - + select_loc(mtcars, 1 + "") + Condition Error in `select_loc()`: i In argument: `1 + ""`. Caused by error in `1 + ""`: ! non-numeric argument to binary operator Code f <- (function() 1 + "") - (expect_error(select_loc(mtcars, f()))) - Output - + select_loc(mtcars, f()) + Condition Error in `select_loc()`: i In argument: `f()`. Caused by error in `1 + ""`: diff --git a/tests/testthat/_snaps/eval-walk.md b/tests/testthat/_snaps/eval-walk.md index 737c3b89..3069b1a0 100644 --- a/tests/testthat/_snaps/eval-walk.md +++ b/tests/testthat/_snaps/eval-walk.md @@ -83,10 +83,9 @@ Use of .data in tidyselect expressions was deprecated in tidyselect 1.2.0. i Please use `all_of(var)` (or `any_of(var)`) instead of `.data[[var]]` -# eval_walk() has informative messages +# eval_walk() warns when using a predicate without where() Code - # Using a predicate without where() warns invisible(select_loc(iris, is_integer)) Condition Warning: @@ -120,7 +119,7 @@ # Now: data %>% select(where(isTRUE)) Code - # Warning is not repeated + # Warning is not repeated invisible(select_loc(iris, is_integer)) Condition Warning: @@ -131,11 +130,12 @@ # Now: data %>% select(where(is_integer)) + +# eval_walk() errors when formula shorthand are not wrapped + Code - # formula shorthand must be wrapped - (expect_error(select_loc(mtcars, ~ is.numeric(.x)))) - Output - + select_loc(mtcars, ~ is.numeric(.x)) + Condition Error in `select_loc()`: ! Formula shorthand must be wrapped in `where()`. @@ -145,10 +145,8 @@ # Good data %>% select(where(~is.numeric(.x))) Code - (expect_error(select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || - is.character(.x)))) - Output - + select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x)) + Condition Error in `select_loc()`: ! Formula shorthand must be wrapped in `where()`. @@ -158,10 +156,9 @@ # Good data %>% select(where(~is.numeric(.x) || is.factor(.x) || is.character(.x))) Code - (expect_error(select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || - is.character(.x) || is.numeric(.x) || is.factor(.x) || is.character(.x)))) - Output - + select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x) || + is.numeric(.x) || is.factor(.x) || is.character(.x)) + Condition Error in `select_loc()`: ! Formula shorthand must be wrapped in `where()`. @@ -171,9 +168,8 @@ # Good data %>% select(where(~...)) Code - (expect_error(select_loc(mtcars, .data$"foo"))) - Output - + select_loc(mtcars, .data$"foo") + Condition Error in `select_loc()`: ! The RHS of `.data$rhs` must be a symbol. diff --git a/tests/testthat/_snaps/helpers-vector.md b/tests/testthat/_snaps/helpers-vector.md index 781f5e7a..8e92ea40 100644 --- a/tests/testthat/_snaps/helpers-vector.md +++ b/tests/testthat/_snaps/helpers-vector.md @@ -12,48 +12,42 @@ # all_of() and any_of() check their inputs Code - (expect_error(select_loc(letters2, all_of(NA)))) - Output - + select_loc(letters2, all_of(NA)) + Condition Error in `select_loc()`: ! Selections can't have missing values. Code - (expect_error(select_loc(letters2, any_of(NA)))) - Output - + select_loc(letters2, any_of(NA)) + Condition Error in `select_loc()`: ! Selections can't have missing values. Code - (expect_error(select_loc(letters2, all_of(TRUE)))) - Output - + select_loc(letters2, all_of(TRUE)) + Condition Error in `select_loc()`: i In argument: `all_of(TRUE)`. Caused by error in `all_of()`: ! Can't subset elements. x Subscript must be numeric or character, not `TRUE`. Code - (expect_error(select_loc(letters2, any_of(TRUE)))) - Output - + select_loc(letters2, any_of(TRUE)) + Condition Error in `select_loc()`: i In argument: `any_of(TRUE)`. Caused by error in `any_of()`: ! Can't subset elements. x Subscript must be numeric or character, not `TRUE`. Code - (expect_error(select_loc(letters2, any_of(is.factor)))) - Output - + select_loc(letters2, any_of(is.factor)) + Condition Error in `select_loc()`: i In argument: `any_of(is.factor)`. Caused by error in `any_of()`: ! Can't subset elements. x Subscript must be numeric or character, not a function. Code - (expect_error(select_loc(letters2, all_of(is.factor)))) - Output - + select_loc(letters2, all_of(is.factor)) + Condition Error in `select_loc()`: i In argument: `all_of(is.factor)`. Caused by error in `all_of()`: @@ -63,9 +57,8 @@ # any_of() errors out of context Code - (expect_error(any_of())) - Output - + any_of() + Condition Error: ! `any_of()` must be used within a *selecting* function. i See for details. diff --git a/tests/testthat/_snaps/helpers.md b/tests/testthat/_snaps/helpers.md index 148d1114..36e407aa 100644 --- a/tests/testthat/_snaps/helpers.md +++ b/tests/testthat/_snaps/helpers.md @@ -1,10 +1,8 @@ # one_of gives useful errors Code - (expect_error(one_of(1L, .vars = c("x", "y")), class = "vctrs_error_incompatible_index_type") - ) - Output - + one_of(1L, .vars = c("x", "y")) + Condition Error in `one_of()`: ! Input 1 must be a vector of column names, not the number 1. diff --git a/tests/testthat/_snaps/vars-pull.md b/tests/testthat/_snaps/vars-pull.md index 6268d6f8..c03b564a 100644 --- a/tests/testthat/_snaps/vars-pull.md +++ b/tests/testthat/_snaps/vars-pull.md @@ -79,22 +79,19 @@ Error in `f()`: ! `var` is absent but must be supplied. -# vars_pull() has informative errors +# vars_pull() are base errors Code - # # vars_pull() instruments base errors - (expect_error(vars_pull(letters, foobar), "")) - Output - + vars_pull(letters, foobar) + Condition Error: ! object 'foobar' not found # vars_pull() errors mention correct calls Code - (expect_error(vars_pull(letters, f()))) - Output - + vars_pull(letters, f()) + Condition Error in `f()`: ! foo diff --git a/tests/testthat/test-eval-relocate.R b/tests/testthat/test-eval-relocate.R index 02cc6e2a..9598e356 100644 --- a/tests/testthat/test-eval-relocate.R +++ b/tests/testthat/test-eval-relocate.R @@ -128,12 +128,14 @@ test_that("can't supply both `before` and `after`", { test_that("can't relocate with out-of-bounds variables by default", { x <- c(a = 1, b = 2) - expect_snapshot({ - (expect_error(relocate_loc(x, c))) - (expect_error(relocate_loc(x, c(1, 3)))) - (expect_error(relocate_loc(x, a, before = c))) - (expect_error(relocate_loc(x, a, after = c))) - }) + expect_snapshot(error = TRUE, { + relocate_loc(x, c) + relocate_loc(x, c(1, 3)) + relocate_loc(x, a, before = c) + relocate_loc(x, a, after = c) + }, + cnd_class = TRUE + ) }) test_that("can relocate with out-of-bounds variables in `expr` if `strict = FALSE`", { @@ -143,10 +145,12 @@ test_that("can relocate with out-of-bounds variables in `expr` if `strict = FALS expect_identical(relocate_loc(x, c(d = b, e = c), strict = FALSE), c(d = 2L, a = 1L)) # But still not with OOB variables in `before` or `after` - expect_snapshot({ - (expect_error(relocate_loc(x, a, before = c, strict = FALSE))) - (expect_error(relocate_loc(x, a, after = c, strict = FALSE))) - }) + expect_snapshot(error = TRUE, { + relocate_loc(x, a, before = c, strict = FALSE) + relocate_loc(x, a, after = c, strict = FALSE) + }, + cnd_class = TRUE + ) }) test_that("accepts name spec", { @@ -165,10 +169,12 @@ test_that("accepts name spec", { test_that("can forbid rename syntax", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot({ - (expect_error(relocate_loc(x, c(foo = b), allow_rename = FALSE))) - (expect_error(relocate_loc(x, c(b, foo = b), allow_rename = FALSE))) - }) + expect_snapshot(error = TRUE, { + relocate_loc(x, c(foo = b), allow_rename = FALSE) + relocate_loc(x, c(b, foo = b), allow_rename = FALSE) + }, + cnd_class = TRUE + ) expect_named(relocate_loc(x, c(c, b), allow_rename = FALSE), c("c", "b", "a")) }) @@ -176,32 +182,35 @@ test_that("can forbid rename syntax", { test_that("can forbid empty selections", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot({ - (expect_error(relocate_loc(x, allow_empty = FALSE, error_arg = "..."))) - (expect_error(relocate_loc(mtcars, integer(), allow_empty = FALSE))) - (expect_error(relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE))) + expect_snapshot(error = TRUE, { + relocate_loc(x, allow_empty = FALSE, error_arg = "...") + relocate_loc(mtcars, integer(), allow_empty = FALSE) + relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE) }) }) test_that("can forbid empty selections", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot( - error = TRUE, { + expect_snapshot(error = TRUE, { relocate_loc(mtcars, before = integer(), allow_empty = FALSE) relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE) - }, cnd_class = TRUE) + }, + cnd_class = TRUE + ) }) test_that("`before` and `after` forbid renaming", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot({ - (expect_error(relocate_loc(x, b, before = c(new = c)))) - (expect_error(relocate_loc(x, b, before = c(new = c), before_arg = ".before"))) + expect_snapshot(error = TRUE, { + relocate_loc(x, b, before = c(new = c)) + relocate_loc(x, b, before = c(new = c), before_arg = ".before") - (expect_error(relocate_loc(x, b, after = c(new = c)))) - (expect_error(relocate_loc(x, b, after = c(new = c), after_arg = ".after"))) - }) + relocate_loc(x, b, after = c(new = c)) + relocate_loc(x, b, after = c(new = c), after_arg = ".after") + }, + cnd_class = TRUE + ) }) diff --git a/tests/testthat/test-eval-select.R b/tests/testthat/test-eval-select.R index 9a3721e9..57d2d653 100644 --- a/tests/testthat/test-eval-select.R +++ b/tests/testthat/test-eval-select.R @@ -53,12 +53,14 @@ test_that("included variables added to front", { }) test_that("include and exclude validate their inputs", { - expect_snapshot({ + expect_snapshot(error = TRUE, { x <- list(a = 1, b = 2, c = 3) - (expect_error(select_loc(x, "a", include = 1))) - (expect_error(select_loc(x, "a", include = "d"))) - (expect_error(select_loc(x, "a", exclude = 1))) - }) + select_loc(x, "a", include = 1) + select_loc(x, "a", include = "d") + select_loc(x, "a", exclude = 1) + }, + cnd_class = TRUE + ) }) test_that("variables are excluded with non-strict `any_of()`", { @@ -87,12 +89,14 @@ test_that("result is named even with constant inputs (#173)", { }) test_that("can forbid rename syntax (#178)", { - expect_snapshot({ - (expect_error(select_loc(mtcars, c(foo = cyl), allow_rename = FALSE))) - (expect_error(select_loc(mtcars, c(cyl, foo = cyl), allow_rename = FALSE))) - (expect_error(select_loc(mtcars, c(cyl, foo = mpg), allow_rename = FALSE))) - (expect_error(select_loc(mtcars, c(foo = mpg, cyl), allow_rename = FALSE))) - }) + expect_snapshot(error = TRUE, { + select_loc(mtcars, c(foo = cyl), allow_rename = FALSE) + select_loc(mtcars, c(cyl, foo = cyl), allow_rename = FALSE) + select_loc(mtcars, c(cyl, foo = mpg), allow_rename = FALSE) + select_loc(mtcars, c(foo = mpg, cyl), allow_rename = FALSE) + }, + cnd_class = TRUE + ) expect_named(select_loc(mtcars, starts_with("c") | all_of("am"), allow_rename = FALSE), c("cyl", "carb", "am")) }) @@ -115,13 +119,11 @@ test_that("can forbid empty selections with informative error", { test_that("eval_select() errors mention correct calls", { f <- function() stop("foo") - expect_snapshot((expect_error(select_loc(mtcars, f())))) + expect_snapshot(select_loc(mtcars, f()), error = TRUE, cnd_class = TRUE) }) test_that("predicate outputs are type-checked", { - expect_snapshot({ - (expect_error(select_loc(mtcars, function(x) ""))) - }) + expect_snapshot(select_loc(mtcars, function(x) ""), error = TRUE, cnd_class = TRUE) }) test_that("eval_select() produces correct backtraces", { @@ -130,7 +132,7 @@ test_that("eval_select() produces correct backtraces", { h <- function(base) if (base) stop("foo") else abort("foo") local_options( - rlang_trace_trop_env = current_env(), + rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) @@ -141,12 +143,14 @@ test_that("eval_select() produces correct backtraces", { }) test_that("eval_select() produces correct chained errors", { - expect_snapshot({ - (expect_error(select_loc(mtcars, 1 + ""))) + expect_snapshot(error = TRUE, { + select_loc(mtcars, 1 + "") f <- function() 1 + "" - (expect_error(select_loc(mtcars, f()))) - }) + select_loc(mtcars, f()) + }, + cnd_class = TRUE + ) }) test_that("can select with predicate when `allow_rename` is `FALSE` (#225)", { diff --git a/tests/testthat/test-eval-walk.R b/tests/testthat/test-eval-walk.R index 41be4621..627c9e7c 100644 --- a/tests/testthat/test-eval-walk.R +++ b/tests/testthat/test-eval-walk.R @@ -249,7 +249,7 @@ test_that(".data in env-expression has the lexical definition", { .data <- mtcars quo({ stopifnot(identical(.data, mtcars)); NULL}) }) - expect_error(select_loc(mtcars, !!quo), regexp = NA) + expect_no_error(select_loc(mtcars, !!quo)) }) test_that("binary `/` is short for set difference", { @@ -260,8 +260,6 @@ test_that("binary `/` is short for set difference", { }) test_that("can select names with unrepresentable characters", { - skip_if_not_installed("rlang", "0.4.2.9000") - # R now emits a warning when converting to symbol. Since Windows # gained UTF-8 support, supporting unrepresentable characters is no # longer necessary. @@ -301,26 +299,29 @@ test_that("eval_sym() still supports predicate functions starting with `is`", { expect_identical(select_loc(iris, isTRUE), select_loc(iris, where(isTRUE))) }) -test_that("eval_walk() has informative messages", { +test_that("eval_walk() warns when using a predicate without where()", { expect_snapshot({ - "Using a predicate without where() warns" invisible(select_loc(iris, is_integer)) invisible(select_loc(iris, is.numeric)) invisible(select_loc(iris, isTRUE)) - - "Warning is not repeated" + "Warning is not repeated " invisible(select_loc(iris, is_integer)) - - "formula shorthand must be wrapped" - (expect_error(select_loc(mtcars, ~ is.numeric(.x)))) - (expect_error(select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x)))) - (expect_error(select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x) || - is.numeric(.x) || is.factor(.x) || is.character(.x)))) - - (expect_error(select_loc(mtcars, .data$"foo"))) + }) }) +test_that("eval_walk() errors when formula shorthand are not wrapped", { + expect_snapshot(error = TRUE, { + select_loc(mtcars, ~ is.numeric(.x)) + select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x)) + select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x) || + is.numeric(.x) || is.factor(.x) || is.character(.x)) + select_loc(mtcars, .data$"foo") + }, + cnd_class = TRUE + ) +}) + test_that("can forbid empty selection", { expect_snapshot(error = TRUE, { ensure_named(integer(), allow_empty = FALSE) diff --git a/tests/testthat/test-helpers-vector.R b/tests/testthat/test-helpers-vector.R index b5f98d5f..e17c37a2 100644 --- a/tests/testthat/test-helpers-vector.R +++ b/tests/testthat/test-helpers-vector.R @@ -38,22 +38,22 @@ test_that("any_of() is lax", { }) test_that("all_of() and any_of() check their inputs", { - expect_snapshot({ - (expect_error(select_loc(letters2, all_of(NA)))) - (expect_error(select_loc(letters2, any_of(NA)))) + expect_snapshot(error = TRUE, { + select_loc(letters2, all_of(NA)) + select_loc(letters2, any_of(NA)) - (expect_error(select_loc(letters2, all_of(TRUE)))) - (expect_error(select_loc(letters2, any_of(TRUE)))) + select_loc(letters2, all_of(TRUE)) + select_loc(letters2, any_of(TRUE)) - (expect_error(select_loc(letters2, any_of(is.factor)))) - (expect_error(select_loc(letters2, all_of(is.factor)))) - }) + select_loc(letters2, any_of(is.factor)) + select_loc(letters2, all_of(is.factor)) + }, + cnd_class = TRUE + ) }) test_that("any_of() errors out of context", { - expect_snapshot({ - (expect_error(any_of())) - }) + expect_snapshot(any_of(), error = TRUE, cnd_class = TRUE) }) test_that("all_of() is deprecated out of context (#269)", { diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 8a29585d..08e6411c 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -1,11 +1,10 @@ test_that("one_of gives useful errors", { - expect_snapshot({ - (expect_error( - one_of(1L, .vars = c("x", "y")), - class = "vctrs_error_incompatible_index_type" - )) - }) + expect_snapshot(error = TRUE, { + one_of(1L, .vars = c("x", "y")) + }, + cnd_class = TRUE + ) }) test_that("one_of tolerates but warns for unknown columns", { diff --git a/tests/testthat/test-vars-pull.R b/tests/testthat/test-vars-pull.R index ee379cea..922b17a9 100644 --- a/tests/testthat/test-vars-pull.R +++ b/tests/testthat/test-vars-pull.R @@ -98,16 +98,13 @@ test_that("can pull with negative values", { expect_identical(vars_pull(letters, -3), "x") }) -test_that("vars_pull() has informative errors", { - expect_snapshot({ - "# vars_pull() instruments base errors" - (expect_error(vars_pull(letters, foobar), "")) - }) +test_that("vars_pull() are base errors", { + expect_snapshot(vars_pull(letters, foobar), error = TRUE, cnd_class = TRUE) }) test_that("vars_pull() errors mention correct calls", { f <- function() stop("foo") - expect_snapshot((expect_error(vars_pull(letters, f())))) + expect_snapshot(vars_pull(letters, f()), error = TRUE, cnd_class = TRUE) }) test_that("vars_pull() produces correct backtraces", { @@ -116,7 +113,7 @@ test_that("vars_pull() produces correct backtraces", { h <- function(base) if (base) stop("foo") else abort("foo") local_options( - rlang_trace_trop_env = current_env(), + rlang_trace_top_env = current_env(), rlang_trace_format_srcrefs = FALSE ) From a7610113790456d37883f86063fabc26eccf5093 Mon Sep 17 00:00:00 2001 From: olivroy Date: Wed, 23 Oct 2024 10:21:53 -0400 Subject: [PATCH 4/6] use standard type checking --- R/eval-select.R | 10 +- R/helpers-misc.R | 5 +- R/import-standalone-types-check.R | 554 ++++++++++++++++++++++++++ R/utils.R | 8 +- R/vars.R | 4 +- tests/testthat/_snaps/eval-select.md | 4 +- tests/testthat/_snaps/helpers-misc.md | 4 +- 7 files changed, 565 insertions(+), 24 deletions(-) create mode 100644 R/import-standalone-types-check.R diff --git a/R/eval-select.R b/R/eval-select.R index db1b2de7..63b461fb 100644 --- a/R/eval-select.R +++ b/R/eval-select.R @@ -209,15 +209,13 @@ eval_select_impl <- function(x, ) if (length(include) > 0) { - if (!is.character(include)) { - cli::cli_abort("{.arg include} must be a character vector.", call = error_call) - } + check_character(include, call = error_call) missing <- setdiff(include, names) if (length(missing) > 0) { cli::cli_abort(c( "{.arg include} must only include variables found in {.arg data}.", - i = "Unknown variables: {.and {missing}}" + i = "Unknown variables: {.var {missing}}" ), call = error_call) } @@ -228,9 +226,7 @@ eval_select_impl <- function(x, } if (length(exclude) > 0) { - if (!is.character(exclude)) { - cli::cli_abort("{.arg include} must be a character vector.", call = error_call) - } + check_character(exclude, call = error_call) to_exclude <- vctrs::vec_match(intersect(exclude, names), names) out <- out[!out %in% to_exclude] diff --git a/R/helpers-misc.R b/R/helpers-misc.R index c12f702d..d3017300 100644 --- a/R/helpers-misc.R +++ b/R/helpers-misc.R @@ -61,10 +61,7 @@ everything <- function(vars = NULL) { #' @export #' @param offset Set it to `n` to select the nth var from the end. last_col <- function(offset = 0L, vars = NULL) { - if (!is_integerish(offset, n = 1)) { - not <- obj_type_friendly(offset) - cli::cli_abort("{.arg offset} must be a single integer, not {not}.") - } + check_number_whole(offset) vars <- vars %||% peek_vars(fn = "last_col") n <- length(vars) diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 00000000..ef8c5a1d --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,554 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R +# Generated by: usethis::use_standalone("r-lib/rlang", "types-check") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-types-check.R +# last-updated: 2023-03-13 +# license: https://unlicense.org +# dependencies: standalone-obj-type.R +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 2024-08-15: +# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) +# +# 2023-03-13: +# - Improved error messages of number checkers (@teunbrand) +# - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). +# - Added `check_data_frame()` (@mgirlich). +# +# 2023-03-07: +# - Added dependency on rlang (>= 1.1.0). +# +# 2023-02-15: +# - Added `check_logical()`. +# +# - `check_bool()`, `check_number_whole()`, and +# `check_number_decimal()` are now implemented in C. +# +# - For efficiency, `check_number_whole()` and +# `check_number_decimal()` now take a `NULL` default for `min` and +# `max`. This makes it possible to bypass unnecessary type-checking +# and comparisons in the default case of no bounds checks. +# +# 2022-10-07: +# - `check_number_whole()` and `_decimal()` no longer treat +# non-numeric types such as factors or dates as numbers. Numeric +# types are detected with `is.numeric()`. +# +# 2022-10-04: +# - Added `check_name()` that forbids the empty string. +# `check_string()` allows the empty string by default. +# +# 2022-09-28: +# - Removed `what` arguments. +# - Added `allow_na` and `allow_null` arguments. +# - Added `allow_decimal` and `allow_infinite` arguments. +# - Improved errors with absent arguments. +# +# +# 2022-09-16: +# - Unprefixed usage of rlang functions with `rlang::` to +# avoid onLoad issues when called from rlang (#1482). +# +# 2022-08-11: +# - Added changelog. +# +# nocov start + +# Scalars ----------------------------------------------------------------- + +.standalone_types_check_dot_call <- .Call + +check_bool <- function(x, + ..., + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x) && .standalone_types_check_dot_call(ffi_standalone_is_bool_1.0.7, x, allow_na, allow_null)) { + return(invisible(NULL)) + } + + stop_input_type( + x, + c("`TRUE`", "`FALSE`"), + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_string <- function(x, + ..., + allow_empty = TRUE, + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + is_string <- .rlang_check_is_string( + x, + allow_empty = allow_empty, + allow_na = allow_na, + allow_null = allow_null + ) + if (is_string) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a single string", + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +.rlang_check_is_string <- function(x, + allow_empty, + allow_na, + allow_null) { + if (is_string(x)) { + if (allow_empty || !is_string(x, "")) { + return(TRUE) + } + } + + if (allow_null && is_null(x)) { + return(TRUE) + } + + if (allow_na && (identical(x, NA) || identical(x, na_chr))) { + return(TRUE) + } + + FALSE +} + +check_name <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + is_string <- .rlang_check_is_string( + x, + allow_empty = FALSE, + allow_na = FALSE, + allow_null = allow_null + ) + if (is_string) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a valid name", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +IS_NUMBER_true <- 0 +IS_NUMBER_false <- 1 +IS_NUMBER_oob <- 2 + +check_number_decimal <- function(x, + ..., + min = NULL, + max = NULL, + allow_infinite = TRUE, + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if (0 == (exit_code <- .standalone_types_check_dot_call( + ffi_standalone_check_number_1.0.7, + x, + allow_decimal = TRUE, + min, + max, + allow_infinite, + allow_na, + allow_null + ))) { + return(invisible(NULL)) + } + + .stop_not_number( + x, + ..., + exit_code = exit_code, + allow_decimal = TRUE, + min = min, + max = max, + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_number_whole <- function(x, + ..., + min = NULL, + max = NULL, + allow_infinite = FALSE, + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if (0 == (exit_code <- .standalone_types_check_dot_call( + ffi_standalone_check_number_1.0.7, + x, + allow_decimal = FALSE, + min, + max, + allow_infinite, + allow_na, + allow_null + ))) { + return(invisible(NULL)) + } + + .stop_not_number( + x, + ..., + exit_code = exit_code, + allow_decimal = FALSE, + min = min, + max = max, + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +.stop_not_number <- function(x, + ..., + exit_code, + allow_decimal, + min, + max, + allow_na, + allow_null, + arg, + call) { + if (allow_decimal) { + what <- "a number" + } else { + what <- "a whole number" + } + + if (exit_code == IS_NUMBER_oob) { + min <- min %||% -Inf + max <- max %||% Inf + + if (min > -Inf && max < Inf) { + what <- sprintf("%s between %s and %s", what, min, max) + } else if (x < min) { + what <- sprintf("%s larger than or equal to %s", what, min) + } else if (x > max) { + what <- sprintf("%s smaller than or equal to %s", what, max) + } else { + abort("Unexpected state in OOB check", .internal = TRUE) + } + } + + stop_input_type( + x, + what, + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_symbol <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a symbol", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_arg <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an argument name", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_call <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_call(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a defused call", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_environment <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_environment(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an environment", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_function <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_function(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a function", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_closure <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_closure(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an R function", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_formula <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_formula(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a formula", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + + +# Vectors ----------------------------------------------------------------- + +# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` + +check_character <- function(x, + ..., + allow_na = TRUE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + + if (!missing(x)) { + if (is_character(x)) { + if (!allow_na && any(is.na(x))) { + abort( + sprintf("`%s` can't contain NA values.", arg), + arg = arg, + call = call + ) + } + + return(invisible(NULL)) + } + + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a character vector", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_logical <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_logical(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a logical vector", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_data_frame <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is.data.frame(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a data frame", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +# nocov end diff --git a/R/utils.R b/R/utils.R index 5edaba01..6f9654fa 100644 --- a/R/utils.R +++ b/R/utils.R @@ -84,9 +84,7 @@ any_valid_names <- function(nms) { } are_empty_name <- function(nms) { - if (!is_character(nms)) { - abort("Expected a character vector") - } + check_character(nms) nms == "" | is.na(nms) } @@ -153,9 +151,7 @@ quo_set_expr2 <- function(x, value, default) { # Always returns a fresh non-shared call call_expand_dots <- function(call, env) { - if (!is_call(call)) { - abort("`call` must be a call.") - } + check_call(call) call <- duplicate(call, shallow = TRUE) diff --git a/R/vars.R b/R/vars.R index d7851931..3d5fbbb7 100644 --- a/R/vars.R +++ b/R/vars.R @@ -190,9 +190,7 @@ has_vars <- function() { } vars_validate <- function(vars) { - if (!is_character(vars)) { - abort("`vars` must be a character vector") - } + check_character(vars) # Named `vars` makes it harder to implement select helpers unname(vars) diff --git a/tests/testthat/_snaps/eval-select.md b/tests/testthat/_snaps/eval-select.md index 745e4c1d..2e0f7921 100644 --- a/tests/testthat/_snaps/eval-select.md +++ b/tests/testthat/_snaps/eval-select.md @@ -5,7 +5,7 @@ select_loc(x, "a", include = 1) Condition Error in `select_loc()`: - ! `include` must be a character vector. + ! `include` must be a character vector, not the number 1. Code select_loc(x, "a", include = "d") Condition @@ -16,7 +16,7 @@ select_loc(x, "a", exclude = 1) Condition Error in `select_loc()`: - ! `include` must be a character vector. + ! `exclude` must be a character vector, not the number 1. # can forbid rename syntax (#178) diff --git a/tests/testthat/_snaps/helpers-misc.md b/tests/testthat/_snaps/helpers-misc.md index 8f58d7c1..8310ec85 100644 --- a/tests/testthat/_snaps/helpers-misc.md +++ b/tests/testthat/_snaps/helpers-misc.md @@ -4,7 +4,7 @@ last_col(Inf, letters[1:3]) Condition Error in `last_col()`: - ! `offset` (Inf) must be smaller than the number of columns (3). + ! `offset` must be a whole number, not `Inf`. Code last_col(3, letters[1:3]) Condition @@ -19,5 +19,5 @@ last_col(1:2, letters[1:3]) Condition Error in `last_col()`: - ! `offset` must be a single integer, not an integer vector. + ! `offset` must be a whole number, not an integer vector. From 9938eb54d14f9df91e1da15d66720545f775757c Mon Sep 17 00:00:00 2001 From: olivroy Date: Wed, 23 Oct 2024 10:36:53 -0400 Subject: [PATCH 5/6] Respect `error_arg` with `allow_rename = FALSE` --- NEWS.md | 2 +- R/eval-select.R | 2 +- R/eval-walk.R | 21 ++++++++++++++++----- man/eval_relocate.Rd | 2 +- man/eval_select.Rd | 2 +- tests/testthat/_snaps/eval-relocate.md | 6 ++++++ tests/testthat/_snaps/eval-select.md | 8 +++++++- tests/testthat/test-eval-relocate.R | 3 +++ tests/testthat/test-eval-select.R | 1 + 9 files changed, 37 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 2d4592e2..497fd6e5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ # tidyselect (development version) -* `eval_select()` and `eval_relocate()` gain a new `error_arg` argument that can be specified to throw a better error message when `allow_empty = FALSE` (@olivroy, #327). +* `eval_select()` and `eval_relocate()` gain a new `error_arg` argument that can be specified to throw a better error message when `allow_empty = FALSE` or `allow_rename = FALSE` (@olivroy, #327). * `eval_select()` and `eval_relocate()` throw a classed error message when `allow_empty = FALSE` (@olivroy, #347). diff --git a/R/eval-select.R b/R/eval-select.R index 63b461fb..81272b77 100644 --- a/R/eval-select.R +++ b/R/eval-select.R @@ -45,7 +45,7 @@ #' support predicates (as determined by [tidyselect_data_has_predicates()]). #' @param error_arg Argument names for `expr`. These #' are used in error messages. (You can use `"..."` if `expr = c(...)`). -#' For now, this is used when `allow_empty = FALSE`. +#' For now, this is used when `allow_empty = FALSE` or `allow_rename = FALSE`. #' @inheritParams rlang::args_dots_empty #' #' @return A named vector of numeric locations, one for each of the diff --git a/R/eval-walk.R b/R/eval-walk.R index 5923a839..170dee73 100644 --- a/R/eval-walk.R +++ b/R/eval-walk.R @@ -110,11 +110,22 @@ ensure_named <- function(pos, check_empty(pos, allow_empty, error_arg, call = call) if (!allow_rename && any(names2(pos) != "")) { - cli::cli_abort( - "Can't rename variables in this context.", - class = "tidyselect:::error_disallowed_rename", - call = call - ) + if (is.null(error_arg)) { + cli::cli_abort( + "Can't rename variables in this context.", + class = "tidyselect:::error_disallowed_rename", + call = call + ) + } else { + cli::cli_abort(c( + "Can't rename variables in this context.", + i = "{.arg {error_arg}} can't be renamed." + ), + class = "tidyselect:::error_disallowed_rename", + call = call + ) + } + } nms <- names(pos) <- names2(pos) diff --git a/man/eval_relocate.Rd b/man/eval_relocate.Rd index 3fdb7caf..c4608787 100644 --- a/man/eval_relocate.Rd +++ b/man/eval_relocate.Rd @@ -65,7 +65,7 @@ are used in error messages.} \item{error_arg}{Argument names for \code{expr}. These are used in error messages. (You can use \code{"..."} if \code{expr = c(...)}). -For now, this is used when \code{allow_empty = FALSE}.} +For now, this is used when \code{allow_empty = FALSE} or \code{allow_rename = FALSE}.} \item{env}{The environment in which to evaluate \code{expr}. Discarded if \code{expr} is a \link[rlang:enquo]{quosure}.} diff --git a/man/eval_select.Rd b/man/eval_select.Rd index 19d85b09..635f7790 100644 --- a/man/eval_select.Rd +++ b/man/eval_select.Rd @@ -78,7 +78,7 @@ selection.} \item{error_arg}{Argument names for \code{expr}. These are used in error messages. (You can use \code{"..."} if \code{expr = c(...)}). -For now, this is used when \code{allow_empty = FALSE}.} +For now, this is used when \code{allow_empty = FALSE} or \code{allow_rename = FALSE}.} } \value{ A named vector of numeric locations, one for each of the diff --git a/tests/testthat/_snaps/eval-relocate.md b/tests/testthat/_snaps/eval-relocate.md index 27e4304d..0defd0d7 100644 --- a/tests/testthat/_snaps/eval-relocate.md +++ b/tests/testthat/_snaps/eval-relocate.md @@ -70,6 +70,12 @@ Condition Error in `relocate_loc()`: ! Can't rename variables in this context. + Code + relocate_loc(x, c(b, foo = b), allow_rename = FALSE, error_arg = "...") + Condition + Error in `relocate_loc()`: + ! Can't rename variables in this context. + i `...` can't be renamed. # can forbid empty selections diff --git a/tests/testthat/_snaps/eval-select.md b/tests/testthat/_snaps/eval-select.md index 2e0f7921..03af845f 100644 --- a/tests/testthat/_snaps/eval-select.md +++ b/tests/testthat/_snaps/eval-select.md @@ -11,7 +11,7 @@ Condition Error in `select_loc()`: ! `include` must only include variables found in `data`. - i Unknown variables: d + i Unknown variables: `d` Code select_loc(x, "a", exclude = 1) Condition @@ -40,6 +40,12 @@ Condition Error in `select_loc()`: ! Can't rename variables in this context. + Code + select_loc(mtcars, c(foo = mpg, cyl), error_arg = "x", allow_rename = FALSE) + Condition + Error in `select_loc()`: + ! Can't rename variables in this context. + i `x` can't be renamed. # can forbid empty selections diff --git a/tests/testthat/test-eval-relocate.R b/tests/testthat/test-eval-relocate.R index 9598e356..8097344b 100644 --- a/tests/testthat/test-eval-relocate.R +++ b/tests/testthat/test-eval-relocate.R @@ -172,6 +172,8 @@ test_that("can forbid rename syntax", { expect_snapshot(error = TRUE, { relocate_loc(x, c(foo = b), allow_rename = FALSE) relocate_loc(x, c(b, foo = b), allow_rename = FALSE) + relocate_loc(x, c(b, foo = b), allow_rename = FALSE, error_arg = "...") + }, cnd_class = TRUE ) @@ -184,6 +186,7 @@ test_that("can forbid empty selections", { expect_snapshot(error = TRUE, { relocate_loc(x, allow_empty = FALSE, error_arg = "...") + relocate_loc(mtcars, integer(), allow_empty = FALSE) relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE) }) diff --git a/tests/testthat/test-eval-select.R b/tests/testthat/test-eval-select.R index 57d2d653..e513d75b 100644 --- a/tests/testthat/test-eval-select.R +++ b/tests/testthat/test-eval-select.R @@ -94,6 +94,7 @@ test_that("can forbid rename syntax (#178)", { select_loc(mtcars, c(cyl, foo = cyl), allow_rename = FALSE) select_loc(mtcars, c(cyl, foo = mpg), allow_rename = FALSE) select_loc(mtcars, c(foo = mpg, cyl), allow_rename = FALSE) + select_loc(mtcars, c(foo = mpg, cyl), error_arg = "x", allow_rename = FALSE) }, cnd_class = TRUE ) From 972a2002469bd85885e7eb91a93725b0d8d70417 Mon Sep 17 00:00:00 2001 From: olivroy Date: Wed, 23 Oct 2024 14:35:15 -0400 Subject: [PATCH 6/6] Standardize on putting `cnd_class = TRUE` on the same line to make it easier to remove if they are judged as not useful for some tests, with a cleaner diff (i.e. no comma to remove) --- tests/testthat/test-eval-relocate.R | 31 +++++++++------------------- tests/testthat/test-eval-select.R | 20 +++++++----------- tests/testthat/test-eval-walk.R | 6 ++---- tests/testthat/test-helpers-vector.R | 6 ++---- tests/testthat/test-helpers.R | 6 ++---- 5 files changed, 23 insertions(+), 46 deletions(-) diff --git a/tests/testthat/test-eval-relocate.R b/tests/testthat/test-eval-relocate.R index 8097344b..79a885e2 100644 --- a/tests/testthat/test-eval-relocate.R +++ b/tests/testthat/test-eval-relocate.R @@ -128,14 +128,12 @@ test_that("can't supply both `before` and `after`", { test_that("can't relocate with out-of-bounds variables by default", { x <- c(a = 1, b = 2) - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { relocate_loc(x, c) relocate_loc(x, c(1, 3)) relocate_loc(x, a, before = c) relocate_loc(x, a, after = c) - }, - cnd_class = TRUE - ) + }) }) test_that("can relocate with out-of-bounds variables in `expr` if `strict = FALSE`", { @@ -145,12 +143,10 @@ test_that("can relocate with out-of-bounds variables in `expr` if `strict = FALS expect_identical(relocate_loc(x, c(d = b, e = c), strict = FALSE), c(d = 2L, a = 1L)) # But still not with OOB variables in `before` or `after` - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { relocate_loc(x, a, before = c, strict = FALSE) relocate_loc(x, a, after = c, strict = FALSE) - }, - cnd_class = TRUE - ) + }) }) test_that("accepts name spec", { @@ -169,14 +165,11 @@ test_that("accepts name spec", { test_that("can forbid rename syntax", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { relocate_loc(x, c(foo = b), allow_rename = FALSE) relocate_loc(x, c(b, foo = b), allow_rename = FALSE) relocate_loc(x, c(b, foo = b), allow_rename = FALSE, error_arg = "...") - - }, - cnd_class = TRUE - ) + }) expect_named(relocate_loc(x, c(c, b), allow_rename = FALSE), c("c", "b", "a")) }) @@ -195,25 +188,21 @@ test_that("can forbid empty selections", { test_that("can forbid empty selections", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { relocate_loc(mtcars, before = integer(), allow_empty = FALSE) relocate_loc(mtcars, starts_with("z"), allow_empty = FALSE) - }, - cnd_class = TRUE - ) + }) }) test_that("`before` and `after` forbid renaming", { x <- c(a = 1, b = 2, c = 3) - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { relocate_loc(x, b, before = c(new = c)) relocate_loc(x, b, before = c(new = c), before_arg = ".before") relocate_loc(x, b, after = c(new = c)) relocate_loc(x, b, after = c(new = c), after_arg = ".after") - }, - cnd_class = TRUE - ) + }) }) diff --git a/tests/testthat/test-eval-select.R b/tests/testthat/test-eval-select.R index e513d75b..67943dd7 100644 --- a/tests/testthat/test-eval-select.R +++ b/tests/testthat/test-eval-select.R @@ -53,14 +53,12 @@ test_that("included variables added to front", { }) test_that("include and exclude validate their inputs", { - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { x <- list(a = 1, b = 2, c = 3) select_loc(x, "a", include = 1) select_loc(x, "a", include = "d") select_loc(x, "a", exclude = 1) - }, - cnd_class = TRUE - ) + }) }) test_that("variables are excluded with non-strict `any_of()`", { @@ -89,15 +87,13 @@ test_that("result is named even with constant inputs (#173)", { }) test_that("can forbid rename syntax (#178)", { - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { select_loc(mtcars, c(foo = cyl), allow_rename = FALSE) select_loc(mtcars, c(cyl, foo = cyl), allow_rename = FALSE) select_loc(mtcars, c(cyl, foo = mpg), allow_rename = FALSE) select_loc(mtcars, c(foo = mpg, cyl), allow_rename = FALSE) select_loc(mtcars, c(foo = mpg, cyl), error_arg = "x", allow_rename = FALSE) - }, - cnd_class = TRUE - ) + }) expect_named(select_loc(mtcars, starts_with("c") | all_of("am"), allow_rename = FALSE), c("cyl", "carb", "am")) }) @@ -144,14 +140,12 @@ test_that("eval_select() produces correct backtraces", { }) test_that("eval_select() produces correct chained errors", { - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { select_loc(mtcars, 1 + "") - + f <- function() 1 + "" select_loc(mtcars, f()) - }, - cnd_class = TRUE - ) + }) }) test_that("can select with predicate when `allow_rename` is `FALSE` (#225)", { diff --git a/tests/testthat/test-eval-walk.R b/tests/testthat/test-eval-walk.R index 627c9e7c..339e3f5f 100644 --- a/tests/testthat/test-eval-walk.R +++ b/tests/testthat/test-eval-walk.R @@ -311,15 +311,13 @@ test_that("eval_walk() warns when using a predicate without where()", { }) test_that("eval_walk() errors when formula shorthand are not wrapped", { - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { select_loc(mtcars, ~ is.numeric(.x)) select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x)) select_loc(mtcars, ~ is.numeric(.x) || is.factor(.x) || is.character(.x) || is.numeric(.x) || is.factor(.x) || is.character(.x)) select_loc(mtcars, .data$"foo") - }, - cnd_class = TRUE - ) + }) }) test_that("can forbid empty selection", { diff --git a/tests/testthat/test-helpers-vector.R b/tests/testthat/test-helpers-vector.R index e17c37a2..f182e927 100644 --- a/tests/testthat/test-helpers-vector.R +++ b/tests/testthat/test-helpers-vector.R @@ -38,7 +38,7 @@ test_that("any_of() is lax", { }) test_that("all_of() and any_of() check their inputs", { - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { select_loc(letters2, all_of(NA)) select_loc(letters2, any_of(NA)) @@ -47,9 +47,7 @@ test_that("all_of() and any_of() check their inputs", { select_loc(letters2, any_of(is.factor)) select_loc(letters2, all_of(is.factor)) - }, - cnd_class = TRUE - ) + }) }) test_that("any_of() errors out of context", { diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 08e6411c..235396a1 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -1,10 +1,8 @@ test_that("one_of gives useful errors", { - expect_snapshot(error = TRUE, { + expect_snapshot(error = TRUE, cnd_class = TRUE, { one_of(1L, .vars = c("x", "y")) - }, - cnd_class = TRUE - ) + }) }) test_that("one_of tolerates but warns for unknown columns", {