diff --git a/.Rbuildignore b/.Rbuildignore index a43ff80..a46c589 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -19,3 +19,6 @@ ^inst/scripts/samples.R ^inst/extdata/bigsample.*$ ^inst/extdata/xml_table.xml$ +^man/add_md\.Rd$ +^man/add_nodes_to_body\.Rd$ +^man/insert_md\.Rd$ diff --git a/DESCRIPTION b/DESCRIPTION index c1747cf..f80fb8e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,6 +55,7 @@ Suggests: Config/testthat/edition: 3 Encoding: UTF-8 LazyData: true -Roxygen: list(markdown = TRUE) +Roxygen: list(markdown = TRUE, roclets = c("collate", "rd", "namespace", "devtag::dev_roclet")) RoxygenNote: 7.3.2.9000 VignetteBuilder: knitr +Config/Needs/build: moodymudskipper/devtag diff --git a/NEWS.md b/NEWS.md index 2e9af1b..301cfe0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ ## NEW FEATURES +* `yarn$append_md()` and `yarn$prepend_md()` methods allow you to add new + markdown to specific places in the document using XPath expressions. * `to_md_vec()` takes an xml node or nodelist and returns a character vector of the markdown produced. * `show_list()`, `show_block()`, and `show_censor()` will show the markdown diff --git a/R/add_md.R b/R/add_md.R index ec3e175..83d9aad 100644 --- a/R/add_md.R +++ b/R/add_md.R @@ -6,13 +6,19 @@ #' @keywords internal #' #' @return a copy of the XML object with the markdown inserted. +#' @dev add_md <- function(body, md, where = 0L) { new <- md_to_xml(md) add_nodes_to_body(body, new, where) copy_xml(body) } -# Add children to a specific location in the full document. +#' Add children to a specific location in the full document. +#' +#' @inheritParams add_md +#' @param nodes an object of `xml_node` or list of nodes +#' @return a copy of the XML object with nodes inserted +#' @dev add_nodes_to_body <- function(body, nodes, where = 0L) { if (inherits(nodes, "xml_node")) { xml2::xml_add_child(body, nodes, .where = where) @@ -21,13 +27,107 @@ add_nodes_to_body <- function(body, nodes, where = 0L) { } } + +#' Insert markdown before or after a set of nodes +#' +#' @inheritParams add_md +#' @param md markdown text to insert +#' @param nodes a character vector of an XPath expression OR an `xml_node` or +#' `xml_nodeset` object. +#' @param space when `TRUE` (default) inline nodes have a single space appended +#' or prepended to avoid the added markdown abutting text. +#' @return a copy of the XML object with the translated markdown inserted +#' +#' @note The markdown content must be of the same type as the XML nodes, either +#' inline or block content. +#' @dev +insert_md <- function(body, md, nodes, where = "after", space = TRUE) { + new <- md_to_xml(md) + shove_nodes_in(body, new, nodes = nodes, where = where, space = space) + copy_xml(body) +} + +shove_nodes_in <- function(body, new, nodes, where = "after", space = TRUE) { + if (inherits(nodes, "character")) { + xpath <- nodes + nodes <- xml2::xml_find_all(body, nodes, ns = md_ns()) + } else { + xpath <- NULL + } + if (length(nodes) == 0) { + msg <- glue::glue("No nodes matched the expression {sQuote(xpath)}") + rlang::abort(msg, class = "insert-md-xpath") + } + if (!inherits(nodes, c("xml_node", "xml_nodeset"))) { + rlang::abort("an object of class `xml_node` or `xml_nodeset` was expected", + class = "insert-md-node" + ) + } + root <- xml2::xml_root(nodes) + if (!identical(root, body)) { + rlang::abort("nodes must come from the same body as the yarn document", + class = "insert-md-body" + ) + } + return(add_nodes_to_nodes(new, old = nodes, where = where, space = space)) +} + + +node_is_inline <- function(node) { + blocks <- c("document", "paragraph", "heading", "block_quote", "list", + "item", "code_block", "html_block", "custom_block", "thematic_break", + "table") + !xml2::xml_name(node) %in% blocks +} + +# add a new set of nodes before or after an exsiting set of nodes. +add_nodes_to_nodes <- function(new, old, where = "after", space = TRUE) { + single_node <- inherits(old, "xml_node") + # count the number of inline elements + inlines <- node_is_inline(old) + n <- sum(inlines) + # when there are any inline nodes, we need to adjust the new node so that + # we extract child-level elements. Note that we assume that the user will + # be supplying strictly inline markdown, but it may not be so neat. + if (n > 0) { + if (!single_node && n < length(old)) { + rlang::abort("Nodes must be either block type or inline, but not both", + class = "insert-md-dual-type", + call. = FALSE + ) + } + # make sure the new nodes are inline by extracting the children. + new <- xml2::xml_children(new) + if (space) { + # For inline nodes, we want to make sure they are separated from existing + # nodes by a space. + lead <- if (inherits(new, "xml_node")) new else new[[1]] + txt <- if (where == "after") " %s" else "%s " + xml2::xml_set_text(lead, sprintf(txt, xml2::xml_text(lead))) + } + } + if (single_node) { + # allow purrr::walk() to work on a single node + old <- list(old) + } + purrr::walk(.x = old, .f = add_node_siblings, + new = new, where = where, remove = FALSE + ) +} + # Add siblings to a node -add_node_siblings <- function(node, nodes, where = "after", remove = TRUE) { +add_node_siblings <- function(node, new, where = "after", remove = TRUE) { # if there is a single node, then we need only add it - if (inherits(nodes, "xml_node")) { - xml2::xml_add_sibling(node, nodes, .where = where) + if (inherits(new, "xml_node")) { + xml2::xml_add_sibling(node, new, .where = where) } else { - purrr::walk(rev(nodes), ~xml2::xml_add_sibling(node, .x, .where = where)) + if (where == "after") { + # Appending new nodes requires us to insert them from the bottom to + # the top. The reason for this is because we are always using the existing + # node as a reference. + new <- rev(new) + } + purrr::walk(new, ~xml2::xml_add_sibling(node, .x, .where = where)) } if (remove) xml2::xml_remove(node) } diff --git a/R/class-yarn.R b/R/class-yarn.R index a352c3a..1b21402 100644 --- a/R/class-yarn.R +++ b/R/class-yarn.R @@ -203,6 +203,55 @@ yarn <- R6::R6Class("yarn", self$body <- add_md(self$body, md, where) invisible(self) }, + #' @description append abritrary markdown to a node or set of nodes + #' + #' @param md a string of markdown formatted text. + #' @param nodes an XPath expression that evaulates to object of class + #' `xml_node` or `xml_nodeset` that are all either inline or block nodes + #' (never both). The XPath expression is passed to [xml2::xml_find_all()]. + #' If you want to append a specific node, you can pass that node to this + #' parameter. + #' @param space if `TRUE`, inline nodes will have a space inserted before + #' they are appended. + #' @details this is similar to the `add_md()` method except that it can do + #' the following: + #' 1. append content after a _specific_ node or set of nodes + #' 2. append content to multiple places in the document + #' @examples + #' path <- system.file("extdata", "example2.Rmd", package = "tinkr") + #' ex <- tinkr::yarn$new(path) + #' # append a note after the first heading + #' + #' txt <- c("> Hello from *tinkr*!", ">", "> :heart: R") + #' ex$append_md(txt, ".//md:heading[1]")$head(20) + append_md = function(md, nodes = NULL, space = TRUE) { + self$body <- insert_md(self$body, md, nodes, where = "after", space = space) + invisible(self) + }, + #' @description prepend arbitrary markdown to a node or set of nodes + #' + #' @param md a string of markdown formatted text. + #' @param nodes an XPath expression that evaulates to object of class + #' `xml_node` or `xml_nodeset` that are all either inline or block nodes + #' (never both). The XPath expression is passed to [xml2::xml_find_all()]. + #' If you want to append a specific node, you can pass that node to this + #' parameter. + #' @param space if `TRUE`, inline nodes will have a space inserted before + #' they are prepended. + #' @details this is similar to the `add_md()` method except that it can do + #' the following: + #' 1. prepend content after a _specific_ node or set of nodes + #' 2. prepend content to multiple places in the document + #' @examples + #' path <- system.file("extdata", "example2.Rmd", package = "tinkr") + #' ex <- tinkr::yarn$new(path) + #' + #' # prepend a table description to the birds table + #' ex$prepend_md("Table: BIRDS, NERDS", ".//md:table[1]")$tail(20) + prepend_md = function(md, nodes = NULL, space = TRUE) { + self$body <- insert_md(self$body, md, nodes, where = "before", space = space) + invisible(self) + }, #' @description Protect math blocks from being escaped #' #' @examples diff --git a/man/add_md.Rd b/man/add_md.Rd index 5db57bd..819069a 100644 --- a/man/add_md.Rd +++ b/man/add_md.Rd @@ -20,3 +20,4 @@ a copy of the XML object with the markdown inserted. Add markdown content to an XML object } \keyword{internal} +\keyword{internal} diff --git a/man/add_nodes_to_body.Rd b/man/add_nodes_to_body.Rd new file mode 100644 index 0000000..56ee346 --- /dev/null +++ b/man/add_nodes_to_body.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_md.R +\name{add_nodes_to_body} +\alias{add_nodes_to_body} +\title{Add children to a specific location in the full document.} +\usage{ +add_nodes_to_body(body, nodes, where = 0L) +} +\arguments{ +\item{body}{an XML object generated via {tinkr}} + +\item{nodes}{an object of \code{xml_node} or list of nodes} + +\item{where}{the position in the markdown document to insert the new markdown} +} +\value{ +a copy of the XML object with nodes inserted +} +\description{ +Add children to a specific location in the full document. +} +\keyword{internal} diff --git a/man/insert_md.Rd b/man/insert_md.Rd new file mode 100644 index 0000000..211725e --- /dev/null +++ b/man/insert_md.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_md.R +\name{insert_md} +\alias{insert_md} +\title{Insert markdown before or after a set of nodes} +\usage{ +insert_md(body, md, nodes, where = "after", space = TRUE) +} +\arguments{ +\item{body}{an XML object generated via {tinkr}} + +\item{md}{markdown text to insert} + +\item{nodes}{a character vector of an XPath expression OR an \code{xml_node} or +\code{xml_nodeset} object.} + +\item{where}{the position in the markdown document to insert the new markdown} + +\item{space}{when \code{TRUE} (default) inline nodes have a single space appended +or prepended to avoid the added markdown abutting text.} +} +\value{ +a copy of the XML object with the translated markdown inserted +} +\description{ +Insert markdown before or after a set of nodes +} +\note{ +The markdown content must be of the same type as the XML nodes, either +inline or block content. +} +\keyword{internal} diff --git a/man/isolate_nodes.Rd b/man/isolate_nodes.Rd index 33ce12c..380e07c 100644 --- a/man/isolate_nodes.Rd +++ b/man/isolate_nodes.Rd @@ -41,7 +41,7 @@ as a list of paragraphs. } } \examples{ -\dontshow{if (isTRUE(as.logical(Sys.getenv("NOT_CRAN", "false")))) withAutoprint(\{ # examplesIf} +\dontshow{if (isTRUE(as.logical(Sys.getenv("NOT_CRAN", "false")))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} path <- system.file("extdata", "show-example.md", package = "tinkr") y <- tinkr::yarn$new(path, sourcepos = TRUE) y$protect_math()$protect_curly() diff --git a/man/provision_isolation.Rd b/man/provision_isolation.Rd index 0764da3..c1c22b9 100644 --- a/man/provision_isolation.Rd +++ b/man/provision_isolation.Rd @@ -28,7 +28,7 @@ we can filter on nodes that are not connected to those present in the nodelist. This function is required for \code{\link[=isolate_nodes]{isolate_nodes()}} to work. } \examples{ -\dontshow{if (isTRUE(as.logical(Sys.getenv("NOT_CRAN", "false")))) withAutoprint(\{ # examplesIf} +\dontshow{if (isTRUE(as.logical(Sys.getenv("NOT_CRAN", "false")))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} path <- system.file("extdata", "show-example.md", package = "tinkr") y <- tinkr::yarn$new(path, sourcepos = TRUE) y$protect_math()$protect_curly() diff --git a/man/yarn.Rd b/man/yarn.Rd index 5e24189..0657e6e 100644 --- a/man/yarn.Rd +++ b/man/yarn.Rd @@ -105,6 +105,27 @@ tmp <- tempfile() ex$write(tmp) readLines(tmp, n = 20) +## ------------------------------------------------ +## Method `yarn$append_md` +## ------------------------------------------------ + +path <- system.file("extdata", "example2.Rmd", package = "tinkr") +ex <- tinkr::yarn$new(path) +# append a note after the first heading + +txt <- c("> Hello from *tinkr*!", ">", "> :heart: R") +ex$append_md(txt, ".//md:heading[1]")$head(20) + +## ------------------------------------------------ +## Method `yarn$prepend_md` +## ------------------------------------------------ + +path <- system.file("extdata", "example2.Rmd", package = "tinkr") +ex <- tinkr::yarn$new(path) + +# prepend a table description to the birds table +ex$prepend_md("Table: BIRDS, NERDS", ".//md:table[1]")$tail(20) + ## ------------------------------------------------ ## Method `yarn$protect_math` ## ------------------------------------------------ @@ -180,6 +201,8 @@ commonmark.} \item \href{#method-yarn-tail}{\code{yarn$tail()}} \item \href{#method-yarn-md_vec}{\code{yarn$md_vec()}} \item \href{#method-yarn-add_md}{\code{yarn$add_md()}} +\item \href{#method-yarn-append_md}{\code{yarn$append_md()}} +\item \href{#method-yarn-prepend_md}{\code{yarn$prepend_md()}} \item \href{#method-yarn-protect_math}{\code{yarn$protect_math()}} \item \href{#method-yarn-protect_curly}{\code{yarn$protect_curly()}} \item \href{#method-yarn-protect_unescaped}{\code{yarn$protect_unescaped()}} @@ -453,6 +476,101 @@ readLines(tmp, n = 20) } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-yarn-append_md}{}}} +\subsection{Method \code{append_md()}}{ +append abritrarily markdown to a node or set of nodes +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{yarn$append_md(md, nodes = NULL, space = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{md}}{a string of markdown formatted text.} + +\item{\code{nodes}}{an XPath expression that evaulates to object of class +\code{xml_node} or \code{xml_nodeset} that are all either inline or block nodes +(never both). The XPath expression is passed to \code{\link[xml2:xml_find_all]{xml2::xml_find_all()}}. +If you want to append a specific node, you can pass that node to this +parameter.} + +\item{\code{space}}{if \code{TRUE}, inline nodes will have a space inserted before +they are appended.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +this is similar to the \code{add_md()} method except that it can do +the following: +\enumerate{ +\item append content after a \emph{specific} node or set of nodes +\item append content to multiple places in the document +} +} + +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{path <- system.file("extdata", "example2.Rmd", package = "tinkr") +ex <- tinkr::yarn$new(path) +# append a note after the first heading + +txt <- c("> Hello from *tinkr*!", ">", "> :heart: R") +ex$append_md(txt, ".//md:heading[1]")$head(20) +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-yarn-prepend_md}{}}} +\subsection{Method \code{prepend_md()}}{ +prepend abritrarily markdown to a node or set of nodes +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{yarn$prepend_md(md, nodes = NULL, space = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{md}}{a string of markdown formatted text.} + +\item{\code{nodes}}{an XPath expression that evaulates to object of class +\code{xml_node} or \code{xml_nodeset} that are all either inline or block nodes +(never both). The XPath expression is passed to \code{\link[xml2:xml_find_all]{xml2::xml_find_all()}}. +If you want to append a specific node, you can pass that node to this +parameter.} + +\item{\code{space}}{if \code{TRUE}, inline nodes will have a space inserted before +they are prepended.} +} +\if{html}{\out{
}} +} +\subsection{Details}{ +this is similar to the \code{add_md()} method except that it can do +the following: +\enumerate{ +\item prepend content after a \emph{specific} node or set of nodes +\item prepend content to multiple places in the document +} +} + +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{path <- system.file("extdata", "example2.Rmd", package = "tinkr") +ex <- tinkr::yarn$new(path) + +# prepend a table description to the birds table +ex$prepend_md("Table: BIRDS, NERDS", ".//md:table[1]")$tail(20) +} +\if{html}{\out{
}} + +} + } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/tests/testthat/test-class-yarn.R b/tests/testthat/test-class-yarn.R index 24eb010..35322c4 100644 --- a/tests/testthat/test-class-yarn.R +++ b/tests/testthat/test-class-yarn.R @@ -133,7 +133,7 @@ test_that("a yarn object can be reset", { }) -test_that("random markdown can be added", { +test_that("random markdown can be added to the body", { tmpdir <- withr::local_tempdir() scarf3 <- withr::local_file(file.path(tmpdir, "yarn-kilroy.md")) @@ -146,7 +146,8 @@ test_that("random markdown can be added", { "[KILROY](https://en.wikipedia.org/wiki/Kilroy_was_here) WAS **HERE**\n\n", "stop copying me!" # THIS WILL BE COPIED TWICE ) - t1$add_md(paste(newmd, collapse = ""))$add_md(toupper(newmd[[3]]), where = 3) + t1$add_md(paste(newmd, collapse = "")) + t1$add_md(toupper(newmd[[3]]), where = 3) expect_length(xml2::xml_find_all(t1$body, "md:link", t1$ns), 0L) t1$write(scarf3) @@ -155,6 +156,108 @@ test_that("random markdown can be added", { }) +test_that("markdown can be appended to elements", { + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + # append a note after the first heading + txt <- c("The following message is sponsored by me:\n", "> Hello from *tinkr*!", ">", "> :heart: R") + # Via XPath ------------------------------------------------------------------ + ex$append_md(txt, ".//md:heading[1]") + # the block quote has been added to the first heading + expect_length(xml2::xml_find_all(ex$body, ".//md:block_quote", ns = ex$ns), 1) + # Via node ------------------------------------------------------------------- + heading2 <- xml2::xml_find_first(ex$body, ".//md:heading[2]", ns = ex$ns) + ex$append_md(txt, heading2) + expect_length(xml2::xml_find_all(ex$body, ".//md:block_quote", ns = ex$ns), 2) + # Because the body is a copy, the original nodeset will throw an error + expect_error(ex$append_md(txt, heading2), class = "insert-md-body") + + # Via nodeset ---------------------------------------------------------------- + ex$append_md(txt, ".//md:heading") + expect_length(xml2::xml_find_all(ex$body, ".//md:block_quote", ns = ex$ns), 4) +}) + + +test_that("Inline markdown can be appended (to a degree)", { + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + nodes <- xml2::xml_find_all(ex$body, + ".//md:code[contains(text(), 'READ THIS')]", ex$ns) + expect_length(nodes, 0) + ex <- tinkr::yarn$new(path) + nodes <- xml2::xml_find_all(ex$body, + ".//md:code[contains(text(), ' <-- READ THIS')]", ex$ns) + expect_length(nodes, 0) + ex$append_md("`<-- READ THIS`", ".//md:link") + nodes <- xml2::xml_find_all(ex$body, + ".//md:code[contains(text(), ' <-- READ THIS')]", ex$ns) + expect_length(nodes, 1) +}) + + +test_that("space parameter can be shut off", { + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + chk <- xml2::xml_find_all(ex$body, + ".//md:heading/*[contains(text(), '!!!')]", ex$ns) + space_chk <- xml2::xml_find_all(ex$body, + ".//md:heading/*[contains(text(), ' !!!')]", ex$ns) + expect_length(chk, 0) + expect_length(space_chk, 0) + ex <- tinkr::yarn$new(path) + ex$append_md("!!!", ".//md:heading/*", space = FALSE) + chk <- xml2::xml_find_all(ex$body, + ".//md:heading/*[contains(text(), '!!!')]", ex$ns) + space_chk <- xml2::xml_find_all(ex$body, + ".//md:heading/*[contains(text(), ' !!!')]", ex$ns) + expect_length(chk, 2) + expect_length(space_chk, 0) +}) + + + +test_that("markdown can be prepended", { + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + nodes <- xml2::xml_find_all(ex$body, + ".//node()[contains(text(), 'NERDS')]", ex$ns) + expect_length(nodes, 0) + ex$prepend_md("I come before the table.\n\nTable: BIRDS, NERDS", ".//md:table") + nodes <- xml2::xml_find_all(ex$body, + ".//node()[contains(text(), 'NERDS')]", ex$ns) + expect_length(nodes, 1) + pretxt <- xml2::xml_find_first(nodes[[1]], ".//parent::*/preceding-sibling::*[1]") + expect_equal(xml2::xml_text(pretxt), "I come before the table.") +}) + + +test_that("an error happens when you try to append with a number", { + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + expect_error(ex$append_md("WRONG", 42), class = "insert-md-node") +}) + +test_that("an error happens when you try to append to a non-existant node", { + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + expect_error(ex$append_md("WRONG", ".//md:nope"), + "No nodes matched the expression './/md:nope'", + class = "insert-md-xpath") +}) + + +test_that("an error happens when you try to append markdown to disparate elements", { + + path <- system.file("extdata", "example2.Rmd", package = "tinkr") + ex <- tinkr::yarn$new(path) + xpath <- ".//md:text[contains(text(), 'bird')] | .//md:paragraph[md:text[contains(text(), 'Non')]]" + + expect_error(ex$append_md("WRONG", xpath), class = "insert-md-dual-type") +}) + + + + test_that("md_vec() will convert a query to a markdown vector", { pathmd <- system.file("extdata", "example1.md", package = "tinkr")