diff --git a/DESCRIPTION b/DESCRIPTION index 3f48b66..6aabe7c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,13 +20,13 @@ Authors@R: c( "maintainer@bioconductor.org", "cre")) Depends: R (>= 4.6.0) Imports: Biobase, graph (>= 1.9.26), methods, RBGL (>= 1.13.5), tools, - utils, XML, RCurl, RUnit, BiocManager + utils, xml2, RCurl, RUnit, BiocManager Suggests: BiocGenerics, BiocPkgTools, knitr, commonmark, BiocStyle -Collate: AllClasses.R AllGenerics.R as-methods.R htmlDoc-methods.R +Collate: AllClasses.R AllGenerics.R xml2_helpers.R as-methods.R htmlDoc-methods.R htmlFilename-methods.R htmlValue-methods.R show-methods.R getPackNames.R packageDetails.R pump.R repository.R showvoc.R getPackageNEWS.R validation_tests.R recommendBiocViews.R dump_concept.R build_dbs.R VignetteBuilder: knitr -RoxygenNote: 7.3.2 Encoding: UTF-8 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index f0c1160..cf05a76 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,9 +16,14 @@ importFrom(utils, download.file, Stangle, available.packages, capture.output, contrib.url, data, file_test, head, packageDescription, readCitationFile, untar) -importMethodsFrom(XML, saveXML) +importFrom( + xml2, + read_html, + xml_find_all, xml_text, xml_new_document, + xml_add_child, xml_set_text + xml_attr, `xml_attr<-`, +) -importFrom(XML, xmlNode, xmlOutputDOM, xmlTree, htmlParse, xpathApply, xmlValue) importFrom(RCurl, getURL) diff --git a/R/repository.R b/R/repository.R index c9edae5..23c020e 100644 --- a/R/repository.R +++ b/R/repository.R @@ -519,8 +519,8 @@ getHtmlTitle <- function(doc, src) { title <- getVignetteIndexEntry(src) if (is.na(title)) { ## now look for an HTML title - doc <- htmlParse(doc) - res <- xpathApply(doc, "//title", xmlValue) + doc <- read_html(doc) + res <- lapply(xml_find_all(doc, "//title"), xml_text) if (length(res)) title <- res[[1L]] } diff --git a/R/xml2_helpers.R b/R/xml2_helpers.R new file mode 100644 index 0000000..3856e0a --- /dev/null +++ b/R/xml2_helpers.R @@ -0,0 +1,193 @@ +## xml2_helpers.R +## +## Compatibility wrappers that replicate the XML package's stateful DOM builder +## (xmlOutputDOM / xmlTree) and xmlNode / saveXML on top of xml2. +## +## The original code used three XML idioms: +## +## 1. xmlOutputDOM(tag, attrs) / xmlTree(tag) -- stateful builder +## Builder methods: $addTag(), $addNode(), $closeTag(), $value() +## +## 2. xmlNode(tag, ..., attrs) -- create a standalone xml2 node +## +## 3. saveXML(node, file, prefix="") -- serialize to file or string +## +## All three are re-implemented below so that the rest of the source code +## needs only minimal mechanical edits. + +## --------------------------------------------------------------------------- +## 1. xmlNode() replacement +## --------------------------------------------------------------------------- +## XML::xmlNode(name, ..., attrs = NULL) +## children / text content are passed as un-named or named '...' arguments. +## 'attrs' is a named character vector. +## +## We return an xml2 node (xml_node). Because xml2 builds nodes as part of a +## document, we keep a lightweight parent document. + +xmlNode <- function(name, ..., attrs = NULL) { + doc <- xml_new_document() + root <- xml_add_child(doc, name) + + if (!is.null(attrs) && length(attrs) > 0) { + for (nm in names(attrs)) + xml_attr(root, nm) <- attrs[[nm]] + } + + args <- list(...) + ## If there is only a single character child and no xml_node children, + ## use xml_set_text (produces a plain text node). When the args are mixed + ## (character + xml_node), wrap bare character strings in so that + ## inline separators (e.g. ", ") are preserved in the HTML output. + node_children <- vapply(args, inherits, logical(1), "xml_node") + mixed <- any(node_children) && any(!node_children) + + txt_acc <- character() + for (child in args) { + if (inherits(child, "xml_node")) { + xml_add_child(root, child) + } else if (is.character(child)) { + txt <- paste0(child, collapse = "") + if (nzchar(txt)) { + if (mixed) { + sp <- xml_add_child(root, "span") + xml_set_text(sp, txt) + } else { + txt_acc <- c(txt_acc, txt) + } + } + } + } + if (!mixed && length(txt_acc)) { + xml_set_text(root, paste0(txt_acc, collapse = "")) + } + root +} + +## --------------------------------------------------------------------------- +## 2. xmlOutputDOM() / xmlTree() replacement +## --------------------------------------------------------------------------- +## Both functions return an environment that exposes: +## $addTag(name, ..., attrs, close) -- open (and optionally close) a tag +## $addNode(node) -- append an xml_node child +## $closeTag() -- close the most-recently opened tag +## $value() -- return the root xml_node +## +## The stateful part is a stack of open nodes held in the environment. + +.makeXmlDomBuilder <- function(rootTag, attrs = NULL) { + doc <- xml_new_document() + root <- xml_add_child(doc, rootTag) + + if (!is.null(attrs) && length(attrs)) { + for (nm in names(attrs)) + xml_attr(root, nm) <- attrs[[nm]] + } + + ## stack: top of stack is the currently open node + stack <- list(root) + + current <- function() stack[[length(stack)]] + push <- function(n) stack[[length(stack) + 1L]] <<- n + pop <- function() stack[[length(stack)]] <<- NULL + + ## addTag(name, text?, attrs = NULL, close = TRUE) + addTag <- function(name, ..., attrs = NULL, close = TRUE) { + node <- xml_add_child(current(), name) + + if (!is.null(attrs) && length(attrs) > 0) { + for (nm in names(attrs)) + xml_attr(node, nm) <- attrs[[nm]] + } + + args <- list(...) + node_children <- vapply(args, inherits, logical(1), "xml_node") + mixed <- any(node_children) && any(!node_children) + + txt_acc <- character() + for (child in args) { + if (inherits(child, "xml_node")) { + xml_add_child(node, child) + } else if (is.character(child)) { + txt <- paste0(child, collapse = "") + if (nzchar(txt)) { + if (mixed) { + sp <- xml_add_child(node, "span") + xml_set_text(sp, txt) + } else { + txt_acc <- c(txt_acc, txt) + } + } + } + } + if (!mixed && length(txt_acc)) + xml_set_text(node, paste0(txt_acc, collapse = "")) + + if (!close) { + push(node) + } + invisible(NULL) + } + + ## addNode(node) -- append a pre-built xml_node + addNode <- function(node) { + if (inherits(node, "xml_node")) { + xml_add_child(current(), node) + } + invisible(NULL) + } + + ## closeTag() -- pop the stack (close the most-recently opened tag) + closeTag <- function() { + if (length(stack) > 1L) + pop() + invisible(NULL) + } + + ## value() -- return the root node + value <- function() root + + list( + addTag = addTag, + addNode = addNode, + closeTag = closeTag, + value = value + ) +} + +xmlOutputDOM <- function(tag = "doc", attrs = NULL, ...) { + .makeXmlDomBuilder(tag, attrs) +} + +## xmlTree is used identically to xmlOutputDOM in biocViews +xmlTree <- function(tag = "doc", attrs = NULL, ...) { + .makeXmlDomBuilder(tag, attrs) +} + +## --------------------------------------------------------------------------- +## 3. saveXML() replacement +## --------------------------------------------------------------------------- +## XML::saveXML(doc, file = NULL, prefix = "", ...) +## * When 'file' is NULL/missing, returns the serialised string. +## * When 'file' is a connection or path, writes to it. +## * 'prefix' is prepended to the output (used for DOCTYPE in biocViews). +## +## xml2::as_xml_document() / xml2::write_html() / xml2::write_xml() are used. + +saveXML <- function(doc, file = NULL, prefix = "", ...) { + if (!inherits(doc, "xml_node")) + stop("saveXML: 'doc' must be an xml_node") + + txt <- as.character(doc) + + ## Prepend any requested prefix (e.g. DOCTYPE declaration) + if (nzchar(prefix)) + txt <- paste0(prefix, "\n", txt) + + if (is.null(file)) { + return(txt) + } else { + writeLines(txt, con = file, sep = "") + invisible(txt) + } +} diff --git a/inst/extdata/vignette.Rmd b/inst/extdata/vignette.Rmd new file mode 100644 index 0000000..8f1b5e4 --- /dev/null +++ b/inst/extdata/vignette.Rmd @@ -0,0 +1,23 @@ +--- +title: "The Vignette Package" +author: "Vignette Author" +date: "`r format(Sys.Date(), '%A, %B %d, %Y')`" +always_allow_html: yes +output: + BiocStyle::html_document: + df_print: paged + toc_float: true +vignette: > + %\VignetteIndexEntry{Vignette for beginners} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r init, results='hide', echo=FALSE, warning=FALSE, message=FALSE} +library(knitr) +opts_chunk$set(warning=FALSE, message=FALSE) +``` + + +# What is a vignette? + diff --git a/inst/extdata/vignette.html b/inst/extdata/vignette.html new file mode 100644 index 0000000..c440e85 --- /dev/null +++ b/inst/extdata/vignette.html @@ -0,0 +1,7 @@ + + + + +The Vignette Package + + diff --git a/inst/unitTests/test_repository.R b/inst/unitTests/test_repository.R new file mode 100644 index 0000000..aa4981a --- /dev/null +++ b/inst/unitTests/test_repository.R @@ -0,0 +1,54 @@ +test_getHtmlTitle <- function() { + doc <- system.file( + "htmlfrags", + "topfrag.html", + package = "biocViews", + mustWork = TRUE + ) + src <- system.file( + "extdata", + "vignette.Rmd", + package = "biocViews", + mustWork = TRUE + ) + checkIdentical( + getVignetteIndexEntry(src), + "Vignette for beginners" + ) + checkIdentical( + getHtmlTitle(doc, src), + "Vignette for beginners" + ) + checkIdentical( + suppressWarnings({ + getHtmlTitle(doc, "") + }), + "Bioconductor Task View: top level views" + ) +} + +test_getDocumentTitles <- function() { + htmlDocs <- system.file("extdata", package = "biocViews") |> + list.files(pattern = "\\.[Hh][Tt][Mm][Ll]$", full.names = TRUE) + + checkIdentical( + getDocumentTitles( + basename(htmlDocs), + ext = "html", + src = c("Rmd", "Rhtml"), + dirname(htmlDocs), + getHtmlTitle + ), + "Vignette for beginners" + ) +} + +test_getVignetteIndexEntry <- function() { + rmdDocs <- system.file("extdata", package = "biocViews") |> + list.files(pattern = "\\.[Rr][Mm][Dd]$", full.names = TRUE) + + checkIdentical( + getVignetteIndexEntry(rmdDocs), + "Vignette for beginners" + ) +}