diff --git a/.Rbuildignore b/.Rbuildignore index 050684fc..969a6605 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,3 +22,5 @@ windows \.dll$ \.o$ \.so$ +^CRAN-SUBMISSION$ +^README\.Rmd$ diff --git a/.github/CODE_OF_CONDUCT.md b/.github/CODE_OF_CONDUCT.md index 03435279..3ac34c82 100644 --- a/.github/CODE_OF_CONDUCT.md +++ b/.github/CODE_OF_CONDUCT.md @@ -1,25 +1,126 @@ -# Contributor Code of Conduct +# Contributor Covenant Code of Conduct -As contributors and maintainers of this project, we pledge to respect all people who -contribute through reporting issues, posting feature requests, updating documentation, -submitting pull requests or patches, and other activities. +## Our Pledge -We are committed to making participation in this project a harassment-free experience for -everyone, regardless of level of experience, gender, gender identity and expression, -sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. +We as members, contributors, and leaders pledge to make participation in our +community a harassment-free experience for everyone, regardless of age, body +size, visible or invisible disability, ethnicity, sex characteristics, gender +identity and expression, level of experience, education, socio-economic status, +nationality, personal appearance, race, caste, color, religion, or sexual +identity and orientation. -Examples of unacceptable behavior by participants include the use of sexual language or -imagery, derogatory comments or personal attacks, trolling, public or private harassment, -insults, or other unprofessional conduct. +We pledge to act and interact in ways that contribute to an open, welcoming, +diverse, inclusive, and healthy community. -Project maintainers have the right and responsibility to remove, edit, or reject comments, -commits, code, wiki edits, issues, and other contributions that are not aligned to this -Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed -from the project team. +## Our Standards -Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by -opening an issue or contacting one or more of the project maintainers. +Examples of behavior that contributes to a positive environment for our +community include: -This Code of Conduct is adapted from the Contributor Covenant -(https://www.contributor-covenant.org), version 1.0.0, available at -https://contributor-covenant.org/version/1/0/0/. +* Demonstrating empathy and kindness toward other people +* Being respectful of differing opinions, viewpoints, and experiences +* Giving and gracefully accepting constructive feedback +* Accepting responsibility and apologizing to those affected by our mistakes, + and learning from the experience +* Focusing on what is best not just for us as individuals, but for the overall + community + +Examples of unacceptable behavior include: + +* The use of sexualized language or imagery, and sexual attention or advances of + any kind +* Trolling, insulting or derogatory comments, and personal or political attacks +* Public or private harassment +* Publishing others' private information, such as a physical or email address, + without their explicit permission +* Other conduct which could reasonably be considered inappropriate in a + professional setting + +## Enforcement Responsibilities + +Community leaders are responsible for clarifying and enforcing our standards of +acceptable behavior and will take appropriate and fair corrective action in +response to any behavior that they deem inappropriate, threatening, offensive, +or harmful. + +Community leaders have the right and responsibility to remove, edit, or reject +comments, commits, code, wiki edits, issues, and other contributions that are +not aligned to this Code of Conduct, and will communicate reasons for moderation +decisions when appropriate. + +## Scope + +This Code of Conduct applies within all community spaces, and also applies when +an individual is officially representing the community in public spaces. +Examples of representing our community include using an official e-mail address, +posting via an official social media account, or acting as an appointed +representative at an online or offline event. + +## Enforcement + +Instances of abusive, harassing, or otherwise unacceptable behavior may be +reported to the community leaders responsible for enforcement at codeofconduct@posit.co. +All complaints will be reviewed and investigated promptly and fairly. + +All community leaders are obligated to respect the privacy and security of the +reporter of any incident. + +## Enforcement Guidelines + +Community leaders will follow these Community Impact Guidelines in determining +the consequences for any action they deem in violation of this Code of Conduct: + +### 1. Correction + +**Community Impact**: Use of inappropriate language or other behavior deemed +unprofessional or unwelcome in the community. + +**Consequence**: A private, written warning from community leaders, providing +clarity around the nature of the violation and an explanation of why the +behavior was inappropriate. A public apology may be requested. + +### 2. Warning + +**Community Impact**: A violation through a single incident or series of +actions. + +**Consequence**: A warning with consequences for continued behavior. No +interaction with the people involved, including unsolicited interaction with +those enforcing the Code of Conduct, for a specified period of time. This +includes avoiding interactions in community spaces as well as external channels +like social media. Violating these terms may lead to a temporary or permanent +ban. + +### 3. Temporary Ban + +**Community Impact**: A serious violation of community standards, including +sustained inappropriate behavior. + +**Consequence**: A temporary ban from any sort of interaction or public +communication with the community for a specified period of time. No public or +private interaction with the people involved, including unsolicited interaction +with those enforcing the Code of Conduct, is allowed during this period. +Violating these terms may lead to a permanent ban. + +### 4. Permanent Ban + +**Community Impact**: Demonstrating a pattern of violation of community +standards, including sustained inappropriate behavior, harassment of an +individual, or aggression toward or disparagement of classes of individuals. + +**Consequence**: A permanent ban from any sort of public interaction within the +community. + +## Attribution + +This Code of Conduct is adapted from the [Contributor Covenant][homepage], +version 2.1, available at +. + +Community Impact Guidelines were inspired by +[Mozilla's code of conduct enforcement ladder][https://github.com/mozilla/inclusion]. + +For answers to common questions about this code of conduct, see the FAQ at +. Translations are available at . + +[homepage]: https://www.contributor-covenant.org diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 4efedd96..ee65ccb5 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -22,26 +22,27 @@ jobs: fail-fast: false matrix: config: - - {os: macOS-latest, r: 'release'} + - {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'} - # Use older ubuntu to maximise backward compatibility - - {os: ubuntu-18.04, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-18.04, r: 'release'} - - {os: ubuntu-18.04, r: 'oldrel-1'} - - {os: ubuntu-18.04, r: 'oldrel-2'} - - {os: ubuntu-18.04, r: 'oldrel-3'} - - {os: ubuntu-18.04, r: 'oldrel-4'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + - {os: ubuntu-latest, r: 'oldrel-2'} + - {os: ubuntu-latest, r: 'oldrel-3'} + - {os: ubuntu-latest, r: 'oldrel-4'} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/setup-pandoc@v2 diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 0b260216..ed7650c7 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -19,8 +19,10 @@ jobs: group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/setup-pandoc@v2 @@ -39,7 +41,7 @@ jobs: - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' - uses: JamesIves/github-pages-deploy-action@4.1.4 + uses: JamesIves/github-pages-deploy-action@v4.4.1 with: clean: false branch: gh-pages diff --git a/.github/workflows/pr-commands.yaml b/.github/workflows/pr-commands.yaml index 97271eb2..71f335b3 100644 --- a/.github/workflows/pr-commands.yaml +++ b/.github/workflows/pr-commands.yaml @@ -14,7 +14,7 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/pr-fetch@v2 with: @@ -51,7 +51,7 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/pr-fetch@v2 with: diff --git a/.github/workflows/rhub.yaml b/.github/workflows/rhub.yaml new file mode 100644 index 00000000..48b12a46 --- /dev/null +++ b/.github/workflows/rhub.yaml @@ -0,0 +1,79 @@ +# R-hub's genetic GitHub Actions workflow file. It's canonical location is at +# https://github.com/r-hub/rhub2/blob/v1/inst/workflow/rhub.yaml +# You can update this file to a newer version using the rhub2 package: +# +# rhub2::rhub_setup() +# +# It is unlikely that you need to modify this file manually. + +name: R-hub +run-name: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }} (${{ github.event.inputs.id }}) + +on: + workflow_dispatch: + inputs: + config: + description: 'A comma separated list of R-hub platforms to use.' + type: string + default: 'linux,windows,macos' + name: + description: 'Run name. You can leave this empty now.' + type: string + id: + description: 'Unique ID. You can leave this empty now.' + type: string + +jobs: + + setup: + runs-on: ubuntu-latest + outputs: + containers: ${{ steps.rhub-setup.outputs.containers }} + platforms: ${{ steps.rhub-setup.outputs.platforms }} + + steps: + # NO NEED TO CHECKOUT HERE + - uses: r-hub/rhub2/actions/rhub-setup@v1 + with: + config: ${{ github.event.inputs.config }} + id: rhub-setup + + linux-containers: + needs: setup + if: ${{ needs.setup.outputs.containers != '[]' }} + runs-on: ubuntu-latest + name: ${{ matrix.config.label }} + strategy: + fail-fast: false + matrix: + config: ${{ fromJson(needs.setup.outputs.containers) }} + container: + image: ${{ matrix.config.container }} + + steps: + - uses: actions/checkout@v3 + - uses: r-hub/rhub2/actions/rhub-check@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + + other-platforms: + needs: setup + if: ${{ needs.setup.outputs.platforms != '[]' }} + runs-on: ${{ matrix.config.os }} + name: ${{ matrix.config.label }} + strategy: + fail-fast: false + matrix: + config: ${{ fromJson(needs.setup.outputs.platforms) }} + + steps: + - uses: actions/checkout@v3 + - uses: r-hub/rhub2/actions/rhub-setup-r@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} + - uses: r-hub/rhub2/actions/rhub-check@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 4b654182..27d45283 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -15,7 +15,7 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: r-lib/actions/setup-r@v2 with: @@ -27,5 +27,24 @@ jobs: needs: coverage - name: Test coverage - run: covr::codecov(quiet = FALSE) + run: | + covr::codecov( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) shell: Rscript {0} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v3 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index e21d0dea..bbe806ac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,11 +1,11 @@ Package: xml2 Title: Parse XML -Version: 1.3.3.9000 +Version: 1.3.5.9000 Authors@R: c( - person("Hadley", "Wickham", , "hadley@rstudio.com", role = c("aut", "cre")), + person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre")), person("Jim", "Hester", role = "aut"), person("Jeroen", "Ooms", role = "aut"), - person("RStudio", role = c("cph", "fnd")), + person("Posit Software, PBC", role = c("cph", "fnd")), person("R Foundation", role = "ctb", comment = "Copy of R-project homepage cached as example") ) @@ -15,9 +15,11 @@ License: MIT + file LICENSE URL: https://xml2.r-lib.org/, https://github.com/r-lib/xml2 BugReports: https://github.com/r-lib/xml2/issues Depends: - R (>= 3.1.0) + R (>= 3.6.0) Imports: - methods + cli, + methods, + rlang (>= 1.1.0) Suggests: covr, curl, @@ -26,13 +28,13 @@ Suggests: magrittr, mockery, rmarkdown, - testthat (>= 2.1.0) + testthat (>= 3.0.0) VignetteBuilder: knitr Config/Needs/website: tidyverse/tidytemplate Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.3 SystemRequirements: libxml2: libxml2-dev (deb), libxml2-devel (rpm) Collate: 'S4.R' @@ -40,15 +42,25 @@ Collate: 'xml_parse.R' 'as_xml_document.R' 'classes.R' + 'format.R' + 'import-standalone-obj-type.R' + 'import-standalone-purrr.R' + 'import-standalone-types-check.R' 'init.R' + 'nodeset_apply.R' 'paths.R' 'utils.R' + 'xml2-package.R' 'xml_attr.R' 'xml_children.R' + 'xml_document.R' 'xml_find.R' + 'xml_missing.R' 'xml_modify.R' 'xml_name.R' 'xml_namespaces.R' + 'xml_node.R' + 'xml_nodeset.R' 'xml_path.R' 'xml_schema.R' 'xml_serialize.R' @@ -58,3 +70,4 @@ Collate: 'xml_url.R' 'xml_write.R' 'zzz.R' +Config/testthat/edition: 3 diff --git a/LICENSE b/LICENSE index 3cfc33ba..1c743f16 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ -YEAR: 2020 +YEAR: 2023 COPYRIGHT HOLDER: xml2 authors diff --git a/LICENSE.md b/LICENSE.md index 9fd9ca9d..a8f2e368 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ # MIT License -Copyright (c) 2020 xml2 authors +Copyright (c) 2023 xml2 authors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/NAMESPACE b/NAMESPACE index 36fb3b71..472fe4f4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -86,6 +86,7 @@ S3method(xml_find_all,xml_nodeset) S3method(xml_find_chr,xml_missing) S3method(xml_find_chr,xml_node) S3method(xml_find_chr,xml_nodeset) +S3method(xml_find_first,xml_missing) S3method(xml_find_first,xml_node) S3method(xml_find_first,xml_nodeset) S3method(xml_find_lgl,xml_missing) @@ -211,5 +212,6 @@ exportClasses(xml_document) exportClasses(xml_missing) exportClasses(xml_node) exportClasses(xml_nodeset) +import(rlang) importFrom(methods,setOldClass) useDynLib(xml2, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index a6ff2200..e59f61c5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,19 @@ # xml2 (development version) +* Remove unused dependencies on glue, withr and lifecycle (@mgirlich). + +# xml2 1.3.5 + +* Small speedup for `xml_find_all()` (@mgirlich, #393). + +* Fixes for R CMD check problems. + +# xml2 1.3.4 + +* Fixes for R CMD check problems. + +* Windows: update to libxml2 2.10.3 + # xml2 1.3.3 * Hadley Wickham is now (again) the maintainer. diff --git a/R/as_list.R b/R/as_list.R index b0e93686..be9474fc 100644 --- a/R/as_list.R +++ b/R/as_list.R @@ -52,10 +52,12 @@ as_list.xml_node <- function(x, ns = character(), ...) { # Base case - contents type <- xml_type(x) - if (type %in% c("text", "cdata")) + if (type %in% c("text", "cdata")) { return(xml_text(x)) - if (type != "element" && type != "document") + } + if (type != "element" && type != "document") { return(paste("[", type, "]")) + } out <- list() } else { diff --git a/R/as_xml_document.R b/R/as_xml_document.R index 6b06ad9f..2b147c32 100644 --- a/R/as_xml_document.R +++ b/R/as_xml_document.R @@ -10,16 +10,17 @@ #' @export #' @examples # empty lists generate empty nodes -#'as_xml_document(list(x = list())) +#' as_xml_document(list(x = list())) #' -#'# Nesting multiple nodes -#'as_xml_document(list(foo = list(bar = list(baz = list())))) +#' # Nesting multiple nodes +#' as_xml_document(list(foo = list(bar = list(baz = list())))) #' -#'# attributes are stored as R attributes -#'as_xml_document(list(foo = structure(list(), id = "a"))) -#'as_xml_document(list(foo = list( -#' bar = structure(list(), id = "a"), -#' bar = structure(list(), id = "b")))) +#' # attributes are stored as R attributes +#' as_xml_document(list(foo = structure(list(), id = "a"))) +#' as_xml_document(list(foo = list( +#' bar = structure(list(), id = "a"), +#' bar = structure(list(), id = "b") +#' ))) as_xml_document <- function(x, ...) { UseMethod("as_xml_document") } @@ -39,7 +40,7 @@ as_xml_document.response <- read_xml.response #' @export as_xml_document.list <- function(x, ...) { if (length(x) > 1) { - stop("Root nodes must be of length 1", call. = FALSE) + abort("Root nodes must be of length 1") } diff --git a/R/classes.R b/R/classes.R index 14a9b722..160829dc 100644 --- a/R/classes.R +++ b/R/classes.R @@ -1,240 +1,6 @@ #' @useDynLib xml2, .registration = TRUE NULL -# node ------------------------------------------------------------------------- - -xml_node <- function(node = NULL, doc = NULL) { - if (inherits(node, "xml_node")) { - node - } else { - structure(list(node = node, doc = doc), class = "xml_node") - } -} - -#' @export -as.character.xml_node <- function(x, ..., options = "format", encoding = "UTF-8") { - options <- parse_options(options, xml_save_options()) - .Call(node_write_character, x$node, encoding, options) -} - -#' @export -print.xml_node <- function(x, width = getOption("width"), max_n = 20, ...) { - cat("{", doc_type(x), "_node}\n", sep = "") - cat(format(x), "\n", sep = "") - show_nodes(xml_children(x), width = width, max_n = max_n) -} - -#' @export -print.xml_missing <- function(x, width = getOption("width"), max_n = 20, ...) { - cat("{xml_missing}\n") - cat(format(x), "\n", sep = "") -} - -# document --------------------------------------------------------------------- - -xml_document <- function(doc) { - if (.Call(doc_has_root, doc)) { - x <- xml_node(.Call(doc_root, doc), doc) - class(x) <- c("xml_document", class(x)) - x - } else { - structure(list(doc = doc), class = "xml_document") - } -} - -doc_type <- function(x) { - if (is.null(x$doc)) { - return("xml") - } - if (.Call(doc_is_html, x$doc)) { - "html" - } else { - "xml" - } -} - -#' @export -print.xml_document <- function(x, width = getOption("width"), max_n = 20, ...) { - doc <- xml_document(x$doc) - cat("{", doc_type(x), "_document}\n", sep = "") - if (inherits(doc, "xml_node")) { - cat(format(doc), "\n", sep = "") - show_nodes(xml_children(doc), width = width, max_n = max_n) - } -} - -#' @export -as.character.xml_document <- function(x, ..., options = "format", encoding = "UTF-8") { - options <- parse_options(options, xml_save_options()) - .Call(doc_write_character, x$doc, encoding, options) -} - -# nodeset ---------------------------------------------------------------------- - -xml_nodeset <- function(nodes = list(), deduplicate = TRUE) { - if (isTRUE(deduplicate)) { - nodes <- nodes[!.Call(nodes_duplicated, nodes)] - } - structure(nodes, class = "xml_nodeset") -} - -#' @param nodes A list (possible nested) of external pointers to nodes -#' @return a nodeset -#' @noRd -make_nodeset <- function(nodes, doc) { - nodes <- unlist(nodes, recursive = FALSE) - - xml_nodeset(lapply(nodes, xml_node, doc = doc)) -} - -#' @export -print.xml_nodeset <- function(x, width = getOption("width"), max_n = 20, ...) { - n <- length(x) - cat("{", doc_type(x), "_nodeset (", n, ")}\n", sep = "") - - if (n > 0) - show_nodes(x, width = width, max_n = max_n) -} - -#' @export -as.character.xml_nodeset <- function(x, ...) { - vapply(x, as.character, FUN.VALUE = character(1)) -} - -#' @export -`[.xml_nodeset` <- function(x, i, ...) { - if (length(x) == 0) { - return(x) - } - xml_nodeset(NextMethod()) -} - -show_nodes <- function(x, width = getOption("width"), max_n = 20) { - stopifnot(inherits(x, "xml_nodeset")) - - n <- length(x) - if (n == 0) - return() - - if (n > max_n) { - n <- max_n - x <- x[seq_len(n)] - trunc <- TRUE - } else { - trunc <- FALSE - } - - label <- format(paste0("[", seq_len(n), "]"), justify = "right") - contents <- encodeString(vapply(x, as.character, FUN.VALUE = character(1))) - - desc <- paste0(label, " ", contents) - needs_trunc <- nchar(desc) > width - desc[needs_trunc] <- paste(substr(desc[needs_trunc], 1, width - 3), "...") - - cat(desc, sep = "\n") - if (trunc) { - cat("...\n") - } - invisible() -} - - -nodeset_apply <- function(x, fun, ...) UseMethod("nodeset_apply") - -#' @export -nodeset_apply.xml_missing <- function(x, fun, ...) { - xml_nodeset() -} - -#' @export -nodeset_apply.xml_nodeset <- function(x, fun, ...) { - if (length(x) == 0) - return(xml_nodeset()) - - is_missing <- is.na(x) - res <- list(length(x)) - - res[is_missing] <- list(xml_missing()) - if (any(!is_missing)) { - res[!is_missing] <- lapply(x[!is_missing], function(x) fun(x$node, ...)) - } - - make_nodeset(res, x[[1]]$doc) -} - -#' @export -nodeset_apply.xml_node <- function(x, fun, ...) { - nodes <- fun(x$node, ...) - xml_nodeset(lapply(nodes, xml_node, doc = x$doc)) -} - -#' @export -nodeset_apply.xml_document <- function(x, fun, ...) { - if (inherits(x, "xml_node")) { - NextMethod() - } else { - xml_nodeset() - } -} - -#' @export -format.xml_node <- function(x, ...) { - attrs <- xml_attrs(x) - paste("<", - paste( - c(xml_name(x), - format_attributes(attrs)), - collapse = " "), - ">", sep = "") -} - -format_attributes <- function(x) { - if (length(x) == 0) { - character(0) - } else { - paste(names(x), quote_str(x), sep = "=") - } -} - -#' Construct an missing xml object -#' @export -#' @keywords internal -xml_missing <- function() { - structure(list(), class = "xml_missing") -} - -#' @export -is.na.xml_missing <- function(x) { - TRUE -} - -#' @export -is.na.xml_nodeset <- function(x) { - vapply(x, is.na, logical(1)) -} - -#' @export -is.na.xml_node <- function(x) { - FALSE -} - -format.xml_missing <- function(x, ...) { - "" -} - -#' @export -as.character.xml_missing <- function(x, ...) { - NA_character_ -} - -# These mimic the behavior of NA[[1]], NA[[2]], NA[1], NA[2] - -#' @export -`[.xml_missing` <- function(x, i, ...) x - -#' @export -`[[.xml_missing` <- function(x, i, ...) if (i == 1L) x else stop("subscript out of bounds") - #' Construct a cdata node #' @param content The CDATA content, does not include ` #' #' ]> -#' This is a valid document &foo; !') +#' This is a valid document &foo; !' +#' ) #' @export xml_dtd <- function(name = "", external_id = "", system_id = "") { - structure(list(name = name, external_id = external_id, system_id = system_id), class = "xml_dtd") + out <- list(name = name, external_id = external_id, system_id = system_id) + class(out) <- "xml_dtd" + out } diff --git a/R/format.R b/R/format.R new file mode 100644 index 00000000..51d61137 --- /dev/null +++ b/R/format.R @@ -0,0 +1,23 @@ +#' @export +format.xml_node <- function(x, ...) { + attrs <- xml_attrs(x) + paste("<", + paste( + c( + xml_name(x), + format_attributes(attrs) + ), + collapse = " " + ), + ">", + sep = "" + ) +} + +format_attributes <- function(x) { + if (length(x) == 0) { + character(0) + } else { + paste(names(x), quote_str(x), sep = "=") + } +} diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 00000000..8e3c07df --- /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-purrr.R b/R/import-standalone-purrr.R new file mode 100644 index 00000000..623142a0 --- /dev/null +++ b/R/import-standalone-purrr.R @@ -0,0 +1,240 @@ +# Standalone file: do not edit by hand +# Source: +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-purrr.R +# last-updated: 2023-02-23 +# license: https://unlicense.org +# imports: rlang +# --- +# +# This file provides a minimal shim to provide a purrr-like API on top of +# base R functions. They are not drop-in replacements but allow a similar style +# of programming. +# +# ## Changelog +# +# 2023-02-23: +# * Added `list_c()` +# +# 2022-06-07: +# * `transpose()` is now more consistent with purrr when inner names +# are not congruent (#1346). +# +# 2021-12-15: +# * `transpose()` now supports empty lists. +# +# 2021-05-21: +# * Fixed "object `x` not found" error in `imap()` (@mgirlich) +# +# 2020-04-14: +# * Removed `pluck*()` functions +# * Removed `*_cpl()` functions +# * Used `as_function()` to allow use of `~` +# * Used `.` prefix for helpers +# +# nocov start + +map <- function(.x, .f, ...) { + .f <- as_function(.f, env = global_env()) + lapply(.x, .f, ...) +} +walk <- function(.x, .f, ...) { + map(.x, .f, ...) + invisible(.x) +} + +map_lgl <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, logical(1), ...) +} +map_int <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, integer(1), ...) +} +map_dbl <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, double(1), ...) +} +map_chr <- function(.x, .f, ...) { + .rlang_purrr_map_mold(.x, .f, character(1), ...) +} +.rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { + .f <- as_function(.f, env = global_env()) + out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) + names(out) <- names(.x) + out +} + +map2 <- function(.x, .y, .f, ...) { + .f <- as_function(.f, env = global_env()) + out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) + if (length(out) == length(.x)) { + set_names(out, names(.x)) + } else { + set_names(out, NULL) + } +} +map2_lgl <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "logical") +} +map2_int <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "integer") +} +map2_dbl <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "double") +} +map2_chr <- function(.x, .y, .f, ...) { + as.vector(map2(.x, .y, .f, ...), "character") +} +imap <- function(.x, .f, ...) { + map2(.x, names(.x) %||% seq_along(.x), .f, ...) +} + +pmap <- function(.l, .f, ...) { + .f <- as.function(.f) + args <- .rlang_purrr_args_recycle(.l) + do.call("mapply", c( + FUN = list(quote(.f)), + args, MoreArgs = quote(list(...)), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) +} +.rlang_purrr_args_recycle <- function(args) { + lengths <- map_int(args, length) + n <- max(lengths) + + stopifnot(all(lengths == 1L | lengths == n)) + to_recycle <- lengths == 1L + args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) + + args +} + +keep <- function(.x, .f, ...) { + .x[.rlang_purrr_probe(.x, .f, ...)] +} +discard <- function(.x, .p, ...) { + sel <- .rlang_purrr_probe(.x, .p, ...) + .x[is.na(sel) | !sel] +} +map_if <- function(.x, .p, .f, ...) { + matches <- .rlang_purrr_probe(.x, .p) + .x[matches] <- map(.x[matches], .f, ...) + .x +} +.rlang_purrr_probe <- function(.x, .p, ...) { + if (is_logical(.p)) { + stopifnot(length(.p) == length(.x)) + .p + } else { + .p <- as_function(.p, env = global_env()) + map_lgl(.x, .p, ...) + } +} + +compact <- function(.x) { + Filter(length, .x) +} + +transpose <- function(.l) { + if (!length(.l)) { + return(.l) + } + + inner_names <- names(.l[[1]]) + + if (is.null(inner_names)) { + fields <- seq_along(.l[[1]]) + } else { + fields <- set_names(inner_names) + .l <- map(.l, function(x) { + if (is.null(names(x))) { + set_names(x, inner_names) + } else { + x + } + }) + } + + # This way missing fields are subsetted as `NULL` instead of causing + # an error + .l <- map(.l, as.list) + + map(fields, function(i) { + map(.l, .subset2, i) + }) +} + +every <- function(.x, .p, ...) { + .p <- as_function(.p, env = global_env()) + + for (i in seq_along(.x)) { + if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) + } + TRUE +} +some <- function(.x, .p, ...) { + .p <- as_function(.p, env = global_env()) + + for (i in seq_along(.x)) { + if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) + } + FALSE +} +negate <- function(.p) { + .p <- as_function(.p, env = global_env()) + function(...) !.p(...) +} + +reduce <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(x, y, ...) + Reduce(f, .x, init = .init) +} +reduce_right <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(y, x, ...) + Reduce(f, .x, init = .init, right = TRUE) +} +accumulate <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(x, y, ...) + Reduce(f, .x, init = .init, accumulate = TRUE) +} +accumulate_right <- function(.x, .f, ..., .init) { + f <- function(x, y) .f(y, x, ...) + Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) +} + +detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { + .p <- as_function(.p, env = global_env()) + .f <- as_function(.f, env = global_env()) + + for (i in .rlang_purrr_index(.x, .right)) { + if (.p(.f(.x[[i]], ...))) { + return(.x[[i]]) + } + } + NULL +} +detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { + .p <- as_function(.p, env = global_env()) + .f <- as_function(.f, env = global_env()) + + for (i in .rlang_purrr_index(.x, .right)) { + if (.p(.f(.x[[i]], ...))) { + return(i) + } + } + 0L +} +.rlang_purrr_index <- function(x, right = FALSE) { + idx <- seq_along(x) + if (right) { + idx <- rev(idx) + } + idx +} + +list_c <- function(x) { + inject(c(!!!x)) +} + +# nocov end diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 00000000..6782d69b --- /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/init.R b/R/init.R index 1a7ffc3e..b137315b 100644 --- a/R/init.R +++ b/R/init.R @@ -1,4 +1,4 @@ -.onLoad <- function(lib, pkg){ +.onLoad <- function(lib, pkg) { .Call(init_libxml2) } diff --git a/R/nodeset_apply.R b/R/nodeset_apply.R new file mode 100644 index 00000000..50770e32 --- /dev/null +++ b/R/nodeset_apply.R @@ -0,0 +1,38 @@ +nodeset_apply <- function(x, fun, ...) UseMethod("nodeset_apply") + +#' @export +nodeset_apply.xml_missing <- function(x, fun, ...) { + xml_nodeset() +} + +#' @export +nodeset_apply.xml_nodeset <- function(x, fun, ...) { + if (length(x) == 0) { + return(xml_nodeset()) + } + + is_missing <- is.na(x) + res <- list(length(x)) + + res[is_missing] <- list(xml_missing()) + if (any(!is_missing)) { + res[!is_missing] <- lapply(x[!is_missing], function(x) fun(x$node, ...)) + } + + make_nodeset(res, x[[1]]$doc) +} + +#' @export +nodeset_apply.xml_node <- function(x, fun, ...) { + nodes <- fun(x$node, ...) + xml_nodeset(lapply(nodes, xml_node, doc = x$doc)) +} + +#' @export +nodeset_apply.xml_document <- function(x, fun, ...) { + if (inherits(x, "xml_node")) { + NextMethod() + } else { + xml_nodeset() + } +} diff --git a/R/paths.R b/R/paths.R index e2d98df2..a64ad6bf 100644 --- a/R/paths.R +++ b/R/paths.R @@ -1,8 +1,9 @@ path_to_connection <- function(path, check = c("file", "dir")) { check <- match.arg(check) - if (!is.character(path) || length(path) != 1L) + if (!is.character(path) || length(path) != 1L) { return(path) + } if (is_url(path)) { if (requireNamespace("curl", quietly = TRUE)) { @@ -30,16 +31,19 @@ is_url <- function(path) { grepl("^(http|ftp)s?://", path) } -check_path <- function(path) { - if (file.exists(path)) +check_path <- function(path, call = caller_env()) { + if (file.exists(path)) { return(normalizePath(path, "/", mustWork = FALSE)) + } - stop("'", path, "' does not exist", - if (!is_absolute_path(path)) - paste0(" in current working directory ('", getwd(), "')"), - ".", - call. = FALSE - ) + + msg <- "{.file {path}} does not exist" + if (!is_absolute_path(path)) { + msg <- paste0(msg, " in current working directory ({.path {getwd()}})") + } + msg <- paste0(msg, ".") + + cli::cli_abort(msg, call = call) } is_absolute_path <- function(path) { diff --git a/R/utils.R b/R/utils.R index 89ebe009..e5d26aeb 100644 --- a/R/utils.R +++ b/R/utils.R @@ -26,19 +26,15 @@ is_installed <- function(pkg) { requireNamespace(pkg, quietly = TRUE) } -need_package <- function(pkg) { - if (is_installed(pkg)) return(invisible()) - - stop("Please install ", pkg, " package", call. = FALSE) -} - # Format the C bitwise flags for display in Rd. The input object is a named # integer vector with a 'descriptions' character vector attribute that # corresponds to each flag. describe_options <- function(x) { - paste0("\\describe{\n", + paste0( + "\\describe{\n", paste0(" \\item{", names(x), "}{", attr(x, "descriptions"), "}", collapse = "\n"), - "\n}") + "\n}" + ) } s_quote <- function(x) paste0("'", x, "'") @@ -59,10 +55,14 @@ parse_options <- function(arg, options) { # 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) + 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 + ) } sum(options[unique(i)]) } diff --git a/R/xml2-package.R b/R/xml2-package.R new file mode 100644 index 00000000..d248733b --- /dev/null +++ b/R/xml2-package.R @@ -0,0 +1,7 @@ +#' @keywords internal +"_PACKAGE" + +## usethis namespace: start +#' @import rlang +## usethis namespace: end +NULL diff --git a/R/xml_attr.R b/R/xml_attr.R index 6ad0768c..1f2a2fca 100644 --- a/R/xml_attr.R +++ b/R/xml_attr.R @@ -75,10 +75,16 @@ xml_attr.xml_node <- function(x, attr, ns = character(), } #' @export -xml_attr.xml_nodeset <- function(x, attr, ns = character(), +xml_attr.xml_nodeset <- function(x, attr, ns = character(), default = NA_character_) { - vapply(x, xml_attr, attr = attr, default = default, ns = ns, - FUN.VALUE = character(1)) + vapply( + x, + xml_attr, + attr = attr, + default = default, + ns = ns, + FUN.VALUE = character(1) + ) } #' @export @@ -175,7 +181,7 @@ xml_set_attr.xml_missing <- set_attr_fun #' @export `xml_attrs<-.xml_node` <- function(x, ns = character(), value) { if (!is_named(value)) { - stop("`value` must be a named character vector or `NULL`", call. = FALSE) + cli::cli_abort("{.arg value} must be a named character vector or `NULL`") } attrs <- names(value) @@ -191,7 +197,7 @@ xml_set_attr.xml_missing <- set_attr_fun # replace existing attributes and add new ones Map(function(attr, val) { - xml_attr(x, attr, ns) <- val + xml_attr(x, attr, ns) <- val }, attr = c(existing, new), value[c(existing, new)]) @@ -209,13 +215,13 @@ xml_set_attr.xml_missing <- set_attr_fun return(x) } if (!is.list(ns)) { - ns <- list(ns) + ns <- list(ns) } if (!is.list(value)) { - value <- list(value) + value <- list(value) } if (!all(vapply(value, is_named, logical(1)))) { - stop("`value` must be a list of named character vectors") + cli::cli_abort("{.arg {value}} must be a list of named character vectors.") } Map(`xml_attrs<-`, x, ns, value) diff --git a/R/xml_children.R b/R/xml_children.R index faabd857..56f424a7 100644 --- a/R/xml_children.R +++ b/R/xml_children.R @@ -45,7 +45,7 @@ xml_children <- function(x) { #' @rdname xml_children xml_child <- function(x, search = 1, ns = xml_ns(x)) { if (length(search) != 1) { - stop("`search` must be of length 1", call. = FALSE) + cli::cli_abort("{.arg {search}} must be of length 1.") } if (is.numeric(search)) { @@ -53,7 +53,7 @@ xml_child <- function(x, search = 1, ns = xml_ns(x)) { } else if (is.character(search)) { xml_find_first(x, xpath = paste0("./", search), ns = ns) } else { - stop("`search` must be `numeric` or `character`", call. = FALSE) + cli::cli_abort("{.arg search} must be `numeric` or `character`.") } } @@ -115,8 +115,9 @@ xml_length.xml_node <- function(x, only_elements = TRUE) { #' @export xml_length.xml_nodeset <- function(x, only_elements = TRUE) { - if (length(x) == 0) + if (length(x) == 0) { return(0L) + } vapply(x, xml_length, only_elements = only_elements, FUN.VALUE = integer(1)) } diff --git a/R/xml_document.R b/R/xml_document.R new file mode 100644 index 00000000..527524bc --- /dev/null +++ b/R/xml_document.R @@ -0,0 +1,38 @@ +xml_document <- function(doc) { + if (.Call(doc_has_root, doc)) { + x <- xml_node(.Call(doc_root, doc), doc) + class(x) <- c("xml_document", class(x)) + x + } else { + out <- list(doc = doc) + class(out) <- "xml_document" + out + } +} + +doc_type <- function(x) { + if (is.null(x$doc)) { + return("xml") + } + if (.Call(doc_is_html, x$doc)) { + "html" + } else { + "xml" + } +} + +#' @export +print.xml_document <- function(x, width = getOption("width"), max_n = 20, ...) { + doc <- xml_document(x$doc) + cat("{", doc_type(x), "_document}\n", sep = "") + if (inherits(doc, "xml_node")) { + cat(format(doc), "\n", sep = "") + show_nodes(xml_children(doc), width = width, max_n = max_n) + } +} + +#' @export +as.character.xml_document <- function(x, ..., options = "format", encoding = "UTF-8") { + options <- parse_options(options, xml_save_options()) + .Call(doc_write_character, x$doc, encoding, options) +} diff --git a/R/xml_find.R b/R/xml_find.R index 1f46b634..4dac21cb 100644 --- a/R/xml_find.R +++ b/R/xml_find.R @@ -94,8 +94,9 @@ xml_find_all.xml_node <- function(x, xpath, ns = xml_ns(x), ...) { #' @export #' @rdname xml_find_all xml_find_all.xml_nodeset <- function(x, xpath, ns = xml_ns(x), flatten = TRUE, ...) { - if (length(x) == 0) + if (length(x) == 0) { return(xml_nodeset()) + } res <- lapply(x, function(x) .Call(xpath_search, x$node, x$doc, xpath, ns, Inf)) @@ -113,6 +114,7 @@ xml_find_first <- function(x, xpath, ns = xml_ns(x)) { UseMethod("xml_find_first") } +#' @export xml_find_first.xml_missing <- function(x, xpath, ns = xml_ns(x)) { xml_missing() } @@ -121,7 +123,7 @@ xml_find_first.xml_missing <- function(x, xpath, ns = xml_ns(x)) { xml_find_first.xml_node <- function(x, xpath, ns = xml_ns(x)) { res <- .Call(xpath_search, x$node, x$doc, xpath, ns, 1) if (length(res) == 1) { - res[[1]] + res[[1]] } else { res } @@ -129,11 +131,19 @@ xml_find_first.xml_node <- function(x, xpath, ns = xml_ns(x)) { #' @export xml_find_first.xml_nodeset <- function(x, xpath, ns = xml_ns(x)) { - if (length(x) == 0) + if (length(x) == 0) { return(xml_nodeset()) + } - xml_nodeset(lapply(x, function(x) - xml_find_first(x, xpath = xpath, ns = ns)), deduplicate = FALSE) + xml_nodeset( + lapply( + x, + function(x) { + xml_find_first(x, xpath = xpath, ns = ns) + } + ), + deduplicate = FALSE + ) } @@ -146,23 +156,26 @@ xml_find_num <- function(x, xpath, ns = xml_ns(x)) { #' @export xml_find_num.xml_node <- function(x, xpath, ns = xml_ns(x)) { res <- .Call(xpath_search, x$node, x$doc, xpath, ns, Inf) - if (!is.numeric(res)) { - stop("result of type: ", sQuote(class(res)), ", not numeric", call. = FALSE) + if (is.numeric(res) && is.nan(res)) { + return(res) } + + check_number_decimal(res, arg = I(paste0("Element at path `", xpath, "`"))) res } #' @export xml_find_num.xml_nodeset <- function(x, xpath, ns = xml_ns(x)) { - if (length(x) == 0) + if (length(x) == 0) { return(numeric()) + } vapply(x, function(x) xml_find_num(x, xpath = xpath, ns = ns), numeric(1)) } #' @export xml_find_num.xml_missing <- function(x, xpath, ns = xml_ns(x)) { - numeric(0) + numeric(0) } #' @export @@ -174,23 +187,22 @@ xml_find_chr <- function(x, xpath, ns = xml_ns(x)) { #' @export xml_find_chr.xml_node <- function(x, xpath, ns = xml_ns(x)) { res <- .Call(xpath_search, x$node, x$doc, xpath, ns, Inf) - if (!is.character(res)) { - stop("result of type: ", sQuote(class(res)), ", not character", call. = FALSE) - } + check_string(res, arg = I(paste0("Element at path `", xpath, "`"))) res } #' @export xml_find_chr.xml_nodeset <- function(x, xpath, ns = xml_ns(x)) { - if (length(x) == 0) + if (length(x) == 0) { return(character()) + } vapply(x, function(x) xml_find_chr(x, xpath = xpath, ns = ns), character(1)) } #' @export xml_find_chr.xml_missing <- function(x, xpath, ns = xml_ns(x)) { - character(0) + character(0) } #' @export @@ -202,23 +214,22 @@ xml_find_lgl <- function(x, xpath, ns = xml_ns(x)) { #' @export xml_find_lgl.xml_node <- function(x, xpath, ns = xml_ns(x)) { res <- .Call(xpath_search, x$node, x$doc, xpath, ns, Inf) - if (!is.logical(res)) { - stop("result of type: ", sQuote(class(res)), ", not logical", call. = FALSE) - } + check_bool(res, arg = I(paste0("Element at path `", xpath, "`"))) res } #' @export xml_find_lgl.xml_nodeset <- function(x, xpath, ns = xml_ns(x)) { - if (length(x) == 0) + if (length(x) == 0) { return(logical()) + } vapply(x, function(x) xml_find_lgl(x, xpath = xpath, ns = ns), logical(1)) } #' @export xml_find_lgl.xml_missing <- function(x, xpath, ns = xml_ns(x)) { - logical(0) + logical(0) } # Deprecated functions ---------------------------------------------------- diff --git a/R/xml_missing.R b/R/xml_missing.R new file mode 100644 index 00000000..1e7d0c69 --- /dev/null +++ b/R/xml_missing.R @@ -0,0 +1,36 @@ +#' Construct an missing xml object +#' @export +#' @keywords internal +xml_missing <- function() { + out <- list() + class(out) <- "xml_missing" + out +} + +format.xml_missing <- function(x, ...) { + "" +} + +#' @export +print.xml_missing <- function(x, width = getOption("width"), max_n = 20, ...) { + cat("{xml_missing}\n") + cat(format(x), "\n", sep = "") +} + +#' @export +as.character.xml_missing <- function(x, ...) { + NA_character_ +} + +# These mimic the behavior of NA[[1]], NA[[2]], NA[1], NA[2] + +#' @export +`[.xml_missing` <- function(x, i, ...) x + +#' @export +`[[.xml_missing` <- function(x, i, ...) if (i == 1L) x else abort("subscript out of bounds") + +#' @export +is.na.xml_missing <- function(x) { + TRUE +} diff --git a/R/xml_modify.R b/R/xml_modify.R index e78a10a4..7411f836 100644 --- a/R/xml_modify.R +++ b/R/xml_modify.R @@ -27,7 +27,6 @@ xml_replace <- function(.x, .value, ..., .copy = TRUE) { #' @export xml_replace.xml_node <- function(.x, .value, ..., .copy = TRUE) { - node <- create_node(.value, .parent = .x, .copy = .copy, ...) .x$node <- .Call(node_replace, .x$node, node$node) @@ -36,7 +35,6 @@ xml_replace.xml_node <- function(.x, .value, ..., .copy = TRUE) { #' @export xml_replace.xml_nodeset <- function(.x, .value, ..., .copy = TRUE) { - if (length(.x) == 0) { return(.x) } @@ -68,7 +66,8 @@ xml_add_sibling.xml_node <- function(.x, .value, ..., .where = c("after", "befor .x$node <- switch(.where, before = .Call(node_prepend_sibling, .x$node, node$node), - after = .Call(node_append_sibling, .x$node, node$node)) + after = .Call(node_append_sibling, .x$node, node$node) + ) invisible(.x) } @@ -116,17 +115,16 @@ create_node <- function(.value, ..., .parent, .copy) { return() } - if (!is.character(.value)) { - stop("`.value` must be a character", call. = FALSE) - } + check_character(.value) parts <- strsplit(.value, ":")[[1]] if (length(parts) == 2 && !is.null(.parent$node)) { - namespace <- .Call(ns_lookup, .parent$doc, .parent$node, parts[[1]]) - node <- structure(list(node = .Call(node_new_ns, parts[[2]], namespace), doc = .parent$doc), class = "xml_node") + namespace <- .Call(ns_lookup, .parent$doc, .parent$node, parts[[1]]) + node <- list(node = .Call(node_new_ns, parts[[2]], namespace), doc = .parent$doc) } else { - node <- structure(list(node = .Call(node_new, .value), doc = .parent$doc), class = "xml_node") + node <- list(node = .Call(node_new, .value), doc = .parent$doc) } + class(node) <- "xml_node" args <- list(...) named <- has_names(args) @@ -144,22 +142,21 @@ xml_add_child <- function(.x, .value, ..., .where = length(xml_children(.x)), .c #' @export xml_add_child.xml_node <- function(.x, .value, ..., .where = length(xml_children(.x)), .copy = inherits(.value, "xml_node")) { - node <- create_node(.value, .parent = .x, .copy = .copy, ...) if (.where == 0L) { - if(.Call(node_has_children, .x$node, TRUE)) { + if (.Call(node_has_children, .x$node, TRUE)) { .Call(node_prepend_child, .x$node, node$node) - } - else { + } else { .Call(node_append_child, .x$node, node$node) } } else { num_children <- length(xml_children(.x)) if (.where >= num_children) { .Call(node_append_child, .x$node, node$node) - } else + } else { .Call(node_append_sibling, xml_child(.x, search = .where)$node, node$node) + } } invisible(node) @@ -238,7 +235,7 @@ xml_add_parent.xml_missing <- function(.x, .value, ..., .copy = TRUE) { #' @rdname xml_replace #' @export xml_remove <- function(.x, free = FALSE) { - UseMethod("xml_remove") + UseMethod("xml_remove") } #' @export @@ -296,7 +293,9 @@ xml_set_namespace <- function(.x, prefix = "", uri = "") { # TODO: jimhester 2016-12-16 Deprecate this in the future? xml_new_document <- function(version = "1.0", encoding = "UTF-8") { doc <- .Call(doc_new, version, encoding) - structure(list(doc = doc), class = "xml_document") + out <- list(doc = doc) + class(out) <- "xml_document" + out } #' @param .version The version number of the document, passed to `xml_new_document(version)`. @@ -313,12 +312,13 @@ xml_new_root <- function(.value, ..., .copy = inherits(.value, "xml_node"), .ver #' @inheritParams xml_name #' @examples #' x <- read_xml( -#' " +#' " #' #' #' #' -#' ") +#' " +#' ) #' # Need to specify the default namespaces to find the baz nodes #' xml_find_all(x, "//d1:baz") #' xml_find_all(x, "//d2:baz") @@ -328,7 +328,6 @@ xml_new_root <- function(.value, ..., .copy = inherits(.value, "xml_node"), .ver #' xml_find_all(x, "//baz") #' @export xml_ns_strip <- function(x) { - # //namespace::*[name()=''] finds all the namespace definition nodes with no # prefix (default namespaces). # What we actually want is the element node the definitions are contained in diff --git a/R/xml_name.R b/R/xml_name.R index 9f40f937..a849be90 100644 --- a/R/xml_name.R +++ b/R/xml_name.R @@ -42,7 +42,7 @@ xml_name.xml_node <- function(x, ns = character()) { #' @rdname xml_name #' @export `xml_name<-` <- function(x, ns = character(), value) { - UseMethod("xml_name<-") + UseMethod("xml_name<-") } #' @export @@ -57,7 +57,7 @@ xml_name.xml_node <- function(x, ns = character()) { return(x) } if (!is.list(ns)) { - ns <- list(ns) + ns <- list(ns) } Map(`xml_name<-`, x, ns, value) x diff --git a/R/xml_namespaces.R b/R/xml_namespaces.R index ad921817..78c289c7 100644 --- a/R/xml_namespaces.R +++ b/R/xml_namespaces.R @@ -95,7 +95,7 @@ xml_ns_rename <- function(old, ...) { m <- match(names(new), names(old)) if (any(is.na(m))) { missing <- paste(names(new)[is.na(m)], collapse = ", ") - stop("Some prefixes [", missing, "] don't already exist.", call. = FALSE) + cli::cli_abort("Some prefixes [{missing}] don't already exist.") } names(old)[m] <- new diff --git a/R/xml_node.R b/R/xml_node.R new file mode 100644 index 00000000..aedaad13 --- /dev/null +++ b/R/xml_node.R @@ -0,0 +1,29 @@ +# node ------------------------------------------------------------------------- + +xml_node <- function(node = NULL, doc = NULL) { + if (inherits(node, "xml_node")) { + node + } else { + out <- list(node = node, doc = doc) + class(out) <- "xml_node" + out + } +} + +#' @export +as.character.xml_node <- function(x, ..., options = "format", encoding = "UTF-8") { + options <- parse_options(options, xml_save_options()) + .Call(node_write_character, x$node, encoding, options) +} + +#' @export +print.xml_node <- function(x, width = getOption("width"), max_n = 20, ...) { + cat("{", doc_type(x), "_node}\n", sep = "") + cat(format(x), "\n", sep = "") + show_nodes(xml_children(x), width = width, max_n = max_n) +} + +#' @export +is.na.xml_node <- function(x) { + FALSE +} diff --git a/R/xml_nodeset.R b/R/xml_nodeset.R new file mode 100644 index 00000000..f899d9dd --- /dev/null +++ b/R/xml_nodeset.R @@ -0,0 +1,74 @@ +xml_nodeset <- function(nodes = list(), deduplicate = TRUE) { + if (isTRUE(deduplicate)) { + nodes <- nodes[!.Call(nodes_duplicated, nodes)] + } + class(nodes) <- "xml_nodeset" + nodes +} + +#' @param nodes A list (possible nested) of external pointers to nodes +#' @return a nodeset +#' @noRd +make_nodeset <- function(nodes, doc) { + nodes <- unlist(nodes, recursive = FALSE) + + xml_nodeset(lapply(nodes, xml_node, doc = doc)) +} + +#' @export +print.xml_nodeset <- function(x, width = getOption("width"), max_n = 20, ...) { + n <- length(x) + cat("{", doc_type(x), "_nodeset (", n, ")}\n", sep = "") + + if (n > 0) { + show_nodes(x, width = width, max_n = max_n) + } +} + +#' @export +as.character.xml_nodeset <- function(x, ...) { + vapply(x, as.character, FUN.VALUE = character(1)) +} + +#' @export +`[.xml_nodeset` <- function(x, i, ...) { + if (length(x) == 0) { + return(x) + } + xml_nodeset(NextMethod()) +} + +show_nodes <- function(x, width = getOption("width"), max_n = 20) { + stopifnot(inherits(x, "xml_nodeset")) + + n <- length(x) + if (n == 0) { + return() + } + + if (n > max_n) { + n <- max_n + x <- x[seq_len(n)] + trunc <- TRUE + } else { + trunc <- FALSE + } + + label <- format(paste0("[", seq_len(n), "]"), justify = "right") + contents <- encodeString(vapply(x, as.character, FUN.VALUE = character(1))) + + desc <- paste0(label, " ", contents) + needs_trunc <- nchar(desc) > width + desc[needs_trunc] <- paste(substr(desc[needs_trunc], 1, width - 3), "...") + + cat(desc, sep = "\n") + if (trunc) { + cat("...\n") + } + invisible() +} + +#' @export +is.na.xml_nodeset <- function(x) { + vapply(x, is.na, logical(1)) +} diff --git a/R/xml_parse.R b/R/xml_parse.R index 70f4e6da..faa92e05 100644 --- a/R/xml_parse.R +++ b/R/xml_parse.R @@ -66,21 +66,29 @@ read_xml <- function(x, encoding = "", ..., as_html = FALSE, options = "NOBLANKS #' @export #' @rdname read_xml -read_html <- function(x, encoding = "", ..., options = c("RECOVER", "NOERROR", "NOBLANKS")) { +read_html <- function(x, + encoding = "", + ..., + options = c("RECOVER", "NOERROR", "NOBLANKS")) { UseMethod("read_html") } #' @export -read_html.default <- function(x, encoding = "", ..., options = c("RECOVER", "NOERROR", "NOBLANKS")) { +read_html.default <- function(x, + encoding = "", + ..., + options = c("RECOVER", "NOERROR", "NOBLANKS")) { options <- parse_options(options, xml_parse_options()) suppressWarnings(read_xml(x, encoding = encoding, ..., as_html = TRUE, options = options)) } #' @export -read_html.response <- function(x, encoding = "", options = c("RECOVER", - "NOERROR", "NOBLANKS"), ...) { - need_package("httr") +read_html.response <- function(x, + encoding = "", + options = c("RECOVER", "NOERROR", "NOBLANKS"), + ...) { + check_installed("httr") options <- parse_options(options, xml_parse_options()) @@ -91,16 +99,12 @@ read_html.response <- function(x, encoding = "", options = c("RECOVER", #' @export #' @rdname read_xml -read_xml.character <- function(x, encoding = "", ..., as_html = FALSE, +read_xml.character <- function(x, + encoding = "", + ..., + as_html = FALSE, options = "NOBLANKS") { - - if (length(x) == 0) { - stop("Document is empty", call. = FALSE) - } - - if (length(x) > 1) { - stop("`x` must be a string of length 1", call. = FALSE) - } + check_string(x) options <- parse_options(options, xml_parse_options()) if (grepl("<|>", x)) { @@ -108,11 +112,15 @@ read_xml.character <- function(x, encoding = "", ..., as_html = FALSE, } else { con <- path_to_connection(x) if (inherits(con, "connection")) { - read_xml.connection(con, encoding = encoding, ..., as_html = as_html, - base_url = x, options = options) + read_xml.connection(con, + encoding = encoding, ..., as_html = as_html, + base_url = x, options = options + ) } else { - doc <- .Call(doc_parse_file, con, encoding = encoding, as_html = as_html, - options = options) + doc <- .Call(doc_parse_file, con, + encoding = encoding, as_html = as_html, + options = options + ) xml_document(doc) } } @@ -120,8 +128,12 @@ read_xml.character <- function(x, encoding = "", ..., as_html = FALSE, #' @export #' @rdname read_xml -read_xml.raw <- function(x, encoding = "", base_url = "", ..., - as_html = FALSE, options = "NOBLANKS") { +read_xml.raw <- function(x, + encoding = "", + base_url = "", + ..., + as_html = FALSE, + options = "NOBLANKS") { options <- parse_options(options, xml_parse_options()) doc <- .Call(doc_parse_raw, x, encoding, base_url, as_html, options) @@ -130,9 +142,14 @@ read_xml.raw <- function(x, encoding = "", base_url = "", ..., #' @export #' @rdname read_xml -read_xml.connection <- function(x, encoding = "", n = 64 * 1024, - verbose = FALSE, ..., base_url = "", - as_html = FALSE, options = "NOBLANKS") { +read_xml.connection <- function(x, + encoding = "", + n = 64 * 1024, + verbose = FALSE, + ..., + base_url = "", + as_html = FALSE, + options = "NOBLANKS") { options <- parse_options(options, xml_parse_options()) if (!isOpen(x)) { @@ -141,20 +158,28 @@ read_xml.connection <- function(x, encoding = "", n = 64 * 1024, } raw <- .Call(read_connection_, x, n) - read_xml.raw(raw, encoding = encoding, base_url = base_url, as_html = - as_html, options = options) + read_xml.raw(raw, + encoding = encoding, base_url = base_url, as_html = + as_html, options = options + ) } #' @export -read_xml.response <- function(x, encoding = "", base_url = "", ..., - as_html = FALSE, options = "NOBLANKS") { - need_package("httr") +read_xml.response <- function(x, + encoding = "", + base_url = "", + ..., + as_html = FALSE, + options = "NOBLANKS") { + check_installed("httr") options <- parse_options(options, xml_parse_options()) httr::stop_for_status(x) content <- httr::content(x, as = "raw") - xml2::read_xml(content, encoding = encoding, base_url = if (nzchar(base_url)) base_url else x$url, - as_html = as_html, option = options, ...) + xml2::read_xml(content, + encoding = encoding, base_url = if (nzchar(base_url)) base_url else x$url, + as_html = as_html, option = options, ... + ) } #' Download a HTML or XML file @@ -172,12 +197,12 @@ read_xml.response <- function(x, encoding = "", base_url = "", ..., #' \dontrun{ #' download_html("http://tidyverse.org/index.html") #' } -download_xml <- function(url, file = basename(url), quiet = TRUE, mode = "wb", - handle = curl::new_handle()) { - - if (!requireNamespace("curl", quietly = TRUE)) { - stop("`curl` must be installed to use `download_xml()`", call. = FALSE) - } +download_xml <- function(url, + file = basename(url), + quiet = TRUE, + mode = "wb", + handle = curl::new_handle()) { + check_installed("curl", "to use `download_xml()`.") curl::curl_download(url, file, quiet = quiet, mode = mode, handle = handle) diff --git a/R/xml_serialize.R b/R/xml_serialize.R index 3f7357f4..1869268e 100644 --- a/R/xml_serialize.R +++ b/R/xml_serialize.R @@ -66,7 +66,7 @@ xml_unserialize <- function(connection, ...) { } else if (inherits(object, "xml_serialized_document")) { res <- read_xml(unclass(object), ...) } else { - stop("Not a serialized xml2 object", call. = FALSE) + abort("Not a serialized xml2 object") } res } diff --git a/R/xml_structure.R b/R/xml_structure.R index bdb888ff..1ff4d907 100644 --- a/R/xml_structure.R +++ b/R/xml_structure.R @@ -12,7 +12,7 @@ #' @examples #' xml_structure(read_xml("")) #' -#' rproj <- read_html(system.file("extdata","r-project.html", package = "xml2")) +#' rproj <- read_html(system.file("extdata", "r-project.html", package = "xml2")) #' xml_structure(rproj) #' xml_structure(xml_find_all(rproj, ".//p")) #' @@ -51,7 +51,7 @@ tree_structure.xml_nodeset <- function(x, indent = 2, html = FALSE, file = "") { } #' @export -tree_structure.xml_node <- function(x, indent = 2, html = FALSE, file = "") { +tree_structure.xml_node <- function(x, indent = 2, html = FALSE, file = "") { print_xml_structure(x, indent = indent, html = html, file = file) invisible() } @@ -61,7 +61,6 @@ print_xml_structure <- function(x, prefix = 0, indent = 2, html = FALSE, file = type <- xml_type(x) if (type == "element") { - attr <- xml_attrs(x) if (html) { html_attrs <- list() @@ -87,8 +86,14 @@ print_xml_structure <- function(x, prefix = 0, indent = 2, html = FALSE, file = node <- paste0("<", xml_name(x), attr_str, ">") cat(padding, node, "\n", sep = "", file = file, append = TRUE) - lapply(xml_contents(x), print_xml_structure, prefix = prefix + indent, - indent = indent, html = html, file = file) + lapply( + xml_contents(x), + print_xml_structure, + prefix = prefix + indent, + indent = indent, + html = html, + file = file + ) } else { cat(padding, "{", type, "}\n", sep = "", file = file, append = TRUE) } diff --git a/R/xml_text.R b/R/xml_text.R index bad8d1f9..0aad2974 100644 --- a/R/xml_text.R +++ b/R/xml_text.R @@ -17,8 +17,7 @@ #' x <- read_xml("

