merge_list <- function(x, y) {
x[names(y)] <- y
x
}
create_fence <- function(x, char = "`") {
r <- paste0("\n", char, "{3,}")
l <- max(if (grepl(r, x)) attr(gregexpr(r, x)[[1]], "match.length"), 3)
paste(rep(char, l), collapse = "")
}
eng2lang <- function(x) {
d <- c(
asy = "cpp",
mysql = "sql",
node = "javascript",
psql = "sql",
rscript = "r",
rcpp = "cpp",
tikz = "tex"
)
x <- tolower(x)
if (x %in% names(d)) d[x] else x
}
knitr_hooks <- function(format, resourceDir, handledLanguages) {
knit_hooks <- list()
opts_hooks <- list()
lastYamlCode <- NULL
opts_hooks[["code"]] <- function(options) {
lastYamlCode <<- options[["yaml.code"]]
options <- knitr_options_hook(options)
if (is.null(lastYamlCode)) {
lastYamlCode <<- options[["yaml.code"]]
}
options
}
executeEnabled <- format$execute[["enabled"]]
if (!is.null(executeEnabled) && executeEnabled == FALSE) {
opts_hooks[["eval"]] <- function(options) {
options$eval <- FALSE
options
}
}
opts_hooks[["echo"]] <- function(options) {
if (identical(options[["echo"]], "fenced")) {
options[["echo"]] <- TRUE
options[["fenced.echo"]] <- TRUE
} else if (isTRUE(options[["chunk.echo"]])) {
options[["fenced.echo"]] <- FALSE
}
if (isTRUE(options[["fenced.echo"]])) {
if (identical(options[["fig.show"]], "asis")) {
options[["fig.show"]] <- "hold"
}
if (identical(options[["results"]], "markup")) {
options[["results"]] <- "hold"
}
}
if (options[["engine"]] %in% c("embed", "verbatim")) {
options[["echo"]] <- TRUE
}
options
}
opts_hooks[["output"]] <- function(options) {
output <- options[["output"]]
if (isFALSE(output)) {
options[["results"]] <- "hide"
options[["fig.show"]] <- "hide"
} else if (identical(output, "asis")) {
options[["results"]] <- "asis"
} else {
if (identical(options[["results"]], "hide")) {
options[["results"]] <- "markup"
}
if (identical(options[["fig.show"]], "hide")) {
options[["fig.show"]] <- "asis"
}
}
options[["message"]] <- ifelse(
!isFALSE(output),
knitr::opts_chunk$get("message"),
FALSE
)
options[["warning"]] <- ifelse(
!isFALSE(output),
knitr::opts_chunk$get("warning"),
FALSE
)
options
}
opts_hooks[["fig.show"]] <- function(options) {
fig.show <- options[["fig.show"]]
if (identical(fig.show, "animate")) {
if (
!is_pandoc_latex_output(format) && is.null(options[["animation.hook"]])
) {
options[["animation.hook"]] <- "gifski"
}
} else if (identical(fig.show, "asis")) {
if (is_figure_label(output_label(options))) {
options[["fig.show"]] <- "hold"
}
}
options
}
opts_hooks[["renderings"]] <- function(options) {
options$fig.show = 'hold'
options
}
opts_hooks[["collapse"]] <- function(options) {
if (isTRUE(options[["collapse"]])) {
comment <- options[["comment"]]
if (is.null(comment) || is.na(comment)) {
options[["comment"]] <- "##"
}
}
options
}
register_hidden_hook <- function(option, hidden = option) {
opts_hooks[[option]] <<- function(options) {
if (identical(options[[option]], FALSE)) {
options[[option]] <- TRUE
for (hide in hidden) {
options[[paste0(hide, ".hidden")]] <- TRUE
}
}
options
}
}
if (isTRUE(format$render[["keep-hidden"]])) {
register_hidden_hook("echo", c("source"))
register_hidden_hook("output", c("output", "plot"))
register_hidden_hook("include")
register_hidden_hook("warning")
register_hidden_hook("message")
}
default_hooks <- knitr::hooks_markdown()
delegating_hook <- function(name, hook) {
function(x, options) {
x <- default_hooks[[name]](x, options)
hook(x, options)
}
}
delegating_output_hook = function(type, classes) {
delegating_hook(type, function(x, options) {
if (
identical(options[["results"]], "asis") ||
isTRUE(options[["collapse"]])
) {
x
} else {
classes <- c("cell-output", paste0("cell-output-", classes))
if (isTRUE(options[[paste0(type, ".hidden")]])) {
classes <- c(classes, "hidden")
}
output_div(x, NULL, classes)
}
})
}
knit_hooks$chunk <- delegating_hook("chunk", function(x, options) {
if (
any(as.logical(lapply(handledLanguages, function(lang) {
prefix <- paste0("```{", lang, "}")
startsWith(x, prefix)
}))) &&
endsWith(x, "```")
) {
return(x)
}
if (startsWith(x, "```{ojs}") && endsWith(x, "```")) {
return(x)
}
if (options[["engine"]] %in% c("verbatim", "embed", "comment")) {
return(x)
}
label <- output_label(options)
fig.cap <- options[["fig.cap"]]
cell.cap <- NULL
fig.subcap = options[["fig.subcap"]]
cellId <- NULL
if (isTRUE(format$render$`notebook-preserve-cells`) && !is.null(label)) {
cellId <- paste0("cell-", label)
}
placeholder <- output_label_placeholder(options)
if (!is.null(placeholder)) {
figs <- length(regmatches(x, gregexpr(placeholder, x, fixed = TRUE))[[1]])
for (i in 1:figs) {
suffix <- ifelse(figs > 1, paste0("-", i), "")
x <- sub(placeholder, paste0(label, suffix), fixed = TRUE, x)
}
}
if (!is.null(fig.cap) && !is.null(fig.subcap)) {
cell.cap <- paste0("\n", fig.cap, "\n")
} else {
label <- NULL
}
fig.sep <- options[["fig.sep"]]
fig.ncol <- options[["fig.ncol"]]
if (!is.null(fig.sep)) {
fig.num <- options[["fig.num"]] %||% 1L
fig.sep <- rep_len(fig.sep, fig.num)
out.width <- options[["out.width"]]
if (is.null(out.width)) {
out.width <- 1
}
out.width <- rep_len(out.width, fig.num)
fig.layout <- list()
fig.row <- c()
for (i in 1:fig.num) {
fig.row <- c(fig.row, out.width[[i]])
if (nzchar(fig.sep[[i]])) {
fig.layout[[length(fig.layout) + 1]] <- fig.row
fig.row <- c()
}
}
if (length(fig.row) > 0) {
fig.layout[[length(fig.layout) + 1]] <- fig.row
}
options[["layout"]] <- fig.layout
} else if (!is.null(fig.ncol)) {
options[["layout-ncol"]] = fig.ncol
}
fig.align = options[["fig.align"]]
if (!is.null(fig.align) && !identical(fig.align, "default")) {
options["layout-align"] = fig.align
}
fig.valign = options[["fig.valign"]]
if (!is.null(fig.valign) && !identical(fig.valign, "default")) {
options["layout-valign"] = fig.valign
}
forward <- c(
"layout",
"layout-nrow",
"layout-ncol",
"layout-align",
"layout-valign"
)
forwardAttr <- character()
for (attr in forward) {
value = options[[attr]]
if (!is.null(value)) {
if (identical(attr, "layout")) {
if (!is.character(value)) {
value = jsonlite::toJSON(value)
}
}
if (!is.null(value)) {
forwardAttr <- c(forwardAttr, sprintf("%s=\"%s\"", attr, value))
}
}
}
knitr_default_opts <- unique(c(
names(knitr:::opts_chunk_attr),
names(knitr::opts_chunk$get())
))
quarto_knitr_opts <- c(
"fig.cap", "fig.subcap", "fig.scap", "fig.link", "fig.alt",
"fig.align", "fig.env", "fig.pos", "fig.num", "out.width"
)
quarto_opts <- c(
"label", "lst-cap", "lst-label", "classes", "panel", "column",
"tbl-column", "tbl-cap-location", "cap-location", "code-fold",
"code-summary", "code-overflow", "code-line-numbers",
"layout", "layout-nrow", "layout-ncol", "layout-align", "layout-valign",
"output", "html-table-processing",
"fig-column", "fig.column", "fig-cap-location", "fig.cap-location",
"fig-format", "fig.format", "fig-dpi", "fig.dpi",
"include.hidden", "source.hidden", "plot.hidden",
"output.hidden", "warning.hidden", "message.hidden"
)
other_opts <- c(
"eval", "yaml.code", "code", "file", "params.src", "original.params.src",
"fenced.echo", "chunk.echo", "lang", "out.width.px", "out.height.px",
"indent", "class.source", "class.output", "class.message",
"class.warning", "class.error", "attr.source", "attr.output",
"attr.message", "attr.warning", "attr.error", "connection", "hash"
)
known_opts <- c(
knitr_default_opts,
quarto_knitr_opts,
quarto_opts,
other_opts
)
unknown_opts <- setdiff(names(options), known_opts)
unknown_opts <- Filter(Negate(is.null), unknown_opts)
unknown_opts <- Filter(function(opt) !startsWith(opt, "."), unknown_opts)
unknown_values <- lapply(
options[unknown_opts],
function(value) {
if (!is.character(value) || length(value) > 1) {
value <- jsonlite::toJSON(value, auto_unbox = TRUE)
}
gsub("'", "\\\'", value, fixed = TRUE)
}
)
forwardAttr <- c(
forwardAttr,
sprintf("%s='%s'", unknown_opts, unknown_values)
)
if (length(forwardAttr) > 0) {
forwardAttr <- paste0(" ", paste(forwardAttr, collapse = " "))
} else {
forwardAttr <- ""
}
classes <- c("cell", options[["classes"]])
if (is.character(options[["panel"]])) {
classes <- c(classes, paste0("panel-", options[["panel"]]))
}
if (is.character(options[["column"]])) {
classes <- c(classes, paste0("column-", options[["column"]]))
}
if (is.character(options[["fig-column"]])) {
classes <- c(classes, paste0("fig-column-", options[["fig-column"]]))
} else if (is.character(options[["fig.column"]])) {
classes <- c(classes, paste0("fig-column-", options[["fig.column"]]))
}
if (is.character(options[["tbl-column"]])) {
classes <- c(classes, paste0("tbl-column-", options[["tbl-column"]]))
}
if (is.character(options[["cap-location"]])) {
classes <- c(classes, paste0("caption-", options[["cap-location"]]))
}
if (is.character(options[["fig-cap-location"]])) {
classes <- c(
classes,
paste0("fig-cap-location-", options[["fig-cap-location"]])
)
} else if (is.character(options[["fig.cap-location"]])) {
classes <- c(
classes,
paste0("fig-cap-location-", options[["fig.cap-location"]])
)
}
if (is.character(options[["tbl-cap-location"]])) {
classes <- c(
classes,
paste0("tbl-cap-location-", options[["tbl-cap-location"]])
)
}
if (isTRUE(options[["include.hidden"]])) {
classes <- c(classes, "hidden")
}
classes <- sapply(
classes,
function(clz) ifelse(startsWith(clz, "."), clz, paste0(".", clz))
)
if (is_table_label(options[["label"]])) {
label <- options[["label"]]
}
if (is.null(label) && !is.null(cellId)) {
label <- cellId
}
if (!is.null(label)) {
label <- paste0(label, " ")
}
needCell <- isTRUE(nzchar(label)) ||
length(classes) > 1 ||
isTRUE(nzchar(forwardAttr)) ||
isTRUE(nzchar(cell.cap))
if (identical(options[["results"]], "asis") && !needCell) {
x
} else {
paste0(
"\n",
options[["indent"]],
"::: {",
labelId(label),
paste(classes, collapse = " "),
forwardAttr,
"}\n",
x,
"\n",
cell.cap,
options[["indent"]],
":::\n"
)
}
})
knit_hooks$source <- function(x, options) {
x <- knitr:::hilight_source(x, "markdown", options)
x <- knitr:::one_string(c('', x))
class <- options$class.source
attr <- options$attr.source
id <- NULL
if (!options[["engine"]] %in% c("verbatim", "embed")) {
class <- paste(class, "cell-code")
if (isTRUE(options[["source.hidden"]])) {
class <- paste(class, "hidden")
}
if (!identical(format$metadata[["crossref"]], FALSE)) {
id <- options[["lst-label"]]
if (!is.null(options[["lst-cap"]])) {
attr <- paste(attr, paste0('lst-cap="', options[["lst-cap"]], '"'))
}
}
if (identical(options[["code-overflow"]], "wrap")) {
class <- paste(class, "code-overflow-wrap")
} else if (identical(options[["code-overflow"]], "scroll")) {
class <- paste(class, "code-overflow-scroll")
}
fold <- options[["code-fold"]]
if (!is.null(fold)) {
attr <- paste(
attr,
paste0('code-fold="', tolower(as.character(fold)), '"')
)
}
fold <- options[["code-summary"]]
if (!is.null(fold)) {
attr <- paste(attr, paste0('code-summary="', as.character(fold), '"'))
}
lineNumbers <- options[["code-line-numbers"]]
if (!is.null(lineNumbers)) {
attr <- paste(
attr,
paste0('code-line-numbers="', tolower(as.character(lineNumbers)), '"')
)
}
}
lang <- tolower(options$lang %||% eng2lang(options$engine))
if (isTRUE(options[["fenced.echo"]])) {
lang <- NULL
yamlCode <- lastYamlCode
if (!is.null(yamlCode)) {
yamlCode <- Filter(
function(line) !grepl("\\|\\s+echo:\\s+fenced\\s*$", line),
yamlCode
)
yamlCode <- paste(yamlCode, collapse = "\n")
if (!nzchar(yamlCode)) {
x <- trimws(x, "left")
}
} else {
x <- trimws(x, "left")
}
ticks <- create_fence(x, "`")
x <- paste0(
"\n",
ticks,
"{{",
options[["original.params.src"]],
"}}\n",
yamlCode,
x,
"\n",
ticks
)
} else {
if (isTRUE(format$render$`produce-source-notebook`)) {
yamlCode <- lastYamlCode
if (!is.null(yamlCode)) {
yamlCode <- paste(yamlCode, collapse = "\n")
if (!nzchar(yamlCode)) {
x <- trimws(x, "left")
}
x <- paste0("\n", yamlCode, x)
}
}
}
ticks <- create_fence(x, "`")
attrs <- block_attr(
id = id,
lang = lang,
class = trimws(class),
attr = attr
)
paste0("\n\n", ticks, attrs, x, "\n", ticks, "\n\n")
}
knit_hooks$output <- delegating_output_hook("output", c("stdout"))
knit_hooks$warning <- delegating_output_hook("warning", c("stderr"))
knit_hooks$message <- delegating_output_hook("message", c("stderr"))
knit_hooks$plot <- knitr_plot_hook(format)
knit_hooks$error <- delegating_output_hook("error", c("error"))
list(
knit = knit_hooks,
opts = opts_hooks
)
}
knitr_plot_hook <- function(format) {
htmlOutput <- knitr:::is_html_output(format$pandoc$to)
latexOutput <- is_pandoc_latex_output(format)
defaultFigPos <- format$render[["fig-pos"]]
function(x, options) {
fig.num <- options[["fig.num"]] %||% 1L
fig.cur = options$fig.cur %||% 1L
tikz <- knitr:::is_tikz_dev(options)
animate = fig.num > 1 && options$fig.show == 'animate' && !tikz
if (animate) {
if (fig.cur < fig.num) {
return('')
} else {
hook <- knitr:::hook_animation(options)
if (identical(hook, knitr:::hook_gifski)) {
return(hook(x, options))
}
}
}
classes <- paste0("cell-output-display")
if (isTRUE(options[["plot.hidden"]])) {
classes <- c(classes, "hidden")
}
placeholder <- output_label_placeholder(options)
label <- ifelse(
is_figure_label(placeholder),
labelId(placeholder),
""
)
attr <- label
options <- latex_sizes_to_percent(options)
keyvalue <- c()
fig.align <- options[['fig.align']]
if (!identical(fig.align, "default")) {
keyvalue <- c(keyvalue, sprintf("fig-align='%s'", fig.align))
}
fig.env <- options[['fig.env']]
if (!identical(fig.env, "figure")) {
keyvalue <- c(keyvalue, sprintf("fig-env='%s'", fig.env))
}
fig.pos <- options[['fig.pos']]
if (nzchar(fig.pos)) {
keyvalue <- c(keyvalue, sprintf("fig-pos='%s'", fig.pos))
} else if (
latexOutput &&
isTRUE(options[["echo"]]) &&
length(names(options)[startsWith(names(options), "layout")]) == 0 &&
is.null(defaultFigPos)
) {
keyvalue <- c(keyvalue, "fig-pos='H'")
}
fig.alt <- options[["fig.alt"]]
escapeAttr <- function(x) gsub("'", "\\'", x, fixed = TRUE)
if (!is.null(fig.alt) && nzchar(fig.alt)) {
keyvalue <- c(keyvalue, sprintf("fig-alt='%s'", escapeAttr(fig.alt)))
}
fig.scap <- options[['fig.scap']]
if (!is.null(fig.scap)) {
keyvalue <- c(keyvalue, sprintf("fig-scap='%s'", escapeAttr(fig.scap)))
}
resize.width <- options[['resize.width']]
if (!is.null(resize.width)) {
keyvalue <- c(keyvalue, sprintf("resize.width='%s'", resize.width))
}
resize.height <- options[['resize.height']]
if (!is.null(resize.height)) {
keyvalue <- c(keyvalue, sprintf("resize.height='%s'", resize.height))
}
keyvalue <- paste(
c(
keyvalue,
sprintf('width=%s', options[['out.width']]),
sprintf('height=%s', options[['out.height']]),
options[['out.extra']]
),
collapse = ' '
)
if (nzchar(keyvalue)) {
attr <- paste(attr, keyvalue)
}
if (nzchar(attr)) {
attr <- paste0("{", trimws(attr), "}")
}
if (animate) {
caption <- figure_cap(options)
options[["fig.cap"]] <- NULL
options[["fig.subcap"]] <- NULL
if (is_pandoc_latex_output(format)) {
knitr::knit_meta_add(list(
rmarkdown::latex_dependency("animate")
))
latexOutput <- paste(
"```{=latex}",
latex_animation(x, options),
"```",
sep = "\n"
)
if (nzchar(caption)) {
latexOutput <- paste0(latexOutput, "\n\n", caption, "\n")
}
output_div(latexOutput, label, classes)
} else {
hook <- knitr:::hook_animation(options)
htmlOutput <- hook(x, options)
htmlOutput <- htmlPreserve(htmlOutput)
if (nzchar(caption)) {
htmlOutput <- paste0(htmlOutput, "\n\n", caption, "\n")
}
output_div(htmlOutput, label, classes)
}
} else {
md <- sprintf("%s", figure_cap(options), x, attr)
link <- options[["fig.link"]]
if (!is.null(link)) {
md <- sprintf("[%s](%s)", md, link)
}
if (identical(options[["results"]], "asis")) {
return(md)
}
output_div(md, NULL, classes)
}
}
}
knitr_options_hook <- function(options) {
if (!knitr_has_yaml_chunk_options()) {
results <- partition_yaml_options(options$engine, options$code)
if (!is.null(results$yaml)) {
results$yaml <- normalize_options(results$yaml)
if (!is.null(results$yaml[["warning"]])) {
options[["message"]] = results$yaml[["warning"]]
}
options <- merge_list(options, results$yaml)
options$code <- results$code
}
options[["yaml.code"]] <- results$yamlSource
} else {
options <- normalize_options(options)
}
if (!is.null(options[["fig-format"]])) {
options[["dev"]] <- options[["fig-format"]]
}
if (!is.null(options[["fig-dpi"]])) {
options[["dpi"]] <- options[["fig-dpi"]]
}
comment_chars <- engine_comment_chars(options$engine)
pattern <- paste0(".*\\Q", comment_chars[[1]], "\\E\\s*", "<[0-9]+>\\s*")
if (length(comment_chars) > 1) {
pattern <- paste0(pattern, ".*\\Q", comment_chars[[2]], "\\E\\s*")
}
pattern <- paste0(pattern, "$")
if (any(grepl(pattern, options$code))) {
options$warning <- FALSE
options$results <- "hold"
}
if (isTRUE(options[["fig.subcap"]])) {
options[["fig.subcap"]] <- ""
}
options
}
normalize_options <- function(options) {
knitr_options_dashed <- c(
"strip-white",
"class-output",
"class-message",
"class-warning",
"class-error",
"attr-output",
"attr-message",
"attr-warning",
"attr-error",
"max-print",
"sql-max-print",
"paged-print",
"rows-print",
"cols-print",
"cols-min-print",
"pages-print",
"paged-print",
"rownames-print",
"tidy-opts",
"class-source",
"attr-source",
"cache-path",
"cache-vars",
"cache-globals",
"cache-lazy",
"cache-comments",
"cache-rebuild",
"fig-path",
"fig-keep",
"fig-show",
"dev-args",
"fig-ext",
"fig-width",
"fig-height",
"fig-asp",
"fig-dim",
"out-width",
"out-height",
"out-extra",
"fig-retina",
"resize-width",
"resize-height",
"fig-align",
"fig-link",
"fig-env",
"fig-cap",
"fig-alt",
"fig-scap",
"fig-lp",
"fig-pos",
"fig-subcap",
"fig-ncol",
"fig-sep",
"fig-process",
"fig-showtext",
"animation-hook",
"ffmpeg-bitrate",
"ffmpeg-format",
"ref-label",
"engine-path",
"engine-opts",
"opts-label",
"R-options"
)
for (name in knitr_options_dashed) {
if (name %in% names(options)) {
options[[gsub("-", ".", name)]] <- options[[name]]
options[[name]] <- NULL
}
}
options
}
partition_yaml_options <- function(engine, code) {
if (length(code) == 0) {
return(list(
yaml = NULL,
yamlSource = NULL,
code = code
))
}
comment_chars <- engine_comment_chars(engine)
comment_start <- paste0(comment_chars[[1]], "| ")
comment_end <- ifelse(length(comment_chars) > 1, comment_chars[[2]], "")
match_start <- startsWith(code, comment_start)
match_end <- endsWith(trimws(code, "right"), comment_end)
matched_lines <- match_start & match_end
if (isTRUE(matched_lines[[1]])) {
if (all(matched_lines)) {
yamlSource <- code
code <- c()
} else {
last_match <- which.min(matched_lines) - 1
yamlSource <- code[1:last_match]
code <- code[(last_match + 1):length(code)]
}
if (any(match_end)) {
yamlSource <- trimws(yamlSource, "right")
}
yaml <- substr(
yamlSource,
nchar(comment_start) + 1,
nchar(yamlSource) - nchar(comment_end)
)
yaml_options <- yaml::yaml.load(yaml, eval.expr = TRUE)
if (!is.list(yaml_options) || length(names(yaml_options)) == 0) {
warning(
"Invalid YAML option format in chunk: \n",
paste(yaml, collapse = "\n"),
"\n"
)
yaml_options <- list()
}
if (length(code) > 0 && knitr:::is_blank(code[[1]])) {
code <- code[-1]
yamlSource <- c(yamlSource, "")
}
list(
yaml = yaml_options,
yamlSource = yamlSource,
code = code
)
} else {
list(
yaml = NULL,
yamlSource = NULL,
code = code
)
}
}
engine_comment_chars <- function(engine) {
comment_chars <- list(
r = "#",
python = "#",
julia = "#",
scala = "//",
matlab = "%",
csharp = "//",
fsharp = "//",
c = c("/*", "*/"),
css = c("/*", "*/"),
sas = c("*", ";"),
powershell = "#",
bash = "#",
sql = "--",
mysql = "--",
psql = "--",
lua = "--",
Rcpp = "//",
cc = "//",
stan = "#",
octave = "#",
fortran = "!",
fortran95 = "!",
awk = "#",
gawk = "#",
stata = "*",
java = "//",
groovy = "//",
sed = "#",
perl = "#",
ruby = "#",
tikz = "%",
js = "//",
d3 = "//",
node = "//",
sass = "//",
coffee = "#",
go = "//",
asy = "//",
haskell = "--",
dot = "//",
apl = "\u235D",
ocaml = c("(*", "*)"),
q = "/",
rust = "//"
)
comment_chars[[engine]] %||% "#"
}
output_div <- function(x, label, classes, attr = NULL) {
div <- "::: {"
if (!is.null(label) && nzchar(label)) {
div <- paste0(div, labelId(label), " ")
}
paste0(
div,
paste(paste0(".", classes), collapse = " "),
ifelse(!is.null(attr), paste0(" ", attr), ""),
"}\n",
x,
"\n:::\n\n"
)
}
labelId <- function(label) {
if (!is.null(label) && !startsWith(label, "#")) paste0("#", label) else label
}
figure_cap <- function(options) {
output_label <- output_label(options)
if (is.null(output_label) || is_figure_label(output_label)) {
fig.cap <- options[["fig.cap"]]
fig.subcap <- options[["fig.subcap"]]
if (length(fig.subcap) != 0) {
fig.subcap
} else if (length(fig.cap) != 0) {
fig.cap
} else {
""
}
} else {
""
}
}
output_label <- function(options) {
label <- options[["label"]]
if (!is.null(label) && grepl("^#?(fig)-", label)) {
label
} else {
NULL
}
}
output_label_placeholder <- function(options) {
kPlaceholder <- "D08295A6-16DC-499D-85A8-8BA656E013A2"
label <- output_label(options)
if (is_figure_label(label)) paste0(label, kPlaceholder) else NULL
}
is_figure_label <- function(label) {
is_label_type("fig", label)
}
is_table_label <- function(label) {
is_label_type("tbl", label)
}
is_label_type <- function(type, label) {
!is.null(label) && grepl(paste0("^#?", type, "-"), label)
}
block_attr <- function(id = NULL, lang = NULL, class = NULL, attr = NULL) {
id <- labelId(id)
if (!is.null(lang) && nzchar(lang)) {
lang <- paste0(".", lang)
} else {
lang <- NULL
}
if (!is.null(class)) {
class <- paste(block_class(class))
}
attributes <- c(id, lang, class, attr)
attributes <- paste(attributes[!is.null(attributes)], collapse = " ")
if (nzchar(attributes)) paste0("{", attributes, "}") else ""
}
block_class <- function(x) {
if (length(x) > 0) gsub('^[.]*', '.', unlist(strsplit(x, '\\s+')))
}
latex_sizes_to_percent <- function(options) {
width <- options[["out.width"]]
if (!is.null(width)) {
latex_width <- regmatches(
width,
regexec("^([0-9\\.]+)\\\\linewidth$", width)
)
if (length(latex_width[[1]]) > 1) {
width <- paste0(as.numeric(latex_width[[1]][[2]]) * 100, "%")
options[["out.width"]] <- width
}
}
height <- options[["out.height"]]
if (!is.null(height)) {
latex_height <- regmatches(
height,
regexec("^([0-9\\.]+)\\\\textheight$", height)
)
if (length(latex_height[[1]]) > 1) {
height <- paste0(as.numeric(latex_height[[1]][[2]]) * 100, "%")
options[["out.height"]] <- height
}
}
options
}
latex_animation <- function(x, options) {
fig.num = options$fig.num %||% 1L
ow = options$out.width
if (identical(ow, '\\maxwidth')) {
ow = NULL
}
if (is.numeric(ow)) {
ow = paste0(ow, 'px')
}
size = paste(
c(
sprintf('width=%s', ow),
sprintf('height=%s', options$out.height),
options$out.extra
),
collapse = ','
)
aniopts = options$aniopts
aniopts = if (is.na(aniopts)) NULL else gsub(';', ',', aniopts)
size = paste(c(size, sprintf('%s', aniopts)), collapse = ',')
if (nzchar(size)) {
size = sprintf('[%s]', size)
}
sprintf(
'\\animategraphics%s{%s}{%s}{%s}{%s}',
size,
1 / options$interval,
sub(sprintf('%d$', fig.num), '', xfun::sans_ext(x)),
1L,
fig.num
)
}
is_ipynb_output <- function(to) {
identical(to, "ipynb")
}