#' An Rmd output format that produces Hugo-flavoured markdown
#'
#' This RMarkdown output format is designed to generate markdown that is
#' maximally compatible with Hugo. It intelligently generates a preview so
#' that you see something useful when Hugo isn't running, but it doesn't
#' get in the way of hugo's full-site preview when it is.
#'
#' @section Syntax highlighting:
#'
#' `md_document()` uses a hybrid system for syntax highlighting.
#' For R code it uses [downlit](http://github.com/r-lib/downlit). For
#' other languages, it relies on Chroma, the syntax highlighter built into
#' hugo.
#'
#' @export
#' @inheritParams rmarkdown::md_document
#' @param fig_width Figure width (in inches).
#' @param fig_asp Figure aspect ratio, defaults to the golden ratio.
#' @param tidyverse_style Use tidyverse knitr conventions? This sets
#' `collapse = TRUE`, `comment = "#>`, `fig.align = "center"`, and
#' `out.width = "700px"`.
md_document <- function(fig_width = 7,
fig_asp = 0.618,
fig_retina = 2,
tidyverse_style = TRUE
) {
knitr <- rmarkdown::knitr_options_html(
fig_height = NULL,
fig_width = fig_width,
fig_retina = fig_retina,
keep_md = FALSE
)
knitr$opts_chunk$fig.asp <- fig_asp
knitr$opts_chunk$fig.path <- "figs/"
# Ensure knitr doesn't turn HTML widgets into pngs
knitr$opts_chunk$screenshot.force <- FALSE
knitr$knit_hooks <- knit_hooks()
if (tidyverse_style) {
knitr$opts_chunk$collapse <- TRUE
knitr$opts_chunk$comment <- "#>"
knitr$opts_chunk$fig.align <- "center"
knitr$opts_chunk$out.width <- "700px"
}
pandoc <- rmarkdown::pandoc_options(
to = goldmark_format(),
from = paste0(rmarkdown::rmarkdown_format(), "+emoji"),
args = "--wrap=none",
ext = ".md"
)
input_rmd <- NULL
old_options <- NULL
old_env <- NULL
pre_knit <- function(input, ...) {
input_rmd <<- input
old_options <<- options(
cli.unicode = TRUE,
cli.num_colors = 8L,
cli.dynamic = FALSE,
crayon.enabled = TRUE
)
old_env <- set_envvar(c(RSTUDIO = 0))
}
on_exit <- function(...) {
options(old_options)
set_envvar(old_env)
}
hack_always_allow_html <- function(...) {
# This truly awful hack ensures that rmarkdown doesn't tell us we're
# producing HTML widgets
render_env <- env_parent(parent.frame())
render_env$front_matter$always_allow_html <- TRUE
NULL
}
knit_meta <- NULL
output_dir <- NULL
preprocess <- function(metadata, input_file, runtime, knit_meta, files_dir, output_dir) {
knit_meta <<- knit_meta
output_dir <<- output_dir
NULL
}
postprocess <- function(metadata, input_file, output_file, clean, verbose) {
old_yaml <- extract_yaml(brio::read_lines(input_file))
new_yaml <- list(rmd_hash = rmd_hash(input_rmd))
if (length(knit_meta) > 0) {
if (!is_installed("htmltools")) {
abort("htmltools package required for posts that include HTML widgets")
}
# Capture dependencies, remove duplicates, save to directory, and render
deps <- htmltools::resolveDependencies(knit_meta)
local <- lapply(deps, htmltools::copyDependencyToDir, outputDir = output_dir)
local <- lapply(local, htmltools::makeDependencyRelative, output_dir)
deps <- strsplit(htmltools::renderDependencies(local), "\n")[[1]]
new_yaml$html_dependencies <- deps
}
body <- brio::read_file(output_file)
output_lines <- c(
"---", old_yaml, yaml::as.yaml(new_yaml), "---",
"",
link_inline(body)
)
brio::write_lines(output_lines, output_file)
# If server not running, and RStudio is rendering the doc, generate
# a standalone HTML file for preview
if (!port_active(1313) && !is.na(preview_dir())) {
output_html <- "preview.html"
rmarkdown::pandoc_convert(
input = output_file,
output = output_html,
to = "html",
options = preview_pandoc_args()
)
output_file <- file_move(output_html, preview_path())
} else {
output_file <- tempdir()
}
output_file
}
rmarkdown::output_format(
knitr = knitr,
pandoc = pandoc,
pre_processor = preprocess,
post_processor = postprocess,
pre_knit = pre_knit,
post_knit = hack_always_allow_html,
on_exit = on_exit
)
}
goldmark_format <- function() {
paste(
"markdown_strict",
# https://github.com/rstudio/rstudio/blob/master/src/gwt/panmirror/src/editor/src/api/pandoc_format.ts#L344-L356
"all_symbols_escapable",
"backtick_code_blocks",
"fenced_code_blocks",
"space_in_atx_header",
"intraword_underscores",
"lists_without_preceding_blankline",
"shortcut_reference_links",
# https://github.com/rstudio/rstudio/blob/master/src/gwt/panmirror/src/editor/src/api/pandoc_format.ts#L380-L392
"pipe_tables",
"strikeout",
"autolink_bare_uris",
"task_lists",
"definition_lists",
"footnotes",
"smart",
"tex_math_dollars",
# custom
"native_divs",
"emoji",
sep = "+"
)
}
preview_pandoc_args <- function() {
template_path <- path_package(
"rmarkdown/templates/github_document/resources/preview.html",
package = "rmarkdown"
)
css_path <- path_package(
"rmarkdown/templates/github_document/resources/github.css",
package = "rmarkdown"
)
args <- c(
"--standalone",
"--self-contained",
"--highlight-style", "pygments",
"--template", template_path,
"--email-obfuscation", "none",
"--variable", paste0("github-markdown-css:", css_path),
"--metadata", "pagetitle=PREVIEW"
)
}
preview_dir <- function() {
Sys.getenv("RMARKDOWN_PREVIEW_DIR", unset = NA)
}
preview_path <- function() {
file_temp("preview-", preview_dir(), ext = "html")
}
extract_yaml <- function(lines) {
delim <- grep("^---\\s*$", lines)
if (length(delim) < 2) {
return(character())
}
lines[(delim[[1]] + 1):(delim[[2]] - 1)]
}
# knitr hooks -------------------------------------------------------------
knit_hooks <- function() {
in_code <- FALSE
needs_code <- function(val, x, before = TRUE) {
if (val == in_code) {
return(x)
}
in_code <<- val
if (val) {
html <- "<pre class='chroma'><code class='language-r' data-lang='r'>"
ws <- ""
} else {
html <- "</code></pre>"
# move trailing newline after code
if (grepl("\n$", x)) {
x <- gsub("\n$", "", x)
ws <- "\n"
} else {
ws <- ""
}
}
if (before) {
paste0(html, x, ws)
} else {
paste0(x, html, ws)
}
}
hook_output <- function(type, x, options) {
if (options$results == "asis") {
needs_code(FALSE, x)
} else {
x <- paste0(x, "\n", collapse = "")
x <- highlight_if_possible(x, options$engine)
needs_code(TRUE, x)
}
}
hook_source <- function(x, options) {
x <- paste0(x, "\n", collapse = "")
x <- highlight_if_possible(x, options$engine)
x <- paste0(x, "\n")
needs_code(TRUE, x)
}
hook_plot <- function(x, options) {
# Repair damage done by pretending to be latex
if (grepl("linewidth", options$out.width)) {
width <- as.numeric(gsub("\\\\linewidth", "", options$out.width))
options$out.width <- paste0(width * 100, "%")
}
x <- knitr::hook_plot_md(x, options)
needs_code(FALSE, x)
}
hook_chunk <- function(x, options, ...) {
x <- needs_code(FALSE, x, before = FALSE) # reset for next chunk
x <- paste0("<div class='highlight'>", x, "</div>")
indent(x, options$indent)
}
evaluate <- function(input, ...) {
# Setting output format to latex ensures that asis outputs are still
# passed to hook_output
Encoding(input) <- "UTF-8"
knitr::opts_knit$set(out.format = "latex")
evaluate::evaluate(input, ...)
}
list(
chunk = hook_chunk,
evaluate = evaluate,
source = hook_source,
plot = hook_plot,
output = function(x, opts) hook_output("output", x, opts),
warning = function(x, opts) hook_output("warning", x, opts),
error = function(x, opts) hook_output("error", x, opts),
message = function(x, opts) hook_output("message", x, opts)
)
}
# if x is not valid R code, downlit::highlight will return NA
# In this case, we return x without highlighting.
highlight_if_possible <- function(x, engine) {
if (engine != "R") {
x
} else {
out <- downlit::highlight(x, pre_class = NULL)
# replace curly operator with HTML entities
# otherwise Hugo will treat it as a shortcode
out <- gsub("\\{", "{", out)
out <- gsub("\\}", "}", out)
if (is.na(out)) {
x
} else {
out
}
}
}
indent <- function(x, indent) {
if (is.null(indent)) {
return(x)
}
paste0(indent, gsub("\n", paste0("\n", indent), x))
}
# inline code -------------------------------------------------------------
link_inline <- function(x) {
regexps <- c(
"\\[[^\\]]+\\]\\([^\\)]*\\)" , # link
"(?m)^\\s*#{1,}.*$", # heading
"(?s)<pre.*?</pre>" # code block
)
danger <- paste0("(", regexps, ")", collapse = "|")
protect_code <- function(x) gsub("`", "\u241E", x)
restore_code <- function(x) gsub("\u241E", "`", x)
x <- str_replace(x, danger, protect_code)
x <- str_replace(x, "(?<!``)`([^`]+)`", function(match) {
code <- gsub("^`|`$", "", match)
href <- vapply(code, downlit::autolink_url, character(1))
ifelse(is.na(href), match, paste0("[", match, "](", href, ")"))
})
x <- str_replace(x, danger, restore_code)
x
}
str_replace <- function(x, pattern, fun, ...) {
loc <- gregexpr(pattern, x, perl = TRUE)
matches <- regmatches(x, loc)
out <- lapply(matches, fun, ...)
regmatches(x, loc) <- out
x
}
#' Deprecated: please use `md_document()`
#' @export
#' @keywords internal
hugo_document <- md_document
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.