Support sections in includeRmd

Rules are:
- text before the first (level 1) heading goes into \details{}.
- level 1 headings get their own \section{}.
- other levels creates subsections, and go into \details{} or
  a \section{}, depending on whether they appear before the
  first level 1 heading or not.

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)

R/markdown.R

@@ -13,16 +13,25 @@ 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) {
   md <- commonmark::markdown_xml(x, hardbreaks = TRUE)
   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 = "")
+}

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
 }

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)
+    })
   }
 }
 

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 = "")
+}

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)
+}

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)
+})