Some text

") #' xml_text(x, trim = TRUE) #' -#' # xml_double() and xml_integer() are useful for extracting numeric -#' attributes +#' # xml_double() and xml_integer() are useful for extracting numeric attributes #' x <- read_xml("") #' xml_integer(xml_find_all(x, "//@x")) #' @export diff --git a/R/xml_write.R b/R/xml_write.R index b8d010e7..35448f1c 100644 --- a/R/xml_write.R +++ b/R/xml_write.R @@ -30,13 +30,13 @@ write_xml <- function(x, file, ...) { #' @export write_xml.xml_missing <- function(x, file, ...) { - stop("Missing data cannot be written", call. = FALSE) + abort("Missing data cannot be written") } #' @rdname write_xml #' @export write_xml.xml_document <- function(x, file, ..., options = "format", encoding = "UTF-8") { - options <- parse_options(options, xml_save_options()) + options <- parse_options(options, xml_save_options()) file <- path_to_connection(file, check = "dir") if (inherits(file, "connection")) { @@ -46,9 +46,7 @@ write_xml.xml_document <- function(x, file, ..., options = "format", encoding = } .Call(doc_write_connection, x$doc, file, encoding, options) } else { - if (!(is.character(file) && length(file) == 1 && nzchar(file))) { - stop("`file` must be a non-zero character of length 1", call. = FALSE) - } + check_string(file) .Call(doc_write_file, x$doc, file, encoding, options) } @@ -58,10 +56,10 @@ 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) { - stop("Can only save length 1 node sets", call. = FALSE) + abort("Can only save length 1 node sets") } - options <- parse_options(options, xml_save_options()) + options <- parse_options(options, xml_save_options()) file <- path_to_connection(file, check = "dir") if (inherits(file, "connection")) { @@ -71,9 +69,7 @@ write_xml.xml_nodeset <- function(x, file, ..., options = "format", encoding = " } .Call(node_write_connection, x[[1]]$node, file, encoding, options) } else { - if (!(is.character(file) && length(file) == 1 && nzchar(file))) { - stop("`file` must be a non-zero character of length 1", call. = FALSE) - } + check_string(file) .Call(node_write_file, x[[1]]$node, file, encoding, options) } @@ -82,7 +78,7 @@ write_xml.xml_nodeset <- function(x, file, ..., options = "format", encoding = " #' @export write_xml.xml_node <- function(x, file, ..., options = "format", encoding = "UTF-8") { - options <- parse_options(options, xml_save_options()) + options <- parse_options(options, xml_save_options()) file <- path_to_connection(file, check = "dir") if (inherits(file, "connection")) { @@ -92,9 +88,7 @@ write_xml.xml_node <- function(x, file, ..., options = "format", encoding = "UTF } .Call(node_write_connection, x$node, file, encoding, options) } else { - if (!(is.character(file) && length(file) == 1 && nzchar(file))) { - stop("`file` must be a non-zero character of length 1", call. = FALSE) - } + check_string(file) .Call(node_write_file, x$node, file, encoding, options) } @@ -110,7 +104,7 @@ write_html <- function(x, file, ...) { #' @export write_html.xml_missing <- function(x, file, ...) { - stop("Missing data cannot be written", call. = FALSE) + abort("Missing data cannot be written") } #' @rdname write_xml diff --git a/README.Rmd b/README.Rmd new file mode 100644 index 00000000..374a543d --- /dev/null +++ b/README.Rmd @@ -0,0 +1,86 @@ +--- +output: github_document +--- + + + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + fig.path = "man/figures/README-", + out.width = "100%" +) +``` + +# xml2 + + +[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/xml2)](https://cran.r-project.org/package=xml2) +[![Codecov test coverage](https://codecov.io/gh/r-lib/xml2/branch/master/graph/badge.svg)](https://app.codecov.io/gh/r-lib/xml2?branch=main) +[![R build status](https://github.com/r-lib/xml2/workflows/R-CMD-check/badge.svg)](https://github.com/r-lib/xml2/actions) +[![R-CMD-check](https://github.com/r-lib/xml2/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/xml2/actions/workflows/R-CMD-check.yaml) + + +The xml2 package is a binding to [libxml2](http://xmlsoft.org), making it easy to work with HTML and XML from R. The API is somewhat inspired by [jQuery](https://jquery.com). + +## Installation + +You can install xml2 from CRAN, + +```r +install.packages("xml2") +``` + +or you can install the development version from github, using `devtools`: + +```r +# install.packages("pak") +pak::pak("r-lib/xml2") +``` + +## Usage + +```r +library("xml2") +x <- read_xml(" text ") +x + +xml_name(x) +xml_children(x) +xml_text(x) +xml_find_all(x, ".//baz") + +h <- read_html("

