R/as-paragraph-md.R

In ftExtra: Extensions for 'Flextable'

vertical_align <- function(sup, sub) {
  .f <- rep(FALSE, max(1L, length(sup), length(sub)))
  sup <- sup %||% .f
  sub <- sub %||% .f
  dplyr::if_else(
    is.na(sub) | !sub,
    dplyr::if_else(sup, "superscript", NA_character_),
    "subscript"
  )
}

pandoc_attr <- function(x, y) {
  a <- attr(x, "pandoc_attr", exact = TRUE)
  if (is.null(a) || is.null(a[[y]])) {
    return(NA)
  }
  a[[y]]
}

pandoc_attrs <- function(x, y) {
  lapply(x, pandoc_attr, y)
}

image_size <- function(x, y = "width") {
  if (is.null(x)) {
    return(NA_real_)
  }
  as.numeric(pandoc_attrs(x, y))
}

organize <- function(md_df, auto_color_link, .solve_footnote) {
  id <- pandoc_attrs(md_df$Div, "id")
  cells <- unname(split(
    dplyr::select(md_df, !"Div"),
    factor(id, levels = unique(id))
  ))

  lapply(cells, function(cell) {
    construct_chunk(as.list(.solve_footnote(cell)), auto_color_link)
  })
}

construct_chunk <- function(x, auto_color_link = "blue") {
  flextable::chunk_dataframe(
    txt = x$txt %||% "", # x can be empty list when input is empty string
    italic = x$Emph %||% NA,
    bold = x$Strong %||% NA,
    url = x$Link %||% NA_character_,
    width = image_size(x$Image, "width"),
    height = image_size(x$Image, "height"),
    vertical.align = vertical_align(x$Superscript, x$Subscript),
    underlined = x$Underline %||% NA,
    color = x$color %||% NA_character_,
    shading.color = x$shading.color %||% NA_character_,
    font.family = x$font.family %||% NA_character_
  ) %>%
    dplyr::mutate(
      color = dplyr::if_else(
        is.na(.data$color) & !is.na(.data$url),
        auto_color_link,
        .data$color
      ),
      img_data = x$Image %||% list(NULL),
      seq_index = dplyr::row_number()
    )
}

#' Convert a character vector into markdown paragraph(s)
#'
#' Parse markdown cells and returns the "paragraph" object.
#'
#' @param x A character vector.
#' @param auto_color_link A color of the link texts.
#' @param md_extensions
#'   Pandoc's extensions. Although it is prefixed with "md", extensions for any
#'   formats specified to `.from` can be used. See
#'   <https://www.pandoc.org/MANUAL.html#extensions> for details.
#' @param metadata
#'   A list of metadata, typically the parsed result of the YAML front matter
#'   (default: `rmarkdown::metadata`). This value is used iff the `.from`
#'   argument specifies the input format that supports the YAML metadata blocks.
#' @param replace_na A value to replace `NA` (default = `""`).
#' @param .from
#'   Pandoc's `--from` argument (default: `'markdown+autolink_bare_uris'`).
#' @param .footnote_options
#'   Options for footnotes generated by `footnote_options()`.
#' @param ...
#'   Arguments passed to internal functions.
#' @inheritParams rmarkdown::html_document
#'
#' @examples
#' if (rmarkdown::pandoc_available("2.0.6")) {
#'   library(flextable)
#'   ft <- flextable(
#'     data.frame(
#'       x = c("**foo** bar", "***baz***", "*qux*"),
#'       stringsAsFactors = FALSE
#'     )
#'   )
#'   ft <- compose(ft, j = "x", i = 1:2, value = as_paragraph_md(x))
#'   autofit(ft)
#' }
#' @export
as_paragraph_md <- function(
  x,
  auto_color_link = "blue",
  md_extensions = NULL,
  pandoc_args = NULL,
  metadata = rmarkdown::metadata,
  replace_na = "",
  .from = "markdown+autolink_bare_uris-raw_html-raw_attribute",
  .footnote_options = NULL,
  ...
) {
  if (!is.character(auto_color_link) || length(auto_color_link) != 1L) {
    stop("`auto_color_link` must be a string")
  }

  pandoc_args <- c(lua_filters(...), pandoc_args)
  .from <- paste0(.from, paste(md_extensions, collapse = ""))

  divs <- supported_divs(.from)

  .solve_footnote <- function(...) {
    solve_footnote(
      ...,
      .footnote_options = .footnote_options,
      auto_color_link = auto_color_link,
      pandoc_args = pandoc_args,
      metadata = metadata,
      .from = .from
    )
  }

  paragraph <- if (length(divs) > 0L) {
      # a faster processing of x by reducing calls of pandoc.
      # here, x becomes a single document whose divs represent cells.
      md_df <- x %>%
        stringr::str_replace_na(replace_na) %>%
        purrr::map2_chr(paste0("cell", seq_along(x)), add_id, divs = divs) %>%
        paste(collapse = "") %>%
        md2df(pandoc_args = pandoc_args,
              metadata = metadata,
              .from = .from)
      organize(md_df, auto_color_link, .solve_footnote)
    } else {
      # a slower processing of x by calling pandoc for each cells.
      lapply(x, function(x) {
        if (x == "") return(construct_chunk(list()))
        y <- x %>%
          md2df(pandoc_args = pandoc_args, .from = .from) %>%
          .solve_footnote() %>%
          as.list()
        construct_chunk(as.list(y), auto_color_link)
      })
    }

  structure(paragraph, class = "paragraph")
}

divs_template <- c(
  fenced_divs = "\n\n::: {#%s}\n\n%s\n\n:::\n\n",
  native_divs = "\n\n<div id=%s>\n\n%s\n\n</div>\n\n"
)

add_id <- function(x, id, divs = "fenced_divs") {
  sprintf(divs_template[divs[[1L]]], id, x)
}