From cc1239506ea291264c8fb9d9ab73bd525190dc27 Mon Sep 17 00:00:00 2001 From: kbvernon Date: Wed, 19 Jun 2024 15:17:53 -0600 Subject: [PATCH 1/6] draft of use_crate() --- R/use_crate.R | 141 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 R/use_crate.R diff --git a/R/use_crate.R b/R/use_crate.R new file mode 100644 index 00000000..c7d77e8e --- /dev/null +++ b/R/use_crate.R @@ -0,0 +1,141 @@ +#' Add dependencies to a Cargo.toml manifest file +#' +#' Analogous to `usethis::use_package()` but for crate dependencies. +#' +#' @param crate a character scalar, the name of the crate to add +#' @param features a character vector, a list of features to include from the +#' crate +#' @param git a character scalar, the URL of the Github repository +#' @param version a character scalar, the version of the crate to add +#' @param path a character scalar, the package directory +#' @param ... additional options to include +#' +#' @details +#' For a list of all available options, see \href{https://doc.rust-lang.org/cargo/commands/cargo-add.html}{Cargo docs} +#' for `cargo-add`. +#' +#' @return `NULL`, invisibly +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' # add to [dependencies] +#' use_crate("serde") +#' +#' # add to [dependencies] and [features] +#' use_crate("serde", features = "derive") +#' +#' # add to [dependencies] using github repository as source +#' use_crate("serde", git = "serde-rs/serde") +#' +#' # add to [dependencies] with specific version +#' use_crate("serde", version = "1.0.1") +#' } +use_crate <- function( + crate, + features = NULL, + git = NULL, + version = NULL, + path = ".", + ... +){ + + # check crate + if (!rlang::is_character(crate) && length(crate) != 1){ + + cli::cli_abort( + "{.var crate} should be a length one character vector.", + "i" = "You supplied an object of class {class(crate)} with length {length(crate)}.", + class = "rextendr_error" + ) + + } + + # check features + if (!is.null(features) && !rlang::is_character(features)){ + + cli::cli_abort( + "{.var features} should be a character vector.", + "i" = "You supplied an object of class {class(features)}.", + class = "rextendr_error" + ) + + } + + # check git + if (!is.null(git)){ + + if (!rlang::is_character(git) && length(git) != 1){ + + cli::cli_abort( + "{.var git} should be a length one character vector.", + "i" = "You supplied an object of class {class(git)} with length {length(git)}.", + class = "rextendr_error" + ) + + } + + git <- paste0("https://github.com/", git) + + } + + # check version + if (!is.null(version)){ + + if (!rlang::is_character(version) && length(version) != 1){ + + cli::cli_abort( + "{.var version} should be a length one character vector.", + "i" = "You supplied an object of class {class(version)} with length {length(version)}.", + class = "rextendr_error" + ) + + } + + crate <- paste0(crate, "@", version) + + } + + # combine main options + cargo_add_opts <- list( + "--features" = features, + "--git" = git + ) + + # add additional options from ... + lst <- rlang::dots_list(...) + + if (length(lst) > 0){ names(lst) <- paste0("--", names(lst)) } + + cargo_add_opts <- c(cargo_add_opts, lst) + + # clear empty options + cargo_add_opts <- Filter(length, cargo_add_opts) + + # combine option names and values into single strings + adtl_args <- unname(purrr::imap_chr( + cargo_add_opts, + \(x, i){ paste(i, paste0(x, collapse = " ")) } + )) + + # get rust directory in project folder + root <- rprojroot::find_package_root_file(path = path) + + rust_folder <- normalizePath( + file.path(root, "src", "rust"), + winslash = "/", + mustWork = FALSE + ) + + # run the commmand + processx::run( + "cargo", + c("add", crate, adtl_args), + echo_cmd = TRUE, + wd = rust_folder + ) + + invisible() + +} From 52b42d5567f918fc7e45eccbe3711f30f1480dbf Mon Sep 17 00:00:00 2001 From: kbvernon Date: Thu, 1 Aug 2024 13:29:36 -0600 Subject: [PATCH 2/6] remove dots, add `optional` --- R/use_crate.R | 69 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 50 insertions(+), 19 deletions(-) diff --git a/R/use_crate.R b/R/use_crate.R index c7d77e8e..fb40fdbc 100644 --- a/R/use_crate.R +++ b/R/use_crate.R @@ -2,16 +2,18 @@ #' #' Analogous to `usethis::use_package()` but for crate dependencies. #' -#' @param crate a character scalar, the name of the crate to add -#' @param features a character vector, a list of features to include from the +#' @param crate character scalar, the name of the crate to add +#' @param features character vector, a list of features to include from the #' crate -#' @param git a character scalar, the URL of the Github repository -#' @param version a character scalar, the version of the crate to add -#' @param path a character scalar, the package directory -#' @param ... additional options to include +#' @param git character scalar, the URL of the Github repository +#' @param version character scalar, the version of the crate to add +#' @param optional boolean scalar, whether to mark the dependency as optional +#' (FALSE by default) +#' @param path character scalar, the package directory #' #' @details -#' For a list of all available options, see \href{https://doc.rust-lang.org/cargo/commands/cargo-add.html}{Cargo docs} +#' For more details regarding these and other options, see the +#' \href{https://doc.rust-lang.org/cargo/commands/cargo-add.html}{Cargo docs} #' for `cargo-add`. #' #' @return `NULL`, invisibly @@ -31,12 +33,16 @@ #' #' # add to [dependencies] with specific version #' use_crate("serde", version = "1.0.1") +#' +#' # add to [dependencies] with optional compilation +#' use_crate("serde", optional = TRUE) #' } use_crate <- function( crate, features = NULL, git = NULL, version = NULL, + optional = FALSE, path = ".", ... ){ @@ -44,9 +50,14 @@ use_crate <- function( # check crate if (!rlang::is_character(crate) && length(crate) != 1){ + info <- paste( + "You supplied an object of class {class(crate)[1]}", + "with length {length(crate)}." + ) + cli::cli_abort( "{.var crate} should be a length one character vector.", - "i" = "You supplied an object of class {class(crate)} with length {length(crate)}.", + "i" = info, class = "rextendr_error" ) @@ -57,7 +68,7 @@ use_crate <- function( cli::cli_abort( "{.var features} should be a character vector.", - "i" = "You supplied an object of class {class(features)}.", + "i" = "You supplied an object of class {class(features)[1]}.", class = "rextendr_error" ) @@ -68,9 +79,14 @@ use_crate <- function( if (!rlang::is_character(git) && length(git) != 1){ + info <- paste( + "You supplied an object of class {class(git)[1]}", + "with length {length(git)}." + ) + cli::cli_abort( "{.var git} should be a length one character vector.", - "i" = "You supplied an object of class {class(git)} with length {length(git)}.", + "i" = info, class = "rextendr_error" ) @@ -85,9 +101,14 @@ use_crate <- function( if (!rlang::is_character(version) && length(version) != 1){ + info <- paste( + "You supplied an object of class {class(version)}", + "with length {length(version)}." + ) + cli::cli_abort( "{.var version} should be a length one character vector.", - "i" = "You supplied an object of class {class(version)} with length {length(version)}.", + "i" = info, class = "rextendr_error" ) @@ -97,19 +118,29 @@ use_crate <- function( } + #check optional + if (!rlang::is_bool(optional) && length(optional) != 1){ + + info <- paste( + "You supplied an object of class {class(optional)[1]}", + "with length {length(optional)}." + ) + + cli::cli_abort( + "{.var optional} should be a length one boolean vector.", + "i" = info, + class = "rextendr_error" + ) + + } + # combine main options cargo_add_opts <- list( "--features" = features, - "--git" = git + "--git" = git, + "--optional" = tolower(as.character(optional)) ) - # add additional options from ... - lst <- rlang::dots_list(...) - - if (length(lst) > 0){ names(lst) <- paste0("--", names(lst)) } - - cargo_add_opts <- c(cargo_add_opts, lst) - # clear empty options cargo_add_opts <- Filter(length, cargo_add_opts) From 05e005874ba0462aebfeb2789a9d54174e962e41 Mon Sep 17 00:00:00 2001 From: Kenneth Blake Vernon <53311626+kbvernon@users.noreply.github.com> Date: Thu, 1 Aug 2024 15:20:30 -0600 Subject: [PATCH 3/6] Update R/use_crate.R Co-authored-by: Josiah Parry --- R/use_crate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/use_crate.R b/R/use_crate.R index fb40fdbc..cf0fd544 100644 --- a/R/use_crate.R +++ b/R/use_crate.R @@ -136,7 +136,7 @@ use_crate <- function( # combine main options cargo_add_opts <- list( - "--features" = features, + "--features" = paste0(features, collapse = " "), "--git" = git, "--optional" = tolower(as.character(optional)) ) From d6cafc7b50f30dc4da861d0fbec3ca1f6d94a084 Mon Sep 17 00:00:00 2001 From: Kenneth Blake Vernon <53311626+kbvernon@users.noreply.github.com> Date: Thu, 1 Aug 2024 15:21:07 -0600 Subject: [PATCH 4/6] Update R/use_crate.R Co-authored-by: Josiah Parry --- R/use_crate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/use_crate.R b/R/use_crate.R index cf0fd544..c4d9296b 100644 --- a/R/use_crate.R +++ b/R/use_crate.R @@ -147,7 +147,7 @@ use_crate <- function( # combine option names and values into single strings adtl_args <- unname(purrr::imap_chr( cargo_add_opts, - \(x, i){ paste(i, paste0(x, collapse = " ")) } + function(x, i){ paste(i, paste0(x, collapse = " ")) } )) # get rust directory in project folder From a5de45f272f5c92017e4b34770dab9849c68649d Mon Sep 17 00:00:00 2001 From: kbvernon Date: Thu, 1 Aug 2024 15:59:55 -0600 Subject: [PATCH 5/6] require full url to remote git repo --- R/use_crate.R | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/R/use_crate.R b/R/use_crate.R index c4d9296b..7b605152 100644 --- a/R/use_crate.R +++ b/R/use_crate.R @@ -5,7 +5,7 @@ #' @param crate character scalar, the name of the crate to add #' @param features character vector, a list of features to include from the #' crate -#' @param git character scalar, the URL of the Github repository +#' @param git character scalar, the full URL of the remote Git repository #' @param version character scalar, the version of the crate to add #' @param optional boolean scalar, whether to mark the dependency as optional #' (FALSE by default) @@ -29,7 +29,7 @@ #' use_crate("serde", features = "derive") #' #' # add to [dependencies] using github repository as source -#' use_crate("serde", git = "serde-rs/serde") +#' use_crate("serde", git = "https://github.com/serde-rs/serde") #' #' # add to [dependencies] with specific version #' use_crate("serde", version = "1.0.1") @@ -43,8 +43,7 @@ use_crate <- function( git = NULL, version = NULL, optional = FALSE, - path = ".", - ... + path = "." ){ # check crate @@ -92,8 +91,6 @@ use_crate <- function( } - git <- paste0("https://github.com/", git) - } # check version From 8ef6db80f69ebefea16da8ab16ec1635a3741cf6 Mon Sep 17 00:00:00 2001 From: kbvernon Date: Fri, 2 Aug 2024 15:06:15 -0600 Subject: [PATCH 6/6] use standalone checks --- R/import-standalone-obj-type.R | 362 +++++++++++++++++++ R/import-standalone-types-check.R | 553 ++++++++++++++++++++++++++++++ R/use_crate.R | 93 +---- 3 files changed, 924 insertions(+), 84 deletions(-) create mode 100644 R/import-standalone-obj-type.R create mode 100644 R/import-standalone-types-check.R diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 00000000..20a88bda --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -0,0 +1,362 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-obj-type.R +# last-updated: 2023-05-01 +# license: https://unlicense.org +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 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 (rlang::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 (!rlang::is_vector(x)) { + return(.rlang_as_friendly_type(typeof(x))) + } + + n_dim <- length(dim(x)) + + if (!n_dim) { + if (!rlang::is_list(x) && length(x) == 1) { + if (rlang::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 (!rlang::is_vector(x)) { + rlang::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 = 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 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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + # From standalone-cli.R + cli <- rlang::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) + ) + + rlang::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/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 00000000..6099af20 --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,553 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# 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 +# +# 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 = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (!missing(x) && .standalone_types_check_dot_call(rlang::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 = rlang::caller_arg(x), + call = rlang::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 (rlang::is_string(x)) { + if (allow_empty || !rlang::is_string(x, "")) { + return(TRUE) + } + } + + if (allow_null && rlang::is_null(x)) { + return(TRUE) + } + + if (allow_na && (identical(x, NA) || identical(x, rlang::na_chr)) + ) { + return(TRUE) + } + + FALSE +} + +check_name <- function(x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if (0 == (exit_code <- .standalone_types_check_dot_call( + rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if (0 == (exit_code <- .standalone_types_check_dot_call( + rlang::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 { + rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (!missing(x)) { + if (rlang::is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_call(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_environment(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_function(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (!missing(x)) { + if (rlang::is_closure(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (rlang::is_formula(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a formula", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + + +# Vectors ----------------------------------------------------------------- + +check_character <- function(x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (!missing(x)) { + if (rlang::is_character(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a character vector", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_logical <- function(x, + ..., + allow_null = FALSE, + arg = rlang::caller_arg(x), + call = rlang::caller_env()) { + if (!missing(x)) { + if (rlang::is_logical(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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 = rlang::caller_arg(x), + call = rlang::caller_env() +) { + if (!missing(x)) { + if (is.data.frame(x)) { + return(invisible(NULL)) + } + if (allow_null && rlang::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/use_crate.R b/R/use_crate.R index 7b605152..520fdb7b 100644 --- a/R/use_crate.R +++ b/R/use_crate.R @@ -46,90 +46,15 @@ use_crate <- function( path = "." ){ - # check crate - if (!rlang::is_character(crate) && length(crate) != 1){ + # check args + check_string(crate) + check_character(features, allow_null = TRUE) + check_string(git, allow_null = TRUE) + check_string(version, allow_null = TRUE) + check_bool(optional) + check_string(path) - info <- paste( - "You supplied an object of class {class(crate)[1]}", - "with length {length(crate)}." - ) - - cli::cli_abort( - "{.var crate} should be a length one character vector.", - "i" = info, - class = "rextendr_error" - ) - - } - - # check features - if (!is.null(features) && !rlang::is_character(features)){ - - cli::cli_abort( - "{.var features} should be a character vector.", - "i" = "You supplied an object of class {class(features)[1]}.", - class = "rextendr_error" - ) - - } - - # check git - if (!is.null(git)){ - - if (!rlang::is_character(git) && length(git) != 1){ - - info <- paste( - "You supplied an object of class {class(git)[1]}", - "with length {length(git)}." - ) - - cli::cli_abort( - "{.var git} should be a length one character vector.", - "i" = info, - class = "rextendr_error" - ) - - } - - } - - # check version - if (!is.null(version)){ - - if (!rlang::is_character(version) && length(version) != 1){ - - info <- paste( - "You supplied an object of class {class(version)}", - "with length {length(version)}." - ) - - cli::cli_abort( - "{.var version} should be a length one character vector.", - "i" = info, - class = "rextendr_error" - ) - - } - - crate <- paste0(crate, "@", version) - - } - - #check optional - if (!rlang::is_bool(optional) && length(optional) != 1){ - - info <- paste( - "You supplied an object of class {class(optional)[1]}", - "with length {length(optional)}." - ) - - cli::cli_abort( - "{.var optional} should be a length one boolean vector.", - "i" = info, - class = "rextendr_error" - ) - - } + if (!is.null(version)){ crate <- paste0(crate, "@", version) } # combine main options cargo_add_opts <- list( @@ -139,7 +64,7 @@ use_crate <- function( ) # clear empty options - cargo_add_opts <- Filter(length, cargo_add_opts) + cargo_add_opts <- purrr::discard(cargo_add_opts, rlang::is_empty) # combine option names and values into single strings adtl_args <- unname(purrr::imap_chr(