Hi !") +h +xml_name(h) +xml_text(h) +``` + +There are three key classes: + +* `xml_node`: a single node in a document. + +* `xml_doc`: the complete document. Acting on a document is usually the same + as acting on the root node of the document. + +* `xml_nodeset`: a __set__ of nodes within the document. Operations on + `xml_nodeset`s are vectorised, apply the operation over each node in the set. + +## Compared to the XML package + +xml2 has similar goals to the XML package. The main differences are: + +* xml2 takes care of memory management for you. It will automatically + free the memory used by an XML document as soon as the last reference + to it goes away. + +* xml2 has a very simple class hierarchy so you don't need to think about exactly + what type of object you have, xml2 will just do the right thing. + +* More convenient handling of namespaces in Xpath expressions - see `xml_ns()` + and `xml_ns_strip()` to get started. + +## Code of Conduct + +Please note that the xml2 project is released with a [Contributor Code of Conduct](https://xml2.r-lib.org/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. diff --git a/README.md b/README.md index 58145dfb..e65adf36 100644 --- a/README.md +++ b/README.md @@ -1,31 +1,41 @@ + + + # xml2 + +[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/xml2)](https://cran.r-project.org/package=xml2) +[![Codecov test +coverage](https://codecov.io/gh/r-lib/xml2/branch/master/graph/badge.svg)](https://app.codecov.io/gh/r-lib/xml2?branch=main) +[![R build +status](https://github.com/r-lib/xml2/workflows/R-CMD-check/badge.svg)](https://github.com/r-lib/xml2/actions) [![R-CMD-check](https://github.com/r-lib/xml2/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/xml2/actions/workflows/R-CMD-check.yaml) -[![R build status](https://github.com/r-lib/xml2/workflows/R-CMD-check/badge.svg)](https://github.com/r-lib/xml2/actions) -[![Coverage Status](https://img.shields.io/codecov/c/github/r-lib/xml2/master.svg)](https://codecov.io/github/r-lib/xml2?branch=master) -The xml2 package is a binding to [libxml2](http://xmlsoft.org), making it easy to work with HTML and XML from R. The API is somewhat inspired by [jQuery](https://jquery.com). +The xml2 package is a binding to [libxml2](http://xmlsoft.org), making +it easy to work with HTML and XML from R. The API is somewhat inspired +by [jQuery](https://jquery.com). ## Installation -You can install xml2 from CRAN, +You can install xml2 from CRAN, -```R +``` r install.packages("xml2") ``` -or you can install the development version from github, using `devtools`: +or you can install the development version from github, using +`devtools`: -```R -# install.packages("devtools") -devtools::install_github("r-lib/xml2") +``` r +# install.packages("pak") +pak::pak("r-lib/xml2") ``` ## Usage -```R +``` r library("xml2") x <- read_xml(" text ") x @@ -43,28 +53,32 @@ xml_text(h) There are three key classes: -* `xml_node`: a single node in a document. +- `xml_node`: a single node in a document. -* `xml_doc`: the complete document. Acting on a document is usually the same - as acting on the root node of the document. +- `xml_doc`: the complete document. Acting on a document is usually the + same as acting on the root node of the document. -* `xml_nodeset`: a __set__ of nodes within the document. Operations on - `xml_nodeset`s are vectorised, apply the operation over each node in the set. +- `xml_nodeset`: a **set** of nodes within the document. Operations on + `xml_nodeset`s are vectorised, apply the operation over each node in + the set. ## Compared to the XML package xml2 has similar goals to the XML package. The main differences are: -* xml2 takes care of memory management for you. It will automatically +- xml2 takes care of memory management for you. It will automatically free the memory used by an XML document as soon as the last reference to it goes away. -* xml2 has a very simple class hierarchy so don't need to think about exactly - what type of object you have, xml2 will just do the right thing. +- xml2 has a very simple class hierarchy so you don’t need to think + about exactly what type of object you have, xml2 will just do the + right thing. -* More convenient handling of namespaces in Xpath expressions - see `xml_ns()` - and `xml_ns_strip()` to get started. +- More convenient handling of namespaces in Xpath expressions - see + `xml_ns()` and `xml_ns_strip()` to get started. ## Code of Conduct -Please note that the xml2 project is released with a [Contributor Code of Conduct](https://xml2.r-lib.org/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. +Please note that the xml2 project is released with a [Contributor Code +of Conduct](https://xml2.r-lib.org/CODE_OF_CONDUCT.html). By +contributing to this project, you agree to abide by its terms. diff --git a/cran-comments.md b/cran-comments.md index e69de29b..20257fd0 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -0,0 +1,3 @@ +## R CMD check results + +0 errors | 0 warnings | 0 note diff --git a/man/as_xml_document.Rd b/man/as_xml_document.Rd index 4f7d351d..21eaf791 100644 --- a/man/as_xml_document.Rd +++ b/man/as_xml_document.Rd @@ -26,6 +26,7 @@ as_xml_document(list(foo = list(bar = list(baz = list())))) # attributes are stored as R attributes as_xml_document(list(foo = structure(list(), id = "a"))) as_xml_document(list(foo = list( - bar = structure(list(), id = "a"), - bar = structure(list(), id = "b")))) + bar = structure(list(), id = "a"), + bar = structure(list(), id = "b") +))) } diff --git a/man/download_xml.Rd b/man/download_xml.Rd index e3d693a9..6e041ae1 100644 --- a/man/download_xml.Rd +++ b/man/download_xml.Rd @@ -51,6 +51,9 @@ is that \code{curl_download} checks the http status code before starting the download, and raises an error when status is non-successful. The behavior of \code{curl_fetch_disk} on the other hand is to proceed as normal and write the error page to disk in case of a non success response. + +For a more advanced download interface which supports concurrent requests and +resuming large files, have a look at the \link[curl]{multi_download} function. } \examples{ \dontrun{ diff --git a/man/figures/lifecycle-archived.svg b/man/figures/lifecycle-archived.svg new file mode 100644 index 00000000..745ab0c7 --- /dev/null +++ b/man/figures/lifecycle-archived.svg @@ -0,0 +1,21 @@ + + lifecycle: archived + + + + + + + + + + + + + + + lifecycle + + archived + + diff --git a/man/figures/lifecycle-defunct.svg b/man/figures/lifecycle-defunct.svg new file mode 100644 index 00000000..d5c9559e --- /dev/null +++ b/man/figures/lifecycle-defunct.svg @@ -0,0 +1,21 @@ + + lifecycle: defunct + + + + + + + + + + + + + + + lifecycle + + defunct + + diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 00000000..b61c57c3 --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 00000000..5d88fc2c --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1,21 @@ + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-maturing.svg b/man/figures/lifecycle-maturing.svg new file mode 100644 index 00000000..897370ec --- /dev/null +++ b/man/figures/lifecycle-maturing.svg @@ -0,0 +1,21 @@ + + lifecycle: maturing + + + + + + + + + + + + + + + lifecycle + + maturing + + diff --git a/man/figures/lifecycle-questioning.svg b/man/figures/lifecycle-questioning.svg new file mode 100644 index 00000000..7c1721d0 --- /dev/null +++ b/man/figures/lifecycle-questioning.svg @@ -0,0 +1,21 @@ + + lifecycle: questioning + + + + + + + + + + + + + + + lifecycle + + questioning + + diff --git a/man/figures/lifecycle-soft-deprecated.svg b/man/figures/lifecycle-soft-deprecated.svg new file mode 100644 index 00000000..9c166ff3 --- /dev/null +++ b/man/figures/lifecycle-soft-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: soft-deprecated + + + + + + + + + + + + + + + lifecycle + + soft-deprecated + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 00000000..9bf21e76 --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1,29 @@ + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 00000000..db8d757f --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1,21 @@ + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/xml2-package.Rd b/man/xml2-package.Rd new file mode 100644 index 00000000..d3a149c6 --- /dev/null +++ b/man/xml2-package.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/xml2-package.R +\docType{package} +\name{xml2-package} +\alias{xml2} +\alias{xml2-package} +\title{xml2: Parse XML} +\description{ +Work with XML files using a simple, consistent interface. Built on top of the 'libxml2' C library. +} +\seealso{ +Useful links: +\itemize{ + \item \url{https://xml2.r-lib.org/} + \item \url{https://github.com/r-lib/xml2} + \item Report bugs at \url{https://github.com/r-lib/xml2/issues} +} + +} +\author{ +\strong{Maintainer}: Hadley Wickham \email{hadley@posit.co} + +Authors: +\itemize{ + \item Jim Hester + \item Jeroen Ooms +} + +Other contributors: +\itemize{ + \item Posit Software, PBC [copyright holder, funder] + \item R Foundation (Copy of R-project homepage cached as example) [contributor] +} + +} +\keyword{internal} diff --git a/man/xml_dtd.Rd b/man/xml_dtd.Rd index 9b0d4c05..d613d76c 100644 --- a/man/xml_dtd.Rd +++ b/man/xml_dtd.Rd @@ -20,15 +20,19 @@ to parse a string directly with \code{read_xml()}. } \examples{ r <- xml_new_root( - xml_dtd("html", + xml_dtd( + "html", "-//W3C//DTD XHTML 1.0 Transitional//EN", - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")) + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" + ) +) # Use read_xml directly for more complicated DTD d <- read_xml( -' ]> -This is a valid document &foo; !') +This is a valid document &foo; !' +) } diff --git a/man/xml_missing.Rd b/man/xml_missing.Rd index 10d51013..8c2b13dc 100644 --- a/man/xml_missing.Rd +++ b/man/xml_missing.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/classes.R +% Please edit documentation in R/xml_missing.R \name{xml_missing} \alias{xml_missing} \title{Construct an missing xml object} diff --git a/man/xml_ns_strip.Rd b/man/xml_ns_strip.Rd index f210f546..362558b1 100644 --- a/man/xml_ns_strip.Rd +++ b/man/xml_ns_strip.Rd @@ -14,12 +14,13 @@ Strip the default namespaces from a document } \examples{ x <- read_xml( - " + " - ") + " +) # Need to specify the default namespaces to find the baz nodes xml_find_all(x, "//d1:baz") xml_find_all(x, "//d2:baz") diff --git a/man/xml_structure.Rd b/man/xml_structure.Rd index 8dd97692..09daa65b 100644 --- a/man/xml_structure.Rd +++ b/man/xml_structure.Rd @@ -31,7 +31,7 @@ way a document is organised. Compared to \code{xml_structure}, \examples{ xml_structure(read_xml("")) -rproj <- read_html(system.file("extdata","r-project.html", package = "xml2")) +rproj <- read_html(system.file("extdata", "r-project.html", package = "xml2")) xml_structure(rproj) xml_structure(xml_find_all(rproj, ".//p")) diff --git a/man/xml_text.Rd b/man/xml_text.Rd index 655d56a3..825b4c95 100644 --- a/man/xml_text.Rd +++ b/man/xml_text.Rd @@ -44,8 +44,7 @@ xml_text(xml_find_all(x, "//x")) x <- read_xml("

