diff --git a/NAMESPACE b/NAMESPACE index 24c24f759..6dda56887 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -123,6 +123,8 @@ importFrom(purrr,map_lgl) importFrom(stats,setNames) importFrom(utils,URLdecode) importFrom(utils,URLencode) +importFrom(utils,head) +importFrom(utils,tail) importFrom(xml2,xml_attr) importFrom(xml2,xml_children) importFrom(xml2,xml_contents) diff --git a/R/markdown.R b/R/markdown.R index 7437dac77..53f97501e 100644 --- a/R/markdown.R +++ b/R/markdown.R @@ -13,9 +13,9 @@ markdown <- function(text, tag = NULL) { mdxml <- md_to_mdxml(esc_text_linkrefs) state <- new.env(parent = emptyenv()) state$tag <- tag - rd <- mdxml_children_to_rd(mdxml, state) + rd <- mdxml_children_to_rd_top(mdxml, state) - unescape_rd_for_md(str_trim(rd), esc_text) + unescape_rd_for_md(str_trim(rd$main), esc_text) } md_to_mdxml <- function(x) { @@ -23,6 +23,15 @@ md_to_mdxml <- function(x) { xml2::read_xml(md) } +mdxml_children_to_rd_top <- function(xml, state) { + state$section_tag <- uuid() + out <- map_chr(xml_children(xml), mdxml_node_to_rd, state) + out <- c(out, mdxml_close_sections(state)) + rd <- paste0(out, collapse = "") + secs <- strsplit(rd, state$section_tag, fixed = TRUE)[[1]] + list(main = secs[[1]], sections = secs[-1]) +} + mdxml_children_to_rd <- function(xml, state) { out <- map_chr(xml_children(xml), mdxml_node_to_rd, state) paste0(out, collapse = "") @@ -54,8 +63,10 @@ mdxml_node_to_rd <- function(xml, state) { link = mdxml_link(xml), image = mdxml_image(xml), + # Only supported when including Rmds + heading = mdxml_heading(xml, state), + # Not supported - heading = mdxml_unsupported(xml, state$tag, "markdown headings"), block_quote = mdxml_unsupported(xml, state$tag, "block quotes"), hrule = mdxml_unsupported(xml, state$tag, "horizontal rules"), html_inline = mdxml_unsupported(xml, state$tag, "inline HTML"), @@ -130,3 +141,31 @@ mdxml_image = function(xml) { title <- xml_attr(xml, "title") paste0("\\figure{", dest, "}{", title, "}") } + +mdxml_heading <- function(xml, state) { + if (state$tag$tag != "@includeRmd") { + return(mdxml_unsupported(xml, state$tag, "markdown headings")) + } + level <- xml_attr(xml, "level") + head <- paste0( + mdxml_close_sections(state, level), + "\n", + if (level == 1) paste0(state$section_tag, "\\section{"), + if (level > 1) "\\subsection{", + xml_text(xml), + "}{") + state$section <- c(state$section, level) + head +} + +#' @importFrom utils head tail + +mdxml_close_sections <- function(state, upto = 1L) { + hmy <- 0L + while (length(state$section) && tail(state$section, 1) >= upto) { + hmy <- hmy + 1L + state$section <- head(state$section, -1L) + } + + paste0(rep("\n}\n", hmy), collapse = "") +} diff --git a/R/rd-include-rmd.R b/R/rd-include-rmd.R index dc4511bd9..c0b53175e 100644 --- a/R/rd-include-rmd.R +++ b/R/rd-include-rmd.R @@ -2,15 +2,21 @@ block_include_rmd <- function(tag, block, env) { rmd <- tag$val stopifnot(is.character(rmd), length(rmd) == 1, !is.na(rmd)) - md_path <- tempfile(fileext = ".md") - on.exit(unlink(md_path, recursive = TRUE), add = TRUE) if (!requireNamespace("rmarkdown", quietly = TRUE)) { stop("@includeRmd requires the rmarkdown package") } + + md_path <- tempfile(fileext = ".md") + on.exit(unlink(md_path, recursive = TRUE), add = TRUE) rmd_path <- rmd_process_links(rmd) on.exit(unlink(rmd_path, recursive = TRUE), add = TRUE) - rmarkdown::render(rmd_path, output_format = rmarkdown::github_document(), - output_file = md_path, quiet = TRUE) + + rmarkdown::render( + rmd_path, + output_format = rmarkdown::github_document(), + output_file = md_path, + quiet = TRUE + ) rmd_eval_rd(md_path, tag) } @@ -31,6 +37,6 @@ rmd_eval_rd <- function(path, tag) { mdxml <- xml2::read_xml(mdx) state <- new.env(parent = emptyenv()) state$tag <- tag - rd <- mdxml_children_to_rd(mdxml, state = state) + rd <- mdxml_children_to_rd_top(mdxml, state = state) rd } diff --git a/R/rd.R b/R/rd.R index dd7cd4194..53cde4fc6 100644 --- a/R/rd.R +++ b/R/rd.R @@ -413,9 +413,12 @@ topic_add_include_rmd <- function(topic, block) { tag <- roxy_tag("@includeRmd", rmd, attr(block, "filename"), attr(block, "location")[[1]]) out <- block_include_rmd(tag, block, env) - if (!is.null(out)) { - topic$add_simple_field("details", out) + if (!is.null(out$main)) { + topic$add_simple_field("details", out$main) } + lapply(out$sections, function(s) { + topic$add_simple_field("rawRd", s) + }) } } diff --git a/R/utils.R b/R/utils.R index 163e2f0ed..91e23358a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -173,3 +173,9 @@ pkg_env <- function() { env$.packageName <- "roxygen2" env } + +uuid <- function(nchar = 8) { + paste( + sample(c(letters, LETTERS, 0:9), nchar, replace = TRUE), + collapse = "") +} diff --git a/tests/testthat/helper-test.R b/tests/testthat/helper-test.R index a42347c36..fded9d875 100644 --- a/tests/testthat/helper-test.R +++ b/tests/testthat/helper-test.R @@ -3,3 +3,11 @@ expect_equivalent_rd <- function(out1, out2) { out2$fields$backref <- NULL expect_equal(out1, out2) } + +expect_equal_strings <- function(s1, s2, ignore_ws = TRUE) { + if (ignore_ws) { + s1 <- gsub("\\s", "", s1, perl = TRUE) + s2 <- gsub("\\s", "", s2, perl = TRUE) + } + expect_equal(s1, s2) +} diff --git a/tests/testthat/test-rd-includermd.R b/tests/testthat/test-rd-includermd.R index b7f2f3234..8b25007f9 100644 --- a/tests/testthat/test-rd-includermd.R +++ b/tests/testthat/test-rd-includermd.R @@ -26,3 +26,38 @@ test_that("markdown file can be included", { NULL")[[1]] expect_equivalent_rd(out1, out2) }) + +test_that("markdown with headers", { + tmp <- tempfile(fileext = ".md") + on.exit(unlink(tmp, recursive = TRUE), add = TRUE) + cat(sep = "\n", file = tmp, + "Text at the front", + "", + "# Header 1", + "", + "## Header 2", + "", + "Text", + "", + "## Header 22", + "", + "# Header 11", + "", + "Text again") + rox <- sprintf(" + #' Title + #' @includeRmd %s + #' @name foobar + NULL", tmp) + out1 <- roc_proc_text(rd_roclet(), rox)[[1]] + exp_details <- "Text at the front" + exp_secs <- c(paste0( + "\\section{Header 1}{", + "\\subsection{Header 2}{Text}", + "\\subsection{Header 22}{}", + "}"), + "\\section{Header 11}{Text again}" + ) + expect_equal_strings(out1$fields$details$values, exp_details) + expect_equal_strings(out1$fields$rawRd$values, exp_secs) +})