diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index ee65ccb57..d9fced246 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -25,8 +25,6 @@ jobs: - {os: macos-latest, r: 'release'} - {os: windows-latest, r: 'release'} - # Use 3.6 to trigger usage of RTools35 - - {os: windows-latest, r: '3.6'} # use 4.1 to check with rtools40's older compiler - {os: windows-latest, r: '4.1'} diff --git a/DESCRIPTION b/DESCRIPTION index 7c18274aa..e71df41f0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,7 +33,7 @@ Imports: memoise, purrr (>= 1.0.0), ragg, - rlang (>= 1.0.0), + rlang (>= 1.1.0), rmarkdown (>= 1.1.9007), tibble, whisker, diff --git a/NEWS.md b/NEWS.md index c851d4582..6f316e20b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # pkgdown (development version) +* The skip link now becomes visible when focussed (#2138). Thanks to @glin for the styles! +* `build_reference_index()` gives more informative errors if your `contents` field is malformed (#2323). * The left and right footers no longer contain an extra empty paragraph tag and the footer gains additional padding-top to keep the whitespace constant (#2381). * `build_article_index()` and `build_reference_index()` use an improved BS5 template that correctly wraps each section description in a `
`, rather than a `

`. This eliminates an empty pargraph tag that preceded each section description (#2352). * `build_news()` now warns if it doesn't find any version headings, suggesting that that `NEWS.md` is structured incorrectly (#2213). diff --git a/R/build-home-index.R b/R/build-home-index.R index bf8843a4f..78d78a9b3 100644 --- a/R/build-home-index.R +++ b/R/build-home-index.R @@ -110,13 +110,13 @@ data_home_sidebar <- function(pkg = ".", call = caller_env()) { sidebar_components <- utils::modifyList( sidebar_components, - purrr::map2( + unwrap_purrr_error(purrr::map2( components, names(components), data_home_component, pkg = pkg, call = call - ) %>% + )) %>% set_names(names(components)) ) diff --git a/R/build-reference-index.R b/R/build-reference-index.R index 0abdd661a..c639762cf 100644 --- a/R/build-reference-index.R +++ b/R/build-reference-index.R @@ -6,10 +6,12 @@ data_reference_index <- function(pkg = ".", error_call = caller_env()) { return(list()) } - rows <- meta %>% - purrr::imap(data_reference_index_rows, pkg = pkg) %>% - purrr::compact() %>% - unlist(recursive = FALSE) + unwrap_purrr_error( + rows <- meta %>% + purrr::imap(data_reference_index_rows, pkg = pkg) %>% + purrr::compact() %>% + unlist(recursive = FALSE) + ) has_icons <- purrr::some(rows, ~ .x$row_has_icons %||% FALSE) @@ -47,7 +49,8 @@ data_reference_index_rows <- function(section, index, pkg) { if (has_name(section, "contents")) { - check_all_characters(section$contents, index, pkg) + id <- section$title %||% section$subtitle %||% index + check_contents(section$contents, id, pkg) topics <- section_topics(section$contents, pkg$topics, pkg$src_path) names <- topics$name @@ -64,35 +67,42 @@ data_reference_index_rows <- function(section, index, pkg) { purrr::compact(rows) } -check_all_characters <- function(contents, index, pkg) { - null <- purrr::map_lgl(contents, is.null) - any_null <- any(null) +check_contents <- function(contents, id, pkg) { + malformed <- "This typically indicates that your {pkgdown_config_href(pkg$src_path)} is malformed." + call <- quote(build_reference_index()) - if (any_null) { - msg_fld <- pkgdown_field(pkg, "reference", cfg = TRUE, fmt = TRUE) + if (length(contents) == 0) { cli::cli_abort( c( - "Item {.field {which(null)}} in section {index} is empty.", - x = paste0("Delete the empty line or add function name to ", msg_fld, ".") - ), call = caller_env() + "Section {.val {id}}: {.field contents} is empty.", + i = malformed + ), + call = call ) } - not_char <- !purrr::map_lgl(contents, is.character) - any_not_char <- any(not_char) - - if (!any_not_char) { - return(invisible()) + is_null <- purrr::map_lgl(contents, is.null) + if (any(is_null)) { + cli::cli_abort( + c( + "Section {.val {id}}: contents {.field {which(is_null)}} is empty.", + i = malformed + ), + call = call + ) } - msg_fld <- pkgdown_field(pkg, "reference", cfg = TRUE, fmt = TRUE) - cli::cli_abort( - c( - "Item {.field {which(not_char)}} in section {index} must be a character.", - x = paste0("You might need to add '' around e.g. - 'N' or - 'off' to ", msg_fld, ".") - ), call = caller_env() - ) - + is_char <- purrr::map_lgl(contents, is.character) + if (!all(is_char)) { + cli::cli_abort( + c( + "Section {.val {id}}: {.field {which(!is_char)}} must be a character.", + i = "You might need to add '' around special values like 'N' or 'off'", + i = malformed + ), + call = call + ) + } } find_icons <- function(x, path) { diff --git a/R/build-reference.R b/R/build-reference.R index 77f9cd41e..9485f0116 100644 --- a/R/build-reference.R +++ b/R/build-reference.R @@ -187,14 +187,14 @@ build_reference <- function(pkg = ".", topics <- purrr::transpose(pkg$topics) } - purrr::map( + unwrap_purrr_error(purrr::map( topics, build_reference_topic, pkg = pkg, lazy = lazy, examples_env = examples_env, run_dont_run = run_dont_run - ) + )) preview_site(pkg, "reference", preview = preview) } @@ -268,7 +268,7 @@ build_reference_topic <- function(topic, pkg, lazy = TRUE, examples_env = globalenv(), - run_dont_run = FALSE ) { + run_dont_run = FALSE) { in_path <- path(pkg$src_path, "man", topic$file_in) out_path <- path(pkg$dst_path, "reference", topic$file_out) @@ -286,7 +286,11 @@ build_reference_topic <- function(topic, run_dont_run = run_dont_run ), error = function(err) { - cli::cli_abort("Failed to parse Rd in {.file {topic$file_in}}", parent = err) + cli::cli_abort( + "Failed to parse Rd in {.file {topic$file_in}}", + parent = err, + call = quote(build_reference()) + ) } ) diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 000000000..8e3c07df4 --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -0,0 +1,360 @@ +# 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 (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 `"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 = 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 000000000..6782d69b1 --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,538 @@ +# 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 = 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 ----------------------------------------------------------------- + +check_character <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_character(x)) { + return(invisible(NULL)) + } + if (allow_null && 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 = 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/rd-html.R b/R/rd-html.R index 7882ac4cf..2739ddefe 100644 --- a/R/rd-html.R +++ b/R/rd-html.R @@ -28,7 +28,7 @@ flatten_para <- function(x, ...) { after_break <- c(FALSE, before_break[-length(x)]) groups <- cumsum(before_break | after_break) - html <- purrr::map(x, as_html, ...) + unwrap_purrr_error(html <- purrr::map(x, as_html, ...)) # split at line breaks for everything except blocks empty <- purrr::map_lgl(x, purrr::is_empty) needs_split <- !is_block & !empty @@ -58,7 +58,7 @@ flatten_para <- function(x, ...) { flatten_text <- function(x, ...) { if (length(x) == 0) return("") - html <- purrr::map_chr(x, as_html, ...) + unwrap_purrr_error(html <- purrr::map_chr(x, as_html, ...)) paste(html, collapse = "") } @@ -231,7 +231,7 @@ as_html.tag_Sexpr <- function(x, ...) { hide = "", cli::cli_abort( "\\\\Sexpr{{result={results}}} not yet supported", - call = caller_env() + call = NULL ) ) } diff --git a/R/topics-external.R b/R/topics-external.R index 0bd56bd90..0bcdd9ae9 100644 --- a/R/topics-external.R +++ b/R/topics-external.R @@ -3,7 +3,9 @@ ext_topics <- function(match_strings) { pkg <- purrr::map_chr(pieces, 1) fun <- sub("\\(\\)$", "", purrr::map_chr(pieces, 2)) - ext_rd <- purrr::map2(pkg, fun, get_rd_from_help) + unwrap_purrr_error( + ext_rd <- purrr::map2(pkg, fun, get_rd_from_help) + ) ext_title <- purrr::map_chr(ext_rd, extract_title) ext_href <- purrr::map2_chr(fun, pkg, downlit::href_topic) ext_funs <- purrr::map(ext_rd, topic_funs) @@ -25,14 +27,15 @@ ext_topics <- function(match_strings) { # Adapted from roxygen2::get_rd_from_help get_rd_from_help <- function(package, alias) { - check_installed(package, "as it's used in the reference index.") + call <- quote(build_reference_index()) + check_installed(package, "as it's used in the reference index.", call = call) help <- utils::help((alias), (package)) if (length(help) == 0) { fun <- paste0(package, "::", alias) cli::cli_abort( "Could not find documentation for {.fn {fun}}.", - call = caller_env() + call = call ) return() } diff --git a/R/topics.R b/R/topics.R index 6ff7a6781..abe5cf4cf 100644 --- a/R/topics.R +++ b/R/topics.R @@ -5,7 +5,9 @@ select_topics <- function(match_strings, topics, check = FALSE) { return(integer()) } - indexes <- purrr::map(match_strings, match_eval, env = match_env(topics)) + unwrap_purrr_error( + indexes <- purrr::map(match_strings, match_eval, env = match_env(topics)) + ) # If none of the specified topics have a match, return no topics if (purrr::every(indexes, is_empty)) { @@ -103,21 +105,37 @@ match_env <- function(topics) { if (!internal) !topics$internal else rep(TRUE, nrow(topics)) } fns$starts_with <- function(x, internal = FALSE) { + check_string(x) + check_bool(internal) + any_alias(~ grepl(paste0("^", x), .), .internal = internal) } fns$ends_with <- function(x, internal = FALSE) { + check_string(x) + check_bool(internal) + any_alias(~ grepl(paste0(x, "$"), .), .internal = internal) } fns$matches <- function(x, internal = FALSE) { + check_string(x) + check_bool(internal) + any_alias(~ grepl(x, .), .internal = internal) } fns$contains <- function(x, internal = FALSE) { + check_string(x) + check_bool(internal) + any_alias(~ grepl(x, ., fixed = TRUE), .internal = internal) } fns$has_keyword <- function(x) { + check_character(x) which(purrr::map_lgl(topics$keywords, ~ any(. %in% x))) } fns$has_concept <- function(x, internal = FALSE) { + check_string(x) + check_bool(internal) + match <- topics$concepts %>% purrr::map(~ str_trim(.) == x) %>% purrr::map_lgl(any) @@ -125,6 +143,9 @@ match_env <- function(topics) { which(match & is_public(internal)) } fns$lacks_concepts <- function(x, internal = FALSE) { + check_character(x) + check_bool(internal) + nomatch <- topics$concepts %>% purrr::map(~ match(str_trim(.), x, nomatch = FALSE)) %>% purrr::map_lgl(~ length(.) == 0L | all(. == 0L)) @@ -167,10 +188,14 @@ match_eval <- function(string, env) { topic_must("be a known topic name or alias", string) } } else if (is_call(expr)) { - tryCatch( + withCallingHandlers( eval(expr, env), error = function(e) { - topic_must("be a known selector function", string, parent = e) + cli::cli_abort( + "Failed to evaluate topic selector {.val {string}}.", + parent = e, + call = NULL + ) } ) } else { diff --git a/R/utils.R b/R/utils.R index 5a6896709..17a887688 100644 --- a/R/utils.R +++ b/R/utils.R @@ -42,6 +42,15 @@ str_trim <- function(x) gsub("^\\s+|\\s+$", "", x) str_squish <- function(x) str_trim(gsub("\\s+", " ", x)) +unwrap_purrr_error <- function(code) { + withCallingHandlers( + code, + purrr_error_indexed = function(err) { + cnd_signal(err$parent) + } + ) +} + # devtools metadata ------------------------------------------------------- system_file <- function(..., package) { diff --git a/inst/BS5/assets/pkgdown.scss b/inst/BS5/assets/pkgdown.scss index 883374561..72adec082 100644 --- a/inst/BS5/assets/pkgdown.scss +++ b/inst/BS5/assets/pkgdown.scss @@ -312,6 +312,16 @@ img.logo { img {width: 40px;} } +// Ensure skip link is visible if focussed +a[href='#main'] { + position: absolute; + margin: 4px; + padding: 0.75rem; + background-color: $body-bg; + text-decoration: none; + z-index: 2000; +} + /* Footnotes ---------------------------------------------------------------- */ a.footnote-ref { diff --git a/man/build_home.Rd b/man/build_home.Rd index 6cf9da56f..a58304180 100644 --- a/man/build_home.Rd +++ b/man/build_home.Rd @@ -99,16 +99,6 @@ To make your package more findable on search engines, it's good practice to over (Note the use of YAML's \code{>} i.e. "YAML pipes"; this is a convenient way of writing paragraphs of text.) } -\subsection{README header}{ - -READMEs usually start with an \verb{

} containing the package name. -If that feels duplicative with the package name in the navbar you can remove it with \code{strip_header: true}: - -\if{html}{\out{
}}\preformatted{home: - strip_header: true -}\if{html}{\out{
}} -} - } \subsection{Dev badges}{ diff --git a/man/rmd-fragments/home-configuration.Rmd b/man/rmd-fragments/home-configuration.Rmd index a2fa325aa..96a6faaa7 100644 --- a/man/rmd-fragments/home-configuration.Rmd +++ b/man/rmd-fragments/home-configuration.Rmd @@ -65,16 +65,6 @@ home: (Note the use of YAML's `>` i.e. "YAML pipes"; this is a convenient way of writing paragraphs of text.) -### README header - -READMEs usually start with an `

` containing the package name. -If that feels duplicative with the package name in the navbar you can remove it with `strip_header: true`: - -``` yaml -home: - strip_header: true -``` - ## Dev badges pkgdown identifies badges in three ways: diff --git a/tests/testthat/_snaps/build-home-index.md b/tests/testthat/_snaps/build-home-index.md index c8dc8c4f7..b34f65e34 100644 --- a/tests/testthat/_snaps/build-home-index.md +++ b/tests/testthat/_snaps/build-home-index.md @@ -92,10 +92,7 @@ Code data_home_sidebar(pkg) Condition - Error in `purrr::map2()`: - i In index: 1. - i With name: fancy. - Caused by error: + Error: ! Can't find component home.sidebar.components.fancy.title. i Edit _pkgdown.yml to define it. @@ -104,10 +101,7 @@ Code data_home_sidebar(pkg) Condition - Error in `purrr::map2()`: - i In index: 1. - i With name: fancy. - Caused by error: + Error: ! Can't find components home.sidebar.components.fancy.title and home.sidebar.components.fancy.text. i Edit _pkgdown.yml to define them. diff --git a/tests/testthat/_snaps/build-reference-index.md b/tests/testthat/_snaps/build-reference-index.md index 23bf49ce8..726c4ef2d 100644 --- a/tests/testthat/_snaps/build-reference-index.md +++ b/tests/testthat/_snaps/build-reference-index.md @@ -57,32 +57,34 @@ # errors well when a content entry is empty - i In index: 1. - Caused by error in `.f()`: - ! Item 2 in section 1 is empty. - x Delete the empty line or add function name to reference in _pkgdown.yml. + Section "bla": contents 2 is empty. + i This typically indicates that your _pkgdown.yml is malformed. # errors well when a content entry is not a character Code build_reference_index(pkg) Condition - Error in `map2()`: - i In index: 1. - Caused by error in `.f()`: - ! Item 2 in section 1 must be a character. - x You might need to add '' around e.g. - 'N' or - 'off' to reference in _pkgdown.yml. + Error in `build_reference_index()`: + ! Section "bla": 2 must be a character. + i You might need to add '' around special values like 'N' or 'off' + i This typically indicates that your _pkgdown.yml is malformed. + +# errors well when a content is totally empty + + Code + build_reference_index(pkg) + Condition + Error in `build_reference_index()`: + ! Section "bla": contents is empty. + i This typically indicates that your _pkgdown.yml is malformed. # errors well when a content entry refers to a not installed package Code build_reference_index(pkg) Condition - Error in `map2()`: - i In index: 1. - Caused by error in `purrr::map2()`: - i In index: 1. - Caused by error in `.f()`: + Error in `build_reference_index()`: ! The package "notapackage" is required as it's used in the reference index. # errors well when a content entry refers to a non existing function @@ -90,11 +92,7 @@ Code build_reference_index(pkg) Condition - Error in `map2()`: - i In index: 1. - Caused by error in `purrr::map2()`: - i In index: 1. - Caused by error in `map2_()`: + Error in `build_reference_index()`: ! Could not find documentation for `rlang::lala()`. # can use a topic from another package diff --git a/tests/testthat/_snaps/build-reference.md b/tests/testthat/_snaps/build-reference.md index 53fe64429..6049eb43c 100644 --- a/tests/testthat/_snaps/build-reference.md +++ b/tests/testthat/_snaps/build-reference.md @@ -6,13 +6,8 @@ Writing `reference/index.html` Reading man/f.Rd Condition - Error in `purrr::map()`: - i In index: 1. - i With name: f.Rd. - Caused by error in `.f()`: + Error in `build_reference()`: ! Failed to parse Rd in 'f.Rd' - Caused by error in `purrr::map()`: - i In index: 4. Caused by error: ! Failed to parse tag "\\url{}". i Check for empty \url{} tags. diff --git a/tests/testthat/_snaps/rd-html.md b/tests/testthat/_snaps/rd-html.md index 16c6be23d..02e009aa7 100644 --- a/tests/testthat/_snaps/rd-html.md +++ b/tests/testthat/_snaps/rd-html.md @@ -37,9 +37,7 @@ Code rd2html("\\Sexpr[results=verbatim]{1}") Condition - Error in `purrr::map_chr()`: - i In index: 1. - Caused by error in `map_()`: + Error: ! \\Sexpr{result=verbatim} not yet supported # bad specs throw errors @@ -47,33 +45,25 @@ Code rd2html("\\url{}") Condition - Error in `purrr::map_chr()`: - i In index: 1. - Caused by error: + Error: ! Failed to parse tag "\\url{}". i Check for empty \url{} tags. Code rd2html("\\url{a\nb}") Condition - Error in `purrr::map_chr()`: - i In index: 1. - Caused by error: + Error: ! Failed to parse tag "\\url{}". i This may be caused by a \url tag that spans a line break. Code rd2html("\\email{}") Condition - Error in `purrr::map_chr()`: - i In index: 1. - Caused by error: + Error: ! Failed to parse tag "\\email{}". i empty Code rd2html("\\linkS4class{}") Condition - Error in `purrr::map_chr()`: - i In index: 1. - Caused by error: + Error: ! Failed to parse tag "\\linkS4class{}". # \describe items can contain multiple paragraphs diff --git a/tests/testthat/_snaps/topics-external.md b/tests/testthat/_snaps/topics-external.md index f2f7ab738..dd07cdb31 100644 --- a/tests/testthat/_snaps/topics-external.md +++ b/tests/testthat/_snaps/topics-external.md @@ -26,8 +26,6 @@ Code ext_topics("base::doesntexist") Condition - Error in `purrr::map2()`: - i In index: 1. - Caused by error in `map2_()`: + Error in `build_reference_index()`: ! Could not find documentation for `base::doesntexist()`. diff --git a/tests/testthat/_snaps/topics.md b/tests/testthat/_snaps/topics.md index a595eec15..0a418bcc2 100644 --- a/tests/testthat/_snaps/topics.md +++ b/tests/testthat/_snaps/topics.md @@ -3,43 +3,32 @@ Code t <- select_topics("x + ", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: + Error: ! Topic must be valid R code, not "x + ". i Run `usethis::edit_pkgdown_config()` to edit. Code t <- select_topics("y", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: + Error: ! Topic must be a known topic name or alias, not "y". i Run `usethis::edit_pkgdown_config()` to edit. Code t <- select_topics("paste(1)", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: - ! Topic must be a known selector function, not "paste(1)". - i Run `usethis::edit_pkgdown_config()` to edit. + Error: + ! Failed to evaluate topic selector "paste(1)". Caused by error in `paste()`: ! could not find function "paste" Code t <- select_topics("starts_with", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: + Error: ! Topic must be a known topic name or alias, not "starts_with". i Run `usethis::edit_pkgdown_config()` to edit. Code t <- select_topics("1", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: + Error: ! Topic must be a string or function call, not "1". i Run `usethis::edit_pkgdown_config()` to edit. Code @@ -49,22 +38,35 @@ ! No topics matched in pkgdown config. No topics selected. i Run `usethis::edit_pkgdown_config()` to edit. +# selector functions validate their inputs + + Code + t <- select_topics("starts_with('x', 'y')", topics) + Condition + Error: + ! Failed to evaluate topic selector "starts_with('x', 'y')". + Caused by error in `starts_with()`: + ! `internal` must be `TRUE` or `FALSE`, not the string "y". + Code + t <- select_topics("starts_with(c('x', 'y'))", topics) + Condition + Error: + ! Failed to evaluate topic selector "starts_with(c('x', 'y'))". + Caused by error in `starts_with()`: + ! `x` must be a single string, not a character vector. + # can select by name or alias Code select_topics("a4", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: + Error: ! Topic must be a known topic name or alias, not "a4". i Run `usethis::edit_pkgdown_config()` to edit. Code select_topics("c::a", topics) Condition - Error in `purrr::map()`: - i In index: 1. - Caused by error: + Error: ! Topic must be a known topic name or alias, not "c::a". i Run `usethis::edit_pkgdown_config()` to edit. diff --git a/tests/testthat/test-build-reference-index.R b/tests/testthat/test-build-reference-index.R index 2899f2e6f..84900ff8f 100644 --- a/tests/testthat/test-build-reference-index.R +++ b/tests/testthat/test-build-reference-index.R @@ -80,6 +80,15 @@ test_that("errors well when a content entry is not a character", { expect_snapshot(build_reference_index(pkg), error = TRUE) }) +test_that("errors well when a content is totally empty", { + local_edition(3) + meta <- yaml::yaml.load( "reference:\n- title: bla\n contents: ~") + pkg <- as_pkgdown(test_path("assets/reference"), override = meta) + + expect_snapshot(build_reference_index(pkg), error = TRUE) +}) + + test_that("errors well when a content entry refers to a not installed package", { skip_if_not_installed("cli", "3.1.0") local_edition(3) diff --git a/tests/testthat/test-topics.R b/tests/testthat/test-topics.R index 8b1eeeb4b..00222a433 100644 --- a/tests/testthat/test-topics.R +++ b/tests/testthat/test-topics.R @@ -15,6 +15,19 @@ test_that("bad inputs give informative warnings", { }) }) +test_that("selector functions validate their inputs", { + topics <- tibble::tribble( + ~name, ~alias, ~internal, ~concepts, + "x", c("x", "x1"), FALSE, character(), + ) + + expect_snapshot(error = TRUE, { + t <- select_topics("starts_with('x', 'y')", topics) + t <- select_topics("starts_with(c('x', 'y'))", topics) + }) +}) + + test_that("empty input returns empty vector", { topics <- tibble::tribble( ~name, ~alias, ~internal, ~concepts,