From ec2ef7f1f8ddedbd16e0d745cddabae463d7ad5c Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 24 Oct 2024 09:41:00 +0200 Subject: [PATCH] Upkeep 2024-10 (#181) --- .gitignore | 2 + DESCRIPTION | 14 +- NAMESPACE | 2 + R/SVG.R | 2 +- R/fonts.R | 38 +- R/import-standalone-obj-type.R | 364 ++++++++++++++++ R/import-standalone-types-check.R | 554 +++++++++++++++++++++++++ R/svglite-package.R | 2 + R/utils.R | 29 +- README.Rmd | 9 +- README.md | 6 +- man/figures/lifecycle-deprecated.svg | 22 +- man/figures/lifecycle-experimental.svg | 22 +- man/figures/lifecycle-stable.svg | 30 +- man/figures/lifecycle-superseded.svg | 22 +- man/svglite-package.Rd | 1 - tests/testthat/_snaps/ids.md | 4 + tests/testthat/_snaps/text-fonts.md | 34 ++ tests/testthat/test-ids.R | 2 +- tests/testthat/test-output.R | 2 +- tests/testthat/test-text-fonts.R | 6 +- vignettes/fonts.Rmd | 19 +- 22 files changed, 1106 insertions(+), 80 deletions(-) create mode 100644 R/import-standalone-obj-type.R create mode 100644 R/import-standalone-types-check.R create mode 100644 tests/testthat/_snaps/ids.md create mode 100644 tests/testthat/_snaps/text-fonts.md diff --git a/.gitignore b/.gitignore index 5978e29..b0ad1bf 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ inst/doc docs compile_commands.json .cache + +/.quarto/ diff --git a/DESCRIPTION b/DESCRIPTION index 00fa154..96a9ca6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,8 +25,11 @@ License: GPL (>= 2) URL: https://svglite.r-lib.org, https://github.com/r-lib/svglite BugReports: https://github.com/r-lib/svglite/issues Depends: - R (>= 3.5.0) + R (>= 4.0) Imports: + cli, + lifecycle, + rlang (>= 1.1.0), systemfonts (>= 1.0.0) Suggests: covr, @@ -39,12 +42,13 @@ Suggests: LinkingTo: cpp11, systemfonts -VignetteBuilder: +VignetteBuilder: knitr +Config/build/compilation-database: true Config/Needs/website: tidyverse/tidytemplate +Config/testthat/edition: 3 +Config/usethis/last-upkeep: 2024-10-23 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.2 SystemRequirements: libpng -Config/testthat/edition: 3 -Config/build/compilation-database: true diff --git a/NAMESPACE b/NAMESPACE index 994f4fa..9e83ca9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,8 @@ export(stringSVG) export(svglite) export(svgstring) export(xmlSVG) +import(rlang) +importFrom(lifecycle,deprecated) importFrom(systemfonts,font_feature) importFrom(systemfonts,font_info) importFrom(systemfonts,match_font) diff --git a/R/SVG.R b/R/SVG.R index e9098b8..6c95765 100644 --- a/R/SVG.R +++ b/R/SVG.R @@ -84,7 +84,7 @@ svglite <- function(filename = "Rplot%03d.svg", width = 10, height = 8, filename <- file } if (invalid_filename(filename)) { - stop("invalid 'file': ", filename) + cli::cli_abort("{.arg filename} does not provide a valid name ({.val {filename}}): ") } aliases <- validate_aliases(system_fonts, user_fonts) web_fonts <- validate_web_fonts(web_fonts) diff --git a/R/fonts.R b/R/fonts.R index 7a1446b..5316ac2 100644 --- a/R/fonts.R +++ b/R/fonts.R @@ -32,7 +32,9 @@ validate_aliases <- function(system_fonts, user_fonts) { aliases <- c(names(system_fonts), names(user_fonts)) if (any(duplicated(aliases))) { - stop("Cannot supply both system and font alias", call. = FALSE) + cli::cli_abort(c("Cannot provided multiple fonts with the same alias", + i = "Problematic aliases: {unique(aliases[duplicated(aliases)])}" + )) } # Add missing system fonts for base families @@ -46,17 +48,11 @@ validate_aliases <- function(system_fonts, user_fonts) { } validate_system_alias <- function(alias) { - if (!is_scalar_character(alias)) { - stop("System fonts must be scalar character vector", call. = FALSE) - } + check_string(alias, allow_empty = FALSE) matched <- match_family(alias) if (alias != matched) { - warning( - call. = FALSE, - "System font `", alias, "` not found. ", - "Closest match: `", matched, "`" - ) + cli::cli_warn("System font {.val {alias}} not found. Closest match is {.val {matched}}") } matched } @@ -69,21 +65,15 @@ is_user_alias <- function(x) { validate_user_alias <- function(default_name, family) { if (!all(names(family) %in% r_font_faces)) { - stop("Faces must contain only: `plain`, `bold`, `italic`, `bolditalic`, `symbol`", - call. = FALSE - ) + cli::cli_abort("{.arg family} must can only include elements named {r_font_faces}") } - is_alias_object <- vapply_lgl(family, is_user_alias) - is_alias_plain <- vapply_lgl(family, is_scalar_character) + is_alias_object <- vapply(family, is_user_alias, logical(1)) + is_alias_plain <- vapply(family, is_scalar_character, logical(1)) is_valid_alias <- is_alias_object | is_alias_plain if (any(!is_valid_alias)) { - stop( - call. = FALSE, - "The following faces are invalid for `", default_name, "`: ", - paste0(names(family)[!is_valid_alias], collapse = ", ") - ) + cli::cli_abort("The following faces are invalid for {.val {default_name}}: {.val {names(family)[!is_valid_alias]}}") } names <- ifelse(is_alias_plain, default_name, family) @@ -94,14 +84,10 @@ validate_user_alias <- function(default_name, family) { obj$file %||% obj$ttf }) - file_exists <- vapply_lgl(files, file.exists) + file_exists <- vapply(files, file.exists, logical(1)) if (any(!file_exists)) { missing <- unlist(files)[!file_exists] - stop( - call. = FALSE, - "Could not find font file: ", - paste0(missing, collapse = ", ") - ) + cli::cli_abort("Could not find the following font file{?s}: {missing}") } zip(list(name = names, file = files)) @@ -156,7 +142,7 @@ font_face <- function(family, woff2 = NULL, woff = NULL, ttf = NULL, otf = NULL, if (!is.null(svg)) paste0('url("', svg, '") format("woff")') ) if (length(sources) == 0) { - stop("At least one font source must be given") + cli::cli_abort("At least one font source must be given") } x <- c( diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 0000000..47268d6 --- /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/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 0000000..ef8c5a1 --- /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/svglite-package.R b/R/svglite-package.R index 6e872a5..460e56c 100644 --- a/R/svglite-package.R +++ b/R/svglite-package.R @@ -3,5 +3,7 @@ "_PACKAGE" ## usethis namespace: start +#' @importFrom lifecycle deprecated +#' @import rlang ## usethis namespace: end NULL diff --git a/R/utils.R b/R/utils.R index 5e3f746..71ff361 100644 --- a/R/utils.R +++ b/R/utils.R @@ -12,53 +12,28 @@ plot_dim <- function(dim = c(NA, NA)) { dim[is.na(dim)] <- default_dim[is.na(dim)] dim_f <- prettyNum(dim, digits = 3) - message("Saving ", dim_f[1], "\" x ", dim_f[2], "\" image") + cli::cli_inform("Saving {dim_f[1]}\" x {dim_f[2]}\" image") } dim } -vapply_chr <- function(.x, .f, ...) { - vapply(.x, .f, character(1), ...) -} -vapply_lgl <- function(.x, .f, ...) { - vapply(.x, .f, logical(1), ...) -} lapply_if <- function(.x, .p, .f, ...) { if (!is.logical(.p)) { - .p <- vapply_lgl(.x, .p) + .p <- vapply(.x, .p, logical(1)) } .x[.p] <- lapply(.x[.p], .f, ...) .x } -keep <- function(.x, .p, ...) { - .x[vapply_lgl(.x, .p, ...)] -} compact <- function(x) { Filter(length, x) } -`%||%` <- function(x, y) { - if (is.null(x)) y else x -} -is_scalar_character <- function(x) { - is.character(x) && length(x) == 1 -} -names2 <- function(x) { - names(x) %||% rep("", length(x)) -} ilapply <- function(.x, .f, ...) { idx <- names(.x) %||% seq_along(.x) out <- Map(.f, names(.x), .x, ...) names(out) <- names(.x) out } -ilapply_if <- function(.x, .p, .f, ...) { - if (!is.logical(.p)) { - .p <- vapply_lgl(.x, .p) - } - .x[.p] <- ilapply(.x[.p], .f, ...) - .x -} set_names <- function(x, nm = x) { stats::setNames(x, nm) } diff --git a/README.Rmd b/README.Rmd index bdade7c..4c29d03 100644 --- a/README.Rmd +++ b/README.Rmd @@ -4,7 +4,8 @@ output: github_document -```{r, include = FALSE} +```{r} +#| include: false knitr::opts_chunk$set( collapse = TRUE, comment = "#>", @@ -28,7 +29,8 @@ svglite is a graphics device that produces clean svg output, suitable for use on svglite is available on CRAN using `install.packages("svglite")`. You can install the development version from github with: -```{r, eval=FALSE} +```{r} +#| eval: false # install.packages("pak") pak::pak("r-lib/svglite") ``` @@ -41,7 +43,8 @@ The grDevices package bundled with R already comes with an SVG device (using the `svglite()` is considerably faster than `svg()`. If you are rendering SVGs dynamically to serve over the web this can be quite important: -```{r, message=FALSE} +```{r} +#| message: false library(svglite) x <- runif(1e3) diff --git a/README.md b/README.md index d8390d8..bf065ba 100644 --- a/README.md +++ b/README.md @@ -62,8 +62,8 @@ bench::mark(svglite_test(), svg_test(), min_iterations = 250, check = FALSE) #> # A tibble: 2 × 6 #> expression min median `itr/sec` mem_alloc `gc/sec` #> -#> 1 svglite_test() 1.47ms 1.53ms 648. 587KB 6.15 -#> 2 svg_test() 6.19ms 6.42ms 155. 192KB 0.623 +#> 1 svglite_test() 1.46ms 1.78ms 393. 577KB 3.17 +#> 2 svg_test() 6.24ms 6.56ms 148. 192KB 0.593 ``` ### File size @@ -93,7 +93,7 @@ invisible(dev.off()) # svglite - svgz fs::file_size(tmp3) -#> 9.45K +#> 9.44K ``` ### Editability diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg index 4baaee0..b61c57c 100644 --- a/man/figures/lifecycle-deprecated.svg +++ b/man/figures/lifecycle-deprecated.svg @@ -1 +1,21 @@ -lifecyclelifecycledeprecateddeprecated \ No newline at end of file + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg index d1d060e..5d88fc2 100644 --- a/man/figures/lifecycle-experimental.svg +++ b/man/figures/lifecycle-experimental.svg @@ -1 +1,21 @@ -lifecyclelifecycleexperimentalexperimental \ No newline at end of file + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg index e015dc8..9bf21e7 100644 --- a/man/figures/lifecycle-stable.svg +++ b/man/figures/lifecycle-stable.svg @@ -1 +1,29 @@ -lifecyclelifecyclestablestable \ No newline at end of file + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg index 75f24f5..db8d757 100644 --- a/man/figures/lifecycle-superseded.svg +++ b/man/figures/lifecycle-superseded.svg @@ -1 +1,21 @@ - lifecyclelifecyclesupersededsuperseded \ No newline at end of file + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/svglite-package.Rd b/man/svglite-package.Rd index 77ac978..02b228e 100644 --- a/man/svglite-package.Rd +++ b/man/svglite-package.Rd @@ -3,7 +3,6 @@ \docType{package} \name{svglite-package} \alias{svglite-package} -\alias{_PACKAGE} \title{svglite: An 'SVG' Graphics Device} \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} diff --git a/tests/testthat/_snaps/ids.md b/tests/testthat/_snaps/ids.md new file mode 100644 index 0000000..260dfa3 --- /dev/null +++ b/tests/testthat/_snaps/ids.md @@ -0,0 +1,4 @@ +# ids are assigned as expecter + + No id supplied for page no 3 + diff --git a/tests/testthat/_snaps/text-fonts.md b/tests/testthat/_snaps/text-fonts.md new file mode 100644 index 0000000..8374323 --- /dev/null +++ b/tests/testthat/_snaps/text-fonts.md @@ -0,0 +1,34 @@ +# throw on malformed alias + + Code + validate_aliases(list(mono = letters), list()) + Condition + Error in `FUN()`: + ! `alias` must be a single string, not a character vector. + +--- + + Code + validate_aliases(list(sans = "foobar"), list()) + Condition + Warning: + System font "foobar" not found. Closest match is "Helvetica" + Output + $system + $system$sans + [1] "Helvetica" + + $system$serif + [1] "Times" + + $system$mono + [1] "Courier" + + $system$symbol + [1] "Symbol" + + + $user + list() + + diff --git a/tests/testthat/test-ids.R b/tests/testthat/test-ids.R index 2630ffe..8e4931a 100644 --- a/tests/testthat/test-ids.R +++ b/tests/testthat/test-ids.R @@ -18,7 +18,7 @@ test_that("ids are assigned as expecter", { sd <- svgstring(id = c("test", "test2")) plot(1:10, 1:10) plot(1:10, 1:10) - expect_warning(plot(1:10, 1:10), regexp = "No id supplied for page no") + expect_snapshot_warning(plot(1:10, 1:10)) dev.off() svg <- sd() diff --git a/tests/testthat/test-output.R b/tests/testthat/test-output.R index ba8f90f..d70b976 100644 --- a/tests/testthat/test-output.R +++ b/tests/testthat/test-output.R @@ -21,7 +21,7 @@ test_that("intermediate outputs are always valid svg if always_valid=TRUE", { svglite(path, always_valid = TRUE) expect_valid_svg <- function() { - expect_error(xml2::read_xml(path), NA) + expect_no_error(xml2::read_xml(path)) } mini_plot(1:10) diff --git a/tests/testthat/test-text-fonts.R b/tests/testthat/test-text-fonts.R index 35259dc..f1000b3 100644 --- a/tests/testthat/test-text-fonts.R +++ b/tests/testthat/test-text-fonts.R @@ -34,8 +34,10 @@ test_that("symbol font family is 'Symbol'", { }) test_that("throw on malformed alias", { - expect_error(validate_aliases(list(mono = letters), list()), "must be scalar") - expect_warning(validate_aliases(list(sans = "foobar"), list()), "not found") + expect_snapshot(validate_aliases(list(mono = letters), list()), error = TRUE) + skip_on_cran() + skip_on_os(c("windows", "linux")) + expect_snapshot(validate_aliases(list(sans = "foobar"), list())) }) test_that("fonts are aliased", { diff --git a/vignettes/fonts.Rmd b/vignettes/fonts.Rmd index 447906e..df41bbd 100644 --- a/vignettes/fonts.Rmd +++ b/vignettes/fonts.Rmd @@ -8,7 +8,9 @@ vignette: > \usepackage[utf8]{inputenc} --- -```{r, echo = FALSE, message = FALSE} +```{r} +#| echo: false +#| message: false knitr::opts_chunk$set(collapse = T, comment = "#>") library("svglite") ``` @@ -48,7 +50,8 @@ control over which fonts to use during SVG generation and rendering. names typically correspond to standard R faces but they can also alias non-standard families (though this is less useful): -```{r, eval=FALSE} +```{r} +#| eval: false fonts <- list( sans = "Helvetica", mono = "Consolas", @@ -69,7 +72,8 @@ coverage that is available on macOS and Windows systems (on the latter, only if MS Office is installed). Note that this font does not support kerning and has no bold or italic faces. -```{r, eval=FALSE} +```{r} +#| eval: false svglite("Rplots.svg", system_fonts = list(sans = "Arial Unicode MS")) plot.new() text(0.5, 0.5, "正規分布") @@ -97,7 +101,8 @@ list of families as argument, `user_fonts` takes a named tree of lists of families (`sans`, `serif`, `mono` and `symbol`) and faces (`plain`, `italic`, `bold`, `bolditalic`, `symbol`): -```{r, eval=FALSE} +```{r} +#| eval: false # Using ttf files from fontquiver here, but it could be any ttf some_file <- fontquiver::font("Liberation", "Sans", "Regular")$ttf other_file <- fontquiver::font("Liberation", "Sans", "Italic")$ttf @@ -125,7 +130,8 @@ You can also control which font gets written in the `font-family` fields of SVGs by supplying a list containing `alias` and `file` elements: -```{r, eval=FALSE} +```{r} +#| eval: false file_with_alias <- list(alias = "Foobar Font", file = other_file) fonts <- list(sans = list(plain = file_with_alias)) @@ -145,7 +151,8 @@ provides Symbola for the symbol font. The function `fontquiver::font_families()` produces a list with the appropriate structure and can be directly supplied to svglite: -```{r, eval=FALSE} +```{r} +#| eval: false fonts <- fontquiver::font_families("Liberation") fonts$symbol$symbol <- fontquiver::font_symbol("Symbola") str(fonts, 2)