From a85effe057791e53fa3e5875b0726cd883cc1f08 Mon Sep 17 00:00:00 2001 From: olivroy Date: Fri, 1 Dec 2023 13:17:22 -0500 Subject: [PATCH 1/3] Use `cli::cli_abort()` for all errors. --- R/as_xml_document.R | 2 +- R/utils.R | 18 ++++++++---------- R/xml_missing.R | 2 +- R/xml_serialize.R | 2 +- R/xml_write.R | 6 +++--- 5 files changed, 14 insertions(+), 16 deletions(-) diff --git a/R/as_xml_document.R b/R/as_xml_document.R index 2b147c32..c24f1226 100644 --- a/R/as_xml_document.R +++ b/R/as_xml_document.R @@ -40,7 +40,7 @@ as_xml_document.response <- read_xml.response #' @export as_xml_document.list <- function(x, ...) { if (length(x) > 1) { - abort("Root nodes must be of length 1") + cli::cli_abort("Root nodes must be of length 1.") } diff --git a/R/utils.R b/R/utils.R index e5d26aeb..36e5f6b3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -42,7 +42,7 @@ s_quote <- function(x) paste0("'", x, "'") # Similar to match.arg, but returns character() with NULL or empty input and # errors if any of the inputs are not found (fixing # https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16659) -parse_options <- function(arg, options) { +parse_options <- function(arg, options, error_call = caller_env()) { if (is.numeric(arg)) { return(as.integer(arg)) } @@ -54,15 +54,13 @@ parse_options <- function(arg, options) { # set duplicates.ok = TRUE so any duplicates are counted differently than # non-matches, then take only unique results i <- pmatch(arg, names(options), duplicates.ok = TRUE) - if (any(is.na(i))) { - stop( - sprintf( - "`options` %s is not a valid option, should be one of %s", - s_quote(arg[is.na(i)][1L]), - paste(s_quote(names(options)), collapse = ", ") - ), - call. = FALSE - ) + if (anyNA(i)) { + cli::cli_abort(c( + x = "{.arg options} {.val {arg[is.na(i)][1L]}} is not a valid option.", + i = "Valid options are one of {.or {.val {names(options)}}}.", + i = "See {.help [read_html](xml2::read_html)} for all options." + ), + call = error_call) } sum(options[unique(i)]) } diff --git a/R/xml_missing.R b/R/xml_missing.R index 1e7d0c69..0600b270 100644 --- a/R/xml_missing.R +++ b/R/xml_missing.R @@ -28,7 +28,7 @@ as.character.xml_missing <- function(x, ...) { `[.xml_missing` <- function(x, i, ...) x #' @export -`[[.xml_missing` <- function(x, i, ...) if (i == 1L) x else abort("subscript out of bounds") +`[[.xml_missing` <- function(x, i, ...) if (i == 1L) x else cli::cli_abort("subscript out of bounds") #' @export is.na.xml_missing <- function(x) { diff --git a/R/xml_serialize.R b/R/xml_serialize.R index d2cdcb9b..7f0b47a6 100644 --- a/R/xml_serialize.R +++ b/R/xml_serialize.R @@ -72,7 +72,7 @@ xml_unserialize <- function(connection, ...) { } res <- read_xml_int(unclass(object), ...) } else { - abort("Not a serialized xml2 object") + cli::cli_abort("Not a serialized xml2 object.") } res } diff --git a/R/xml_write.R b/R/xml_write.R index 35448f1c..8fb77b8c 100644 --- a/R/xml_write.R +++ b/R/xml_write.R @@ -30,7 +30,7 @@ write_xml <- function(x, file, ...) { #' @export write_xml.xml_missing <- function(x, file, ...) { - abort("Missing data cannot be written") + cli::cli_abort("Missing data cannot be written.") } #' @rdname write_xml @@ -56,7 +56,7 @@ write_xml.xml_document <- function(x, file, ..., options = "format", encoding = #' @export write_xml.xml_nodeset <- function(x, file, ..., options = "format", encoding = "UTF-8") { if (length(x) != 1) { - abort("Can only save length 1 node sets") + cli::cli_abort("Can only save length 1 node sets.") } options <- parse_options(options, xml_save_options()) @@ -104,7 +104,7 @@ write_html <- function(x, file, ...) { #' @export write_html.xml_missing <- function(x, file, ...) { - abort("Missing data cannot be written") + cli::cli_abort("Missing data cannot be written.") } #' @rdname write_xml From 697cb47e063b4d4e2ae487b6094e03a1ad9f3f6d Mon Sep 17 00:00:00 2001 From: olivroy Date: Fri, 1 Dec 2023 13:17:55 -0500 Subject: [PATCH 2/3] Adjust test + add snapshot --- tests/testthat/_snaps/xml_parse.md | 10 ++++++++++ tests/testthat/test-xml_parse.R | 7 +++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/tests/testthat/_snaps/xml_parse.md b/tests/testthat/_snaps/xml_parse.md index db748e1a..a774f18d 100644 --- a/tests/testthat/_snaps/xml_parse.md +++ b/tests/testthat/_snaps/xml_parse.md @@ -2,6 +2,16 @@ `x` must be a single string, not an empty character vector. +# parse_options errors when given an invalid option + + Code + read_html(test_path("lego.html.bz2"), options = "INVALID") + Condition + Error in `read_html()`: + x `options` "INVALID" is not a valid option. + i Valid options are one of "RECOVER", "NOENT", "DTDLOAD", "DTDATTR", "DTDVALID", "NOERROR", "NOWARNING", "PEDANTIC", "NOBLANKS", "SAX1", "XINCLUDE", "NONET", "NODICT", "NSCLEAN", "NOCDATA", "NOXINCNODE", "COMPACT", "OLD10", ..., "IGNORE_ENC", or "BIG_LINES". + i See read_html (`?xml2::read_html()`) for all options. + # read_xml and read_html fail with > 1 input `x` must be a single string, not a character vector. diff --git a/tests/testthat/test-xml_parse.R b/tests/testthat/test-xml_parse.R index 2ff6e6ce..2c190729 100644 --- a/tests/testthat/test-xml_parse.R +++ b/tests/testthat/test-xml_parse.R @@ -26,12 +26,11 @@ test_that("read_html correctly parses malformed document", { test_that("parse_options errors when given an invalid option", { expect_error( parse_options("INVALID", xml_parse_options()), - "`options` 'INVALID' is not a valid option" + '`options` "INVALID" is not a valid option' ) - expect_error( - read_html(test_path("lego.html.bz2"), options = "INVALID"), - "`options` 'INVALID' is not a valid option" + expect_snapshot(error = TRUE, + read_html(test_path("lego.html.bz2"), options = "INVALID") ) # Empty inputs returned as 0 From 3b868bdbfb90a48c4d5a08705d342cf6a4bd08ed Mon Sep 17 00:00:00 2001 From: olivroy Date: Fri, 1 Dec 2023 13:30:06 -0500 Subject: [PATCH 3/3] Last message conversion to cli. --- R/paths.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/paths.R b/R/paths.R index a64ad6bf..07dca3cd 100644 --- a/R/paths.R +++ b/R/paths.R @@ -55,7 +55,7 @@ zipfile <- function(path, open = "r") { file <- files$Name[[1]] if (nrow(files) > 1) { - message("Multiple files in zip: reading '", file, "'") + cli::cli_inform("Multiple files in zip: reading {.file {file}}") } unz(path, file, open = open)