R/as_markdown.R

Defines functions as_markdown.tag_renewcommand as_markdown.tag_newcommand as_markdown.tag_tab as_markdown.tag_enc as_markdown.tag_cr as_markdown.tag_ldots as_markdown.tag_dots as_markdown.tag_R as_markdown.tag_out as_markdown.tag_samp wrap_flattened_text as_markdown.tag_item as_markdown.tag_describe as_markdown.tag_enumerate as_markdown.tag_itemize as_markdown.tag_figure as_markdown.tag_tabular `as_markdown.#ifndef` `as_markdown.#ifdef` as_markdown.tag_special as_markdown.tag_ifelse as_markdown.tag_if method_usage_md as_markdown.tag_S4method as_markdown.tag_S3method as_markdown.tag_method as_markdown.tag_linkS4class as_markdown.tag_link as_markdown.tag_email as_markdown.tag_href as_markdown.tag_url as_markdown.tag_deqn as_markdown.tag_eqn as_markdown.tag_subsection as_markdown.USERMACRO as_markdown.COMMENT as_markdown.LIST as_markdown.character as_markdown.tag_Sexpr as_markdown.tag_RdOpts as_markdown.tag_usage as_markdown.tag_title as_markdown.tag_section as_markdown.tag_Rdversion as_markdown.tag_name as_markdown.tag_examples as_markdown.tag_encoding as_markdown.tag_docType as_markdown.tag_arguments as_markdown.NULL as_markdown.rdfragment as_markdown.rdfile as_markdown.refman_rdfile as_markdown.DESCRIPTION as_markdown.Rd as_markdown.default as_markdown

Documented in as_markdown

# generic as_markdown --------------------------------------------------------

#' Parse into Markdown
#'
#' S3 Methods to parse different classes into Markdown.
#' @param x Object
#' @param ... Further arguments passed to methods
#' @export
as_markdown <- function(x, ...) {
  UseMethod("as_markdown")
}

#' @export
as_markdown.default <- function(x, ...) {
  warning(
    sprintf(
      "Unknown as_markdown method for class(es): %s",
      paste0(class(x), collapse = ", ")
    )
  )
  paste0(
    sapply(x, as_markdown, ...),
    collapse = ""
  )
}

#' @export
as_markdown.Rd <- function(x, ...) {
  paste0(
    sapply(x, as_markdown, ...),
    collapse = ""
  )
}

# Various internal classes ---------------------------------------------------

#' @export
as_markdown.DESCRIPTION <- function(x, section_level = 1, ...) {
  paste0(
    h_md("DESCRIPTION", section_level = section_level),
    pre_md(paste(x, collapse = "\n"))
  )
}

#' @export
as_markdown.refman_rdfile <- function(x, section_level = 1, ...) {
  funname <- flatten_text_md(find_section(x, "tag_name"), ...)
  fundesc <- flatten_text_md(find_section(x, "tag_title"), ...)
  title <- h_md(
    paste(
      code_md(funname),
      fundesc,
      sep = ": "
    ),
    section_level
  )

  x <- order_rdfile(
    x,
    keep_first = paste0("tag_", c("description", "usage", "arguments")),
    # name and title already concatenated above
    # alias(es) will be shown in usage section
    remove = paste0("tag_", c("name", "title", "alias")),
    keep_last = paste0("tag_", c("value", "see_also", "examples"))
  )

  subsection_level <- section_level + 1
  rest <- paste0(
    sapply(x, as_markdown, section_level = subsection_level, ...),
    collapse = ""
  )

  paste0(
    title,
    rest
  )
}

#' @export
as_markdown.rdfile <- function(x, section_level = 1, ...) {
  title <- as_markdown(
    find_section(x, "tag_title"), section_level = section_level, ...
  )

  x <- order_rdfile(
    x,
    keep_first = paste0("tag_", c("description", "usage", "arguments")),
    # title already concatenated above
    # name and alias(es) will be shown in usage section
    remove = paste0("tag_", c("name", "title", "alias")),
    keep_last = paste0("tag_", c("value", "see_also", "examples"))
  )

  subsection_level <- section_level + 1
  rest <- paste0(
    sapply(x, as_markdown, section_level = subsection_level, ...),
    collapse = ""
  )

  paste0(
    title,
    rest
  )
}

#' @export
as_markdown.rdfragment <- function(x, ...) {
  paste0(
    sapply(x, as_markdown, ...),
    collapse = ""
  )
}

#' @export
as_markdown.NULL <- function(x, ...) ""