Some text

") xml_text(x, trim = TRUE) -# xml_double() and xml_integer() are useful for extracting numeric -attributes +# xml_double() and xml_integer() are useful for extracting numeric attributes x <- read_xml("") xml_integer(xml_find_all(x, "//@x")) } diff --git a/src/Makevars.ucrt b/src/Makevars.ucrt deleted file mode 100644 index 1a2e1013..00000000 --- a/src/Makevars.ucrt +++ /dev/null @@ -1,2 +0,0 @@ -CRT=-ucrt -include Makevars.win diff --git a/src/Makevars.win b/src/Makevars.win index e0f6d1de..badc575d 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -1,9 +1,11 @@ -VERSION=2.9.10 +VERSION=2.10.3 RWINLIB=../windows/libxml2-$(VERSION) PKG_CPPFLAGS=-I../inst/include -I$(RWINLIB)/include/libxml2 \ -DLIBXML_STATIC -PKG_LIBS=-L$(RWINLIB)/lib${R_ARCH}${CRT} -lxml2 -llzma -liconv -lz -lws2_32 +PKG_LIBS = -L$(RWINLIB)/lib${subst gcc,,$(COMPILED_BY)}$(R_ARCH) \ + -L$(RWINLIB)/lib$(R_ARCH)\ + -lxml2 -llzma -liconv -lz -lws2_32 all: clean winlibs diff --git a/src/connection.cpp b/src/connection.cpp index fba60b47..736ada94 100644 --- a/src/connection.cpp +++ b/src/connection.cpp @@ -1,4 +1,8 @@ +#define R_NO_REMAP #include +#undef R_NO_REMAP + +#include #include #include "xml2_utils.h" diff --git a/src/connection.h b/src/connection.h index 587974cc..41b400a4 100644 --- a/src/connection.h +++ b/src/connection.h @@ -1,6 +1,8 @@ #pragma once +#define R_NO_REMAP #include +#undef R_NO_REMAP #include #include diff --git a/src/init.c b/src/init.c index fef02907..6b3f0781 100644 --- a/src/init.c +++ b/src/init.c @@ -1,9 +1,11 @@ -#include +#define R_NO_REMAP #include +#undef R_NO_REMAP + #include // for NULL #include -/* FIXME: +/* FIXME: Check these declarations against the C/Fortran source code. */ @@ -21,8 +23,8 @@ extern SEXP doc_validate(SEXP, SEXP); extern SEXP doc_write_character(SEXP, SEXP, SEXP); extern SEXP doc_write_connection(SEXP, SEXP, SEXP, SEXP); extern SEXP doc_write_file(SEXP, SEXP, SEXP, SEXP); -extern SEXP init_libxml2(); -extern SEXP libxml2_version_(); +extern SEXP init_libxml2(void); +extern SEXP libxml2_version_(void); extern SEXP node_append_child(SEXP, SEXP); extern SEXP node_append_content(SEXP, SEXP); extern SEXP node_append_sibling(SEXP, SEXP); @@ -68,8 +70,8 @@ extern SEXP url_escape_(SEXP, SEXP); extern SEXP url_parse_(SEXP); extern SEXP url_relative_(SEXP, SEXP); extern SEXP url_unescape_(SEXP); -extern SEXP xml_parse_options_(); -extern SEXP xml_save_options_(); +extern SEXP xml_parse_options_(void); +extern SEXP xml_save_options_(void); extern SEXP xpath_search(SEXP, SEXP, SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { diff --git a/src/xml2_doc.cpp b/src/xml2_doc.cpp index 32d52fb9..5ff748d3 100644 --- a/src/xml2_doc.cpp +++ b/src/xml2_doc.cpp @@ -1,4 +1,6 @@ +#define R_NO_REMAP #include +#undef R_NO_REMAP #include #include diff --git a/src/xml2_namespace.cpp b/src/xml2_namespace.cpp index f82ef098..0915c08a 100644 --- a/src/xml2_namespace.cpp +++ b/src/xml2_namespace.cpp @@ -1,4 +1,7 @@ +#define R_NO_REMAP #include +#undef R_NO_REMAP + #include #include "xml2_types.h" diff --git a/src/xml2_output.cpp b/src/xml2_output.cpp index 0d4e8204..c0619e23 100644 --- a/src/xml2_output.cpp +++ b/src/xml2_output.cpp @@ -1,10 +1,12 @@ +#define R_NO_REMAP #include -#include "connection.h" +#undef R_NO_REMAP #include #include #include +#include "connection.h" #include "xml2_types.h" #include "xml2_utils.h" diff --git a/src/xml2_schema.cpp b/src/xml2_schema.cpp index dfe37e51..345ca502 100644 --- a/src/xml2_schema.cpp +++ b/src/xml2_schema.cpp @@ -1,9 +1,12 @@ +#define R_NO_REMAP #include +#undef R_NO_REMAP #include -#include "xml2_types.h" #include #include + +#include "xml2_types.h" #include "xml2_utils.h" void handleSchemaError(void* userData, xmlError* error) { diff --git a/src/xml2_url.cpp b/src/xml2_url.cpp index 96519011..6f7644ba 100644 --- a/src/xml2_url.cpp +++ b/src/xml2_url.cpp @@ -1,4 +1,6 @@ +#define R_NO_REMAP #include +#undef R_NO_REMAP #include #include "xml2_utils.h" diff --git a/src/xml2_utils.h b/src/xml2_utils.h index e0c63c76..231b7e38 100644 --- a/src/xml2_utils.h +++ b/src/xml2_utils.h @@ -1,7 +1,10 @@ #ifndef __XML2_XML_UTILS__ #define __XML2_XML_UTILS__ +#define R_NO_REMAP #include +#undef R_NO_REMAP + #include #include #include diff --git a/src/xml2_xpath.cpp b/src/xml2_xpath.cpp index 63504cf0..6a43b504 100644 --- a/src/xml2_xpath.cpp +++ b/src/xml2_xpath.cpp @@ -1,4 +1,7 @@ +#define R_NO_REMAP #include +#undef R_NO_REMAP + #include #include #include @@ -105,7 +108,7 @@ extern "C" SEXP xpath_search(SEXP node_sxp, SEXP doc_sxp, SEXP xpath_sxp, SEXP n XPtrNode node(node_sxp); XPtrDoc doc(doc_sxp); if (TYPEOF(xpath_sxp) != STRSXP) { - Rf_error("XPath must be a string, received %s", type2char(TYPEOF(xpath_sxp))); + Rf_error("XPath must be a string, received %s", Rf_type2char(TYPEOF(xpath_sxp))); } const char* xpath = CHAR(STRING_ELT(xpath_sxp, 0)); diff --git a/tests/testthat.R b/tests/testthat.R index ef9fcef3..8837ba1e 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,3 +1,11 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + library(testthat) library(xml2) diff --git a/tests/testthat/_snaps/xml_attr.md b/tests/testthat/_snaps/xml_attr.md new file mode 100644 index 00000000..87aef962 --- /dev/null +++ b/tests/testthat/_snaps/xml_attr.md @@ -0,0 +1,4 @@ +# xml_attrs<- modifies all attributes + + `test` must be a list of named character vectors. + diff --git a/tests/testthat/_snaps/xml_children.md b/tests/testthat/_snaps/xml_children.md new file mode 100644 index 00000000..2fadd129 --- /dev/null +++ b/tests/testthat/_snaps/xml_children.md @@ -0,0 +1,4 @@ +# xml_child() errors if more than one search is given + + `1` and `2` must be of length 1. + diff --git a/tests/testthat/_snaps/xml_document.md b/tests/testthat/_snaps/xml_document.md new file mode 100644 index 00000000..c85aef8a --- /dev/null +++ b/tests/testthat/_snaps/xml_document.md @@ -0,0 +1,10 @@ +# print method is correct + + Code + print(x) + Output + {html_document} + + [1] \n