R/evalrd.R

In gaborcsardi/rmd2rd: Manual Pages via 'rmarkdown'

#' Include an Rmarkdown document in a manual page
#'
#' This function should be called via roxygen2's `@evalRd` macro, to
#' include its Rd output in a manual page.
#'
#' @param path Path to the Rmarkdown file to include.
#' @param output_format Output format, passed to [rmarkdown::render()].
#' @param quiet Passed to [rmarkdown::render()].
#' @param ... Additional arguments are passed to [rmarkdown::render()].
#' @return Character vector of Rd text.
#'
#' @importFrom rmarkdown render
#' @export

eval_rmd <- function(path, output_format = rmarkdown::github_document(),
                     quiet = TRUE, ...) {
  stopifnot(is_string(path), file.exists(path))
  md_path <- tempfile(fileext = ".md")
  on.exit(unlink(md_path, recursive = TRUE), add = TRUE)
  render(process_links(path), output_format = output_format,
         output_file = md_path, quiet = quiet, ...)
  eval_md(md_path)
}

#' @importFrom commonmark markdown_xml
#' @importFrom xml2 read_xml

eval_md <- function(path) {
  mdtxt <- paste(readLines(path), collapse = "\n")
  mdesc <- add_linkrefs_to_md(mdtxt)
  mdx <- markdown_xml(mdesc, hardbreaks = TRUE)
  mdxml <- read_xml(mdx)
  state <- new.env(parent = emptyenv())
  rd <- mdxml_children_to_rd(mdxml, state = state)
  rd <- paste0(rd, close_sections(state))
  rd
}

#' @importFrom xml2 xml_children

mdxml_children_to_rd <- function(xml, state) {
  out <- map_chr(xml_children(xml), mdxml_node_to_rd, state = state)
  paste0(out, collapse = "")
}

#' @importFrom xml2 xml_name xml_type xml_text xml_contents xml_attr
#' xml_children
mdxml_node_to_rd <- function(xml, state) {
  if (!inherits(xml, "xml_node") || xml_type(xml) != "element") {
    warning("Internal markdown translation failure")
    return("")
  }

  switch(xml_name(xml),
    html = ,
    document = ,
    unknown = mdxml_children_to_rd(xml, state),

    code_block = paste0("\\preformatted{", gsub("%", "\\\\%", xml_text(xml)), "}"),
    paragraph = paste0("\n\n", mdxml_children_to_rd(xml, state)),
    text = xml_text(xml),
    code = paste0("\\code{", gsub("%", "\\\\%", xml_text(xml)), "}"),
    emph = paste0("\\emph{", mdxml_children_to_rd(xml, state), "}"),
    strong = paste0("\\strong{", mdxml_children_to_rd(xml, state), "}"),
    softbreak = "\n",
    linebreak = "\n",

    list = mdxml_list(xml, state),
    item = mdxml_item(xml, state),
    link = mdxml_link(xml, state),
    image = mdxml_image(xml, state),

    heading = mdxml_heading(xml, state),

    # Not supported
    block_quote = mdxml_unsupported(xml, state, "block quotes"),
    hrule = mdxml_unsupported(xml, state, "horizontal rules"),
    html_inline = mdxml_unsupported(xml, state, "inline HTML"),
    mdxml_unknown(xml, state)
  )
}

mdxml_unknown <- function(xml, state) {
  warning("Unknown xml node: ", xml_name(xml))
  xml_text(xml)
}

mdxml_unsupported <- function(xml, state, feature) {
  warning("Use of ", feature, " is not currently supported")
  xml_text(xml)
}

# A list, either bulleted or numbered
mdxml_list <- function(xml, state) {
  type <- xml_attr(xml, "type")
  if (type == "ordered") {
    paste0("\n\\enumerate{", mdxml_children_to_rd(xml, state), "\n}")
  } else {
    paste0("\n\\itemize{", mdxml_children_to_rd(xml, state), "\n}")
  }
}

mdxml_item <- function(xml, state) {
  ## A single item within a list. We remove the first paragraph
  ## tag, to avoid an empty line at the beginning of the first item.
  children <- xml_children(xml)
  if (length(children) == 0) {
    cnts <- ""
  } else if (xml_name(children[[1]]) == "paragraph") {
    cnts <- paste0(
      mdxml_children_to_rd(children[[1]], state),
      paste0(map_chr(children[-1], mdxml_node_to_rd, state), collapse = "")
    )
  } else {
    cnts <- mdxml_children_to_rd(xml, state)
  }
  paste0("\n\\item ", cnts)
}

mdxml_link <- function(xml, state) {
  ## Hyperlink, this can also be a link to a function
  dest <- xml_attr(xml, "destination")
  contents <- xml_contents(xml)

  link <- parse_link(dest, contents)

  if (!is.null(link)) {
    paste0(link, collapse = "")
  } else if (dest == "" || dest == xml_text(xml)) {
    paste0("\\url{", xml_text(xml), "}")
  } else {
    paste0("\\href{", dest, "}{", mdxml_link_text(contents, state), "}")
  }
}

# Newlines in markdown get converted to softbreaks/linebreaks by
# markdown_xml(), which then get interpreted as empty strings by
# xml_text(). So we preserve newlines as spaces.
mdxml_link_text <- function(xml_contents, state) {
  text <- xml_text(xml_contents)
  text[xml_name(xml_contents) %in% c("linebreak", "softbreak")] <- " "
  paste0(text, collapse = "")
}

mdxml_image <- function(xml, state) {
  dest <- xml_attr(xml, "destination")
  title <- xml_attr(xml, "title")
  paste0("\\figure{", dest, "}{", title, "}")
}

mdxml_heading <- function(xml, state) {
  ## TODO: level is not used currently...
  level <- xml_attr(xml, "level")
  head <- paste0(
    close_sections(state, level),
    if (level == 1) "\n\n\\section{" else "\n\n\\subsection{",
    xml_text(xml),
    "}{")
  state$section <- c(state$section, level)
  head
}

#' @importFrom utils head tail

close_sections <- function(state, upto = 1L) {
  hmy <- 0L
  while (length(state$section) && tail(state$section) >= upto) {
    hmy <- hmy + 1L
    state$section <- head(state$section, -1L)
  }

  paste0(rep("\n}\n", hmy), collapse = "")
}