# Sections ------------------------------------------------------------------

#' @export
as_markdown.tag_alias <- parse_section_md
#' @export
as_markdown.tag_arguments <- function(x, section_level = 2, ...) {
  title <- tag_to_title(x)
  paste0(
    h_md(title, section_level),
    flatten_para_md(describe_contents_md(x, ...), ...)
  )
}

#' @export
as_markdown.tag_author <- parse_section_md
#' @export
as_markdown.tag_concept <- parse_section_md
#' @export
as_markdown.tag_description <- parse_section_md
#' @export
as_markdown.tag_details <- parse_section_md
#' @export
as_markdown.tag_docType <- function(x, ...) ""
#' @export
as_markdown.tag_encoding <- function(x, ...) ""
#' @export
as_markdown.tag_examples <- function(x, section_level, ...) {
  p_md(
    paste0(
      h_md(tag_to_title(x), section_level),
      pre_md(flatten_text_md(x, ...), lang = "r")
    )
  )
}
#' @export
as_markdown.tag_format <- parse_section_md
#' @export
as_markdown.tag_keyword <- parse_section_md
#' @export
as_markdown.tag_name <- function(x, ...) {
  parse_section_md(NULL, x[[1]], ...)
}
#' @export
as_markdown.tag_note <- parse_section_md
#' @export
as_markdown.tag_Rdversion <- function(x, ...) ""
#' @export
as_markdown.tag_references <- parse_section_md
#' @export
as_markdown.tag_section <- function(x, ...) {
  parse_section_md(x[[2]], title = x[[1]], fmt_code_fun = function(x) x, ...)
}
#' @export
as_markdown.tag_seealso <- parse_section_md
#' @export
as_markdown.tag_source <- parse_section_md
#' @export
as_markdown.tag_title <- function(x, ...) {
  parse_section_md(NULL, title = x[[1]], ...)
}
#' @export
as_markdown.tag_value <- parse_section_md
#' @export
as_markdown.tag_usage <- function(x, section_level, ...) {
  p_md(
    paste0(
      h_md(tag_to_title(x), section_level),
      pre_md(flatten_text_md(x, ...), lang = "r")
    )
  )
}

# Not implemented -----------------------------------------------------------

#' @export
as_markdown.tag_RdOpts <- function(x, ...) {
  warn_not_implemented("\\RdOpts", NULL)
}
#' @export
as_markdown.tag_Sexpr <- function(x, ...) {
  warn_not_implemented("\\Sexpr", NULL)
}


# Text  ---------------------------------------------------------------------

#' @export
as_markdown.character <- function(x, ...) as.character(x)
#' @export
as_markdown.LIST <-  function(x, ...) flatten_text_md(x, ...)
#' @export
as_markdown.TEXT <-  as_markdown.character
#' @export
as_markdown.RCODE <- as_markdown.character
#' @export
as_markdown.VERB <-  as_markdown.character
#' @export
as_markdown.COMMENT <- function(x, ...) ""
#' @export
as_markdown.USERMACRO <-  function(x, ...) ""

#' @export
as_markdown.tag_subsection <- function(x, ..., subsection_level = 3L) {
  title <- flatten_text_md(x[[1]], ...)
  text <- flatten_para_md(x[[2]], subsection_level = subsection_level + 1L, ...)
  paste0(
    h_md(title, subsection_level),
    text,
    collapse = ""
  )
}

# Equations ------------------------------------------------------------------

#' @export
as_markdown.tag_eqn <- function(x, ...) {
  latex_rep <- x[[1]]
  paste0("$", flatten_text_md(latex_rep, ...), "$")
}

#' @export
as_markdown.tag_deqn <- function(x, ...) {
  latex_rep <- x[[1]]
  paste0("$$", flatten_text_md(latex_rep, ...), "$$")
}

# Links ----------------------------------------------------------------------

#' @export
as_markdown.tag_url <- function(x, ...) {
  if (length(x) != 1) {
    if (length(x) == 0) {
      msg <- "Check for empty \\url{{}} tags."
    } else {
      msg <- "This may be caused by a \\url tag that spans a line break."
    }
    stop_bad_tag("url", msg)
  }

  text <- flatten_text_md(x[[1]])
  a_md(text, href = text)
}

#' @export
as_markdown.tag_href <- function(x, ...) {
  a_md(flatten_text_md(x[[2]]), href = flatten_text_md(x[[1]]))
}

#' @export
as_markdown.tag_email <- function(x, ...) {
  a_md(flatten_text_md(x, ...), is_email = TRUE)
}


# If single, need to look up alias to find file name and package
#' @export
as_markdown.tag_link <- function(x, ...) {
  # \link[opt]{in_braces}
  opt <- attr(x, "Rd_option")
  in_braces <- flatten_text_md(x)

  if (is.null(opt)) {
    # \link{topic}
    href <- get_topic_href(in_braces)
  } else if (substr(opt, 1, 1) == "=") {
    # \link[=dest]{name}
    href <- get_topic_href(substr(opt, 2, nchar(opt)))
  } else {
    match <- regexec("^([^:]+)(?:|:(.*))$", opt)
    parts <- regmatches(opt, match)[[1]][-1]

    if (parts[[2]] == "") {
      # \link[pkg]{foo}
      href <- get_topic_href(in_braces, opt)
    } else {
      # \link[pkg:bar]{foo}
      href <- get_topic_href(parts[[2]], parts[[1]])
    }
  }

  a_md(in_braces, href = href)
}

#' @export
as_markdown.tag_linkS4class <- function(x, ...) {
  if (length(x) != 1) stop_bad_tag("linkS4class")

  text <- flatten_text_md(x[[1]])
  href <- get_topic_href(paste0(text, "-class"))
  a_md(text, href = href)
}

# Miscellaneous --------------------------------------------------------------

#' @export
as_markdown.tag_method <- function(x, ...) method_usage_md(x, "S3")
#' @export
as_markdown.tag_S3method <- function(x, ...) method_usage_md(x, "S3")
#' @export
as_markdown.tag_S4method <- function(x, ...) method_usage_md(x, "S4")

method_usage_md <- function(x, type) {
  fun <- as_markdown(x[[1]])
  class <- as_markdown(x[[2]])
  sprintf("# %s method for %s\n%s", type, class, fun)
}

# Conditionals ---------------------------------------------------------------

#' @export
as_markdown.tag_if <- function(x, ...) {
  if (x[[1]] == "markdown") {
    as_markdown(x[[2]], ...)
  } else {
    ""
  }
}

#' @export
as_markdown.tag_ifelse <- function(x, ...) {
  if (x[[1]] == "markdown") {
    as_markdown(x[[2]], ...)
  } else {
    as_markdown(x[[3]], ...)
  }
}

# Used inside a \usage{} Rd tag to prevent the code from being treated as
# regular R syntax, either because it is not valid R, or because its usage
# intentionally deviates from regular R usage. An example of the former is the
# command line documentation, e.g. `R CMD SHLIB`
# (https://github.com/wch/r-source/blob/trunk/src/library/utils/man/SHLIB.Rd):
#
#    \special{R CMD SHLIB [options] [-o dllname] files}
#
# An example of the latter is the documentation shortcut `?`
# (https://github.com/wch/r-source/blob/trunk/src/library/utils/man/Question.Rd):
#
#    \special{?topic}
#
#' @export
as_markdown.tag_special <- function(x, ...) {
  flatten_text_md(x, ...)
}

#' @export
`as_markdown.#ifdef` <- function(x, ...) {
  os <- trimws(flatten_text_md(x[[1]]))
  if (os == "unix") {
    flatten_text_md(x[[2]])
  } else {
    ""
  }
}

#' @export
`as_markdown.#ifndef` <- function(x, ...) {
  os <- trimws(flatten_text_md(x[[1]]))
  if (os == "windows") {
    flatten_text_md(x[[2]])
  } else {
    ""
  }
}

# Tables ---------------------------------------------------------------------

#' @export
as_markdown.tag_tabular <- function(x, ...) {
  align_abbr <- strsplit(as.character(x[[1]]), "")[[1]]
  align <- align_abbr[align_abbr != "|"]

  contents <- x[[2]]
  class <- sapply(contents, function(x) class(x)[[1]])

  row_sep <- class == "tag_cr"
  contents[row_sep] <- list("")
  col_sep <- class == "tag_tab"
  sep <- col_sep | row_sep

  # Identify groups in reverse order (preserve empty cells)
  # Negative maintains correct ordering once reversed
  cell_grp <- rev(cumsum(-rev(sep)))
  cells <- unname(split(contents, cell_grp))
  # Remove trailing content (that does not match the dimensions of the table)
  cells <- cells[seq_len(length(cells) - length(cells) %% length(align))]
  cell_contents <- trimws(sapply(cells, flatten_text_md, ...))
  tbl <- matrix(cell_contents, ncol = length(align), byrow = TRUE)

  table_md(tbl)
}


# Figures -----------------------------------------------------------------

#' @export
as_markdown.tag_figure <- function(x, ...) {
  path <- as.character(x[[1]])
  alt <- ""

  if (length(x) == 2) {
    opt <- paste(trimws(as.character(x[[2]])), collapse = " ")
    if (substr(opt, 1, 9) != "options: ") {
      alt <- opt
    }
  }

  img_md(path, alt)
}

# List -----------------------------------------------------------------------

#' @export
as_markdown.tag_itemize <- function(x, ...) {
  flatten_para_md(parse_items_md(x, ...))
}
#' @export
as_markdown.tag_enumerate <- function(x, ...) {
  flatten_para_md(parse_items_md(x, enum = TRUE, ...))
}

#' @export
# we manipulate the argument `fmt_code_fun` of the `...` as we cannot directly
# call `parse_descriptions_md(x, fmt_code_fun= f unction(x) x, ...)`, then there
# could be twice the argument `fmt_code_fun`, once explicitly passed and once
# through `...`
as_markdown.tag_describe <- function(x, ...) {
  args <- list(...)
  args$fmt_code_fun <- function(x) x
  flatten_para_md(
    do.call(describe_contents_md, append(list(x = x), args))
  )
}

# only used by parse_items() to split up sequence of tags
#' @export
as_markdown.tag_item <- function(x, ...) ""

# Marking text --------------------------------------------------------------
# https://cran.rstudio.com/doc/manuals/r-devel/R-exts.html#Marking-text

wrap_flattened_text <- function(fun) {
  function(x, ...) {
    fun(flatten_text_md(x, ...))
  }
}

#' @export
as_markdown.tag_emph <- wrap_flattened_text(i_md)
#' @export
as_markdown.tag_strong <- wrap_flattened_text(bi_md)
#' @export
as_markdown.tag_bold <- wrap_flattened_text(b_md)

#' @export
as_markdown.tag_dQuote <- wrap_flattened_text(sQuote)
#' @export
as_markdown.tag_sQuote <- wrap_flattened_text(sQuote)

#' @export
as_markdown.tag_code <- wrap_flattened_text(code_md)

#' @export
as_markdown.tag_preformatted <- wrap_flattened_text(pre_md)

#' @export
as_markdown.tag_kbd <- wrap_flattened_text(code_md)
#' @export
as_markdown.tag_samp <- function(x, ...) sQuote(code_md(flatten_text_md(x, ...)))

#' @export
as_markdown.tag_verb <- wrap_flattened_text(code_md)

#' @export
as_markdown.tag_pkg <- wrap_flattened_text(code_md)
#' @export
as_markdown.tag_file <- wrap_flattened_text(code_md)

#' @export
as_markdown.tag_var <- wrap_flattened_text(i_md)
#' @export
as_markdown.tag_env <- wrap_flattened_text(code_md)
#' @export
as_markdown.tag_option <- wrap_flattened_text(code_md)
#' @export
as_markdown.tag_command <- wrap_flattened_text(code_md)

#' @export
as_markdown.tag_dfn <- as_markdown.character
#' @export
as_markdown.tag_cite <- as_markdown.character
#' @export
as_markdown.tag_acronym <- as_markdown.character
#' @export
as_markdown.tag_abbr <- as_markdown.character

#' @export
as_markdown.tag_out <- function(x, ...) flatten_text_md(x, ..., escape = FALSE)

# Insertions --------------------------------------------------------------

#' @export
as_markdown.tag_R <- function(x, ...) code_md("R")
#' @export
as_markdown.tag_dots <- function(x, ...) code_md("...")
#' @export
as_markdown.tag_ldots <- function(x, ...) code_md("...")
#' @export
as_markdown.tag_cr <- function(x, ...) "\n"

# First element of enc is the encoded version (second is the ascii version)
#' @export
as_markdown.tag_enc <- function(x, ...) {
  if (length(x) == 2) {
    as_markdown(x[[1]], ...)
  } else {
    stop_bad_tag("enc")
  }
}

# Elements that don't return anything ----------------------------------------

#' @export
as_markdown.tag_tab <- function(x, ...) ""
#' @export
as_markdown.tag_newcommand <- function(x, ...) ""
#' @export
as_markdown.tag_renewcommand <- function(x, ...) ""

Try the Rd2md package in your browser

Any scripts or data that you put into this service are public.

Rd2md documentation built on June 22, 2024, 11:15 a.m.