Book a Demo!
CoCalc Logo Icon
StoreFeaturesDocsShareSupportNewsAboutPoliciesSign UpSign In
quarto-dev
GitHub Repository: quarto-dev/quarto-cli
Path: blob/main/src/resources/rmd/hooks.R
12921 views
1
# hooks.R
2
# Copyright (C) 2020-2022 Posit Software, PBC
3
4
# inline knitr:::merge_list()
5
merge_list <- function(x, y) {
6
x[names(y)] <- y
7
x
8
}
9
10
# inline from knitr:::create_fence() from version 1.38
11
# calculate correct number of fences based on content for correct escaping
12
create_fence <- function(x, char = "`") {
13
r <- paste0("\n", char, "{3,}")
14
l <- max(if (grepl(r, x)) attr(gregexpr(r, x)[[1]], "match.length"), 3)
15
paste(rep(char, l), collapse = "")
16
}
17
18
# inline from knitr:::eng2lang() from version 1.38
19
# convert some engine names to language names
20
eng2lang <- function(x) {
21
d <- c(
22
asy = "cpp",
23
mysql = "sql",
24
node = "javascript",
25
psql = "sql",
26
rscript = "r",
27
rcpp = "cpp",
28
tikz = "tex"
29
)
30
x <- tolower(x)
31
if (x %in% names(d)) d[x] else x
32
}
33
34
35
knitr_hooks <- function(format, resourceDir, handledLanguages) {
36
knit_hooks <- list()
37
opts_hooks <- list()
38
39
# options in yaml (save last yaml.code for source hook)
40
lastYamlCode <- NULL
41
opts_hooks[["code"]] <- function(options) {
42
lastYamlCode <<- options[["yaml.code"]]
43
options <- knitr_options_hook(options)
44
if (is.null(lastYamlCode)) {
45
lastYamlCode <<- options[["yaml.code"]]
46
}
47
options
48
}
49
50
# force eval to 'FALSE' for all chunks if execute: enabled: false
51
executeEnabled <- format$execute[["enabled"]]
52
if (!is.null(executeEnabled) && executeEnabled == FALSE) {
53
opts_hooks[["eval"]] <- function(options) {
54
options$eval <- FALSE
55
options
56
}
57
}
58
59
# propagate echo: fenced to echo: true / fenced.echo
60
opts_hooks[["echo"]] <- function(options) {
61
if (identical(options[["echo"]], "fenced")) {
62
options[["echo"]] <- TRUE
63
options[["fenced.echo"]] <- TRUE
64
} else if (isTRUE(options[["chunk.echo"]])) {
65
options[["fenced.echo"]] <- FALSE
66
}
67
# fenced.echo implies hold (if another explicit override isn't there)
68
if (isTRUE(options[["fenced.echo"]])) {
69
if (identical(options[["fig.show"]], "asis")) {
70
options[["fig.show"]] <- "hold"
71
}
72
if (identical(options[["results"]], "markup")) {
73
options[["results"]] <- "hold"
74
}
75
}
76
# for source-only engine, always set `echo: TRUE`
77
if (options[["engine"]] %in% c("embed", "verbatim")) {
78
options[["echo"]] <- TRUE
79
}
80
81
options
82
}
83
84
# forward 'output' to various options. For mainline output, TRUE means flip them
85
# from hide, FALSE means hide. For message/warning TRUE means use the
86
# global default, FALSE means shut them off entirely)
87
opts_hooks[["output"]] <- function(options) {
88
output <- options[["output"]]
89
if (isFALSE(output)) {
90
options[["results"]] <- "hide"
91
options[["fig.show"]] <- "hide"
92
} else if (identical(output, "asis")) {
93
options[["results"]] <- "asis"
94
} else {
95
if (identical(options[["results"]], "hide")) {
96
options[["results"]] <- "markup"
97
}
98
if (identical(options[["fig.show"]], "hide")) {
99
options[["fig.show"]] <- "asis"
100
}
101
}
102
options[["message"]] <- ifelse(
103
!isFALSE(output),
104
knitr::opts_chunk$get("message"),
105
FALSE
106
)
107
options[["warning"]] <- ifelse(
108
!isFALSE(output),
109
knitr::opts_chunk$get("warning"),
110
FALSE
111
)
112
options
113
}
114
115
# automatically set gifski hook for fig.animate
116
opts_hooks[["fig.show"]] <- function(options) {
117
# get current value of fig.show
118
fig.show <- options[["fig.show"]]
119
120
# use gifski as default animation hook for non-latex output
121
if (identical(fig.show, "animate")) {
122
if (
123
!is_pandoc_latex_output(format) && is.null(options[["animation.hook"]])
124
) {
125
options[["animation.hook"]] <- "gifski"
126
}
127
128
# fig.show "asis" -> "hold" for fig: labeled chunks
129
} else if (identical(fig.show, "asis")) {
130
if (is_figure_label(output_label(options))) {
131
options[["fig.show"]] <- "hold"
132
}
133
}
134
135
# return options
136
options
137
}
138
139
# coalesce echos so that all code is displayed for renderings: [light, dark]
140
opts_hooks[["renderings"]] <- function(options) {
141
options$fig.show = 'hold'
142
options
143
}
144
145
opts_hooks[["collapse"]] <- function(options) {
146
if (isTRUE(options[["collapse"]])) {
147
comment <- options[["comment"]]
148
if (is.null(comment) || is.na(comment)) {
149
options[["comment"]] <- "##"
150
}
151
}
152
153
# return options
154
options
155
}
156
157
# opts hooks for implementing keep-hidden
158
register_hidden_hook <- function(option, hidden = option) {
159
opts_hooks[[option]] <<- function(options) {
160
if (identical(options[[option]], FALSE)) {
161
options[[option]] <- TRUE
162
for (hide in hidden) {
163
options[[paste0(hide, ".hidden")]] <- TRUE
164
}
165
}
166
options
167
}
168
}
169
if (isTRUE(format$render[["keep-hidden"]])) {
170
register_hidden_hook("echo", c("source"))
171
register_hidden_hook("output", c("output", "plot"))
172
register_hidden_hook("include")
173
register_hidden_hook("warning")
174
register_hidden_hook("message")
175
}
176
177
# hooks for marking up output
178
default_hooks <- knitr::hooks_markdown()
179
delegating_hook <- function(name, hook) {
180
function(x, options) {
181
x <- default_hooks[[name]](x, options)
182
hook(x, options)
183
}
184
}
185
delegating_output_hook = function(type, classes) {
186
delegating_hook(type, function(x, options) {
187
if (
188
identical(options[["results"]], "asis") ||
189
isTRUE(options[["collapse"]])
190
) {
191
x
192
} else {
193
# prefix for classes
194
classes <- c("cell-output", paste0("cell-output-", classes))
195
# add .hidden class if keep-hidden hook injected an option
196
if (isTRUE(options[[paste0(type, ".hidden")]])) {
197
classes <- c(classes, "hidden")
198
}
199
output_div(x, NULL, classes)
200
}
201
})
202
}
203
204
# entire chunk
205
knit_hooks$chunk <- delegating_hook("chunk", function(x, options) {
206
# Do nothing more for some specific chunk content -----
207
208
# Quarto language handler
209
if (
210
any(as.logical(lapply(handledLanguages, function(lang) {
211
prefix <- paste0("```{", lang, "}")
212
startsWith(x, prefix)
213
}))) &&
214
endsWith(x, "```")
215
) {
216
return(x)
217
}
218
219
# ojs engine should return output unadorned
220
if (startsWith(x, "```{ojs}") && endsWith(x, "```")) {
221
return(x)
222
}
223
224
# verbatim-like and comment knitr's engine should do nothing
225
if (options[["engine"]] %in% c("verbatim", "embed", "comment")) {
226
return(x)
227
}
228
229
# For any other, adding a cell output div -----
230
231
# read some options
232
233
label <- output_label(options)
234
fig.cap <- options[["fig.cap"]]
235
cell.cap <- NULL
236
fig.subcap = options[["fig.subcap"]]
237
238
# If we're preserving cells, we need provide a cell id
239
cellId <- NULL
240
if (isTRUE(format$render$`notebook-preserve-cells`) && !is.null(label)) {
241
cellId <- paste0("cell-", label)
242
}
243
244
# fixup duplicate figure labels
245
placeholder <- output_label_placeholder(options)
246
if (!is.null(placeholder)) {
247
figs <- length(regmatches(x, gregexpr(placeholder, x, fixed = TRUE))[[1]])
248
for (i in 1:figs) {
249
suffix <- ifelse(figs > 1, paste0("-", i), "")
250
x <- sub(placeholder, paste0(label, suffix), fixed = TRUE, x)
251
}
252
}
253
254
# caption output
255
if (!is.null(fig.cap) && !is.null(fig.subcap)) {
256
cell.cap <- paste0("\n", fig.cap, "\n")
257
} else {
258
label <- NULL
259
}
260
261
# synthesize layout if we have fig.sep
262
fig.sep <- options[["fig.sep"]]
263
fig.ncol <- options[["fig.ncol"]]
264
if (!is.null(fig.sep)) {
265
# recycle fig.sep
266
fig.num <- options[["fig.num"]] %||% 1L
267
fig.sep <- rep_len(fig.sep, fig.num)
268
269
# recyle out.width
270
out.width <- options[["out.width"]]
271
if (is.null(out.width)) {
272
out.width <- 1
273
}
274
out.width <- rep_len(out.width, fig.num)
275
276
# build fig.layout
277
fig.layout <- list()
278
fig.row <- c()
279
for (i in 1:fig.num) {
280
fig.row <- c(fig.row, out.width[[i]])
281
if (nzchar(fig.sep[[i]])) {
282
fig.layout[[length(fig.layout) + 1]] <- fig.row
283
fig.row <- c()
284
}
285
}
286
if (length(fig.row) > 0) {
287
fig.layout[[length(fig.layout) + 1]] <- fig.row
288
}
289
options[["layout"]] <- fig.layout
290
291
# populate layout-ncol from fig.ncol
292
} else if (!is.null(fig.ncol)) {
293
options[["layout-ncol"]] = fig.ncol
294
}
295
296
# alias fig.align to layout-align
297
fig.align = options[["fig.align"]]
298
if (!is.null(fig.align) && !identical(fig.align, "default")) {
299
options["layout-align"] = fig.align
300
}
301
302
# alias fig.valign to layout-valign
303
fig.valign = options[["fig.valign"]]
304
if (!is.null(fig.valign) && !identical(fig.valign, "default")) {
305
options["layout-valign"] = fig.valign
306
}
307
308
# forward selected attributes
309
forward <- c(
310
"layout",
311
"layout-nrow",
312
"layout-ncol",
313
"layout-align",
314
"layout-valign"
315
)
316
forwardAttr <- character()
317
for (attr in forward) {
318
value = options[[attr]]
319
if (!is.null(value)) {
320
if (identical(attr, "layout")) {
321
if (!is.character(value)) {
322
value = jsonlite::toJSON(value)
323
}
324
}
325
if (!is.null(value)) {
326
forwardAttr <- c(forwardAttr, sprintf("%s=\"%s\"", attr, value))
327
}
328
}
329
}
330
331
# forward any other unknown attributes
332
# From knitr 1.44, knitr:::opts_chunk_attr and knitr::opts_chunk$get()
333
# should cover all options and knitr will only normalize
334
# to their . version the known knitr options.
335
# Other options (like quarto specific ones) will keep there original values
336
# with - separator.
337
knitr_default_opts <- unique(c(
338
names(knitr:::opts_chunk_attr),
339
names(knitr::opts_chunk$get())
340
))
341
# quarto options common with knitr and that will be normalized to
342
# fmt: skip
343
quarto_knitr_opts <- c(
344
"fig.cap", "fig.subcap", "fig.scap", "fig.link", "fig.alt",
345
"fig.align", "fig.env", "fig.pos", "fig.num", "out.width"
346
)
347
# fmt: skip
348
quarto_opts <- c(
349
"label", "lst-cap", "lst-label", "classes", "panel", "column",
350
"tbl-column", "tbl-cap-location", "cap-location", "code-fold",
351
"code-summary", "code-overflow", "code-line-numbers",
352
"layout", "layout-nrow", "layout-ncol", "layout-align", "layout-valign",
353
"output", "html-table-processing",
354
# duplicating options as they were normalized in knitr < 1.44
355
"fig-column", "fig.column", "fig-cap-location", "fig.cap-location",
356
# those options have been aliased in knitr 1.44
357
"fig-format", "fig.format", "fig-dpi", "fig.dpi",
358
# options created by quarto when `keep-hidden`
359
"include.hidden", "source.hidden", "plot.hidden",
360
"output.hidden", "warning.hidden", "message.hidden"
361
)
362
# Other knitr option possibly not in knitr_default_opts
363
# fmt: skip
364
other_opts <- c(
365
"eval", "yaml.code", "code", "file", "params.src", "original.params.src",
366
"fenced.echo", "chunk.echo", "lang", "out.width.px", "out.height.px",
367
"indent", "class.source", "class.output", "class.message",
368
"class.warning", "class.error", "attr.source", "attr.output",
369
"attr.message", "attr.warning", "attr.error", "connection", "hash"
370
)
371
known_opts <- c(
372
knitr_default_opts,
373
quarto_knitr_opts,
374
quarto_opts,
375
other_opts
376
)
377
unknown_opts <- setdiff(names(options), known_opts)
378
unknown_opts <- Filter(Negate(is.null), unknown_opts)
379
unknown_opts <- Filter(function(opt) !startsWith(opt, "."), unknown_opts)
380
# json encode if necessary
381
unknown_values <- lapply(
382
options[unknown_opts],
383
function(value) {
384
if (!is.character(value) || length(value) > 1) {
385
value <- jsonlite::toJSON(value, auto_unbox = TRUE)
386
}
387
# will be enclosed in single quotes so escape
388
gsub("'", "\\\'", value, fixed = TRUE)
389
}
390
)
391
# append to forward list
392
forwardAttr <- c(
393
forwardAttr,
394
sprintf("%s='%s'", unknown_opts, unknown_values)
395
)
396
if (length(forwardAttr) > 0) {
397
forwardAttr <- paste0(" ", paste(forwardAttr, collapse = " "))
398
} else {
399
forwardAttr <- ""
400
}
401
402
# handle classes
403
classes <- c("cell", options[["classes"]])
404
if (is.character(options[["panel"]])) {
405
classes <- c(classes, paste0("panel-", options[["panel"]]))
406
}
407
if (is.character(options[["column"]])) {
408
classes <- c(classes, paste0("column-", options[["column"]]))
409
}
410
if (is.character(options[["fig-column"]])) {
411
classes <- c(classes, paste0("fig-column-", options[["fig-column"]]))
412
} else if (is.character(options[["fig.column"]])) {
413
# knitr < 1.44 compatibility where fig- -> fig.
414
classes <- c(classes, paste0("fig-column-", options[["fig.column"]]))
415
}
416
if (is.character(options[["tbl-column"]])) {
417
classes <- c(classes, paste0("tbl-column-", options[["tbl-column"]]))
418
}
419
if (is.character(options[["cap-location"]])) {
420
classes <- c(classes, paste0("caption-", options[["cap-location"]]))
421
}
422
if (is.character(options[["fig-cap-location"]])) {
423
classes <- c(
424
classes,
425
paste0("fig-cap-location-", options[["fig-cap-location"]])
426
)
427
} else if (is.character(options[["fig.cap-location"]])) {
428
# knitr < 1.44 compatibility where fig- -> fig.
429
classes <- c(
430
classes,
431
paste0("fig-cap-location-", options[["fig.cap-location"]])
432
)
433
}
434
if (is.character(options[["tbl-cap-location"]])) {
435
classes <- c(
436
classes,
437
paste0("tbl-cap-location-", options[["tbl-cap-location"]])
438
)
439
}
440
441
if (isTRUE(options[["include.hidden"]])) {
442
classes <- c(classes, "hidden")
443
}
444
classes <- sapply(
445
classes,
446
function(clz) ifelse(startsWith(clz, "."), clz, paste0(".", clz))
447
)
448
449
# allow table label through
450
if (is_table_label(options[["label"]])) {
451
label <- options[["label"]]
452
}
453
454
if (is.null(label) && !is.null(cellId)) {
455
label <- cellId
456
}
457
458
if (!is.null(label)) {
459
label <- paste0(label, " ")
460
}
461
462
# if there is a label, additional classes, a forwardAttr, or a cell.cap
463
# then the user is deemed to have implicitly overridden results = "asis"
464
# (as those features don't work w/o an enclosing div)
465
needCell <- isTRUE(nzchar(label)) ||
466
length(classes) > 1 ||
467
isTRUE(nzchar(forwardAttr)) ||
468
isTRUE(nzchar(cell.cap))
469
if (identical(options[["results"]], "asis") && !needCell) {
470
x
471
} else {
472
# Newline first and after to ensure Pandoc Fenced Div is correctly parsed
473
paste0(
474
"\n",
475
options[["indent"]],
476
"::: {",
477
labelId(label),
478
paste(classes, collapse = " "),
479
forwardAttr,
480
"}\n",
481
x,
482
"\n",
483
cell.cap,
484
options[["indent"]],
485
":::\n"
486
)
487
}
488
})
489
knit_hooks$source <- function(x, options) {
490
# How knitr handles the prompt option for R chunks
491
x <- knitr:::hilight_source(x, "markdown", options)
492
x <- knitr:::one_string(c('', x))
493
494
class <- options$class.source
495
attr <- options$attr.source
496
id <- NULL
497
498
# leave some specific engine alone
499
if (!options[["engine"]] %in% c("verbatim", "embed")) {
500
# Add classes and attributes required for quarto specific features
501
class <- paste(class, "cell-code")
502
if (isTRUE(options[["source.hidden"]])) {
503
class <- paste(class, "hidden")
504
}
505
if (!identical(format$metadata[["crossref"]], FALSE)) {
506
id <- options[["lst-label"]]
507
if (!is.null(options[["lst-cap"]])) {
508
attr <- paste(attr, paste0('lst-cap="', options[["lst-cap"]], '"'))
509
}
510
}
511
if (identical(options[["code-overflow"]], "wrap")) {
512
class <- paste(class, "code-overflow-wrap")
513
} else if (identical(options[["code-overflow"]], "scroll")) {
514
class <- paste(class, "code-overflow-scroll")
515
}
516
fold <- options[["code-fold"]]
517
if (!is.null(fold)) {
518
attr <- paste(
519
attr,
520
paste0('code-fold="', tolower(as.character(fold)), '"')
521
)
522
}
523
fold <- options[["code-summary"]]
524
if (!is.null(fold)) {
525
attr <- paste(attr, paste0('code-summary="', as.character(fold), '"'))
526
}
527
lineNumbers <- options[["code-line-numbers"]]
528
if (!is.null(lineNumbers)) {
529
attr <- paste(
530
attr,
531
paste0('code-line-numbers="', tolower(as.character(lineNumbers)), '"')
532
)
533
}
534
}
535
536
# handles same knitr options
537
lang <- tolower(options$lang %||% eng2lang(options$engine))
538
539
if (isTRUE(options[["fenced.echo"]])) {
540
lang <- NULL
541
yamlCode <- lastYamlCode
542
if (!is.null(yamlCode)) {
543
yamlCode <- Filter(
544
function(line) !grepl("\\|\\s+echo:\\s+fenced\\s*$", line),
545
yamlCode
546
)
547
yamlCode <- paste(yamlCode, collapse = "\n")
548
if (!nzchar(yamlCode)) {
549
x <- trimws(x, "left")
550
}
551
} else {
552
x <- trimws(x, "left")
553
}
554
ticks <- create_fence(x, "`")
555
x <- paste0(
556
"\n",
557
ticks,
558
"{{",
559
options[["original.params.src"]],
560
"}}\n",
561
yamlCode,
562
x,
563
"\n",
564
ticks
565
)
566
} else {
567
# If requested, preserve the code yaml and emit it into the code blocks
568
if (isTRUE(format$render$`produce-source-notebook`)) {
569
yamlCode <- lastYamlCode
570
if (!is.null(yamlCode)) {
571
yamlCode <- paste(yamlCode, collapse = "\n")
572
if (!nzchar(yamlCode)) {
573
x <- trimws(x, "left")
574
}
575
x <- paste0("\n", yamlCode, x)
576
}
577
}
578
}
579
580
ticks <- create_fence(x, "`")
581
attrs <- block_attr(
582
id = id,
583
lang = lang,
584
class = trimws(class),
585
attr = attr
586
)
587
588
paste0("\n\n", ticks, attrs, x, "\n", ticks, "\n\n")
589
}
590
knit_hooks$output <- delegating_output_hook("output", c("stdout"))
591
knit_hooks$warning <- delegating_output_hook("warning", c("stderr"))
592
knit_hooks$message <- delegating_output_hook("message", c("stderr"))
593
knit_hooks$plot <- knitr_plot_hook(format)
594
knit_hooks$error <- delegating_output_hook("error", c("error"))
595
596
list(
597
knit = knit_hooks,
598
opts = opts_hooks
599
)
600
}
601
602
knitr_plot_hook <- function(format) {
603
htmlOutput <- knitr:::is_html_output(format$pandoc$to)
604
latexOutput <- is_pandoc_latex_output(format)
605
defaultFigPos <- format$render[["fig-pos"]]
606
607
function(x, options) {
608
# are we using animation (if we are then ignore all but the last fig)
609
fig.num <- options[["fig.num"]] %||% 1L
610
fig.cur = options$fig.cur %||% 1L
611
tikz <- knitr:::is_tikz_dev(options)
612
animate = fig.num > 1 && options$fig.show == 'animate' && !tikz
613
if (animate) {
614
if (fig.cur < fig.num) {
615
return('')
616
} else {
617
# if it's the gifski hook then call it directly (it will call
618
# this function back with the composed animated gif)
619
hook <- knitr:::hook_animation(options)
620
if (identical(hook, knitr:::hook_gifski)) {
621
return(hook(x, options))
622
}
623
}
624
}
625
626
# classes
627
classes <- paste0("cell-output-display")
628
if (isTRUE(options[["plot.hidden"]])) {
629
classes <- c(classes, "hidden")
630
}
631
632
# label
633
placeholder <- output_label_placeholder(options)
634
label <- ifelse(
635
is_figure_label(placeholder),
636
labelId(placeholder),
637
""
638
)
639
attr <- label
640
641
# knitr::fix_options will convert out.width and out.height to their
642
# latex equivalents, reverse this transformation so our figure layout
643
# code can deal directly with percentages
644
options <- latex_sizes_to_percent(options)
645
646
# check for optional figure attributes
647
keyvalue <- c()
648
fig.align <- options[['fig.align']]
649
if (!identical(fig.align, "default")) {
650
keyvalue <- c(keyvalue, sprintf("fig-align='%s'", fig.align))
651
}
652
fig.env <- options[['fig.env']]
653
if (!identical(fig.env, "figure")) {
654
keyvalue <- c(keyvalue, sprintf("fig-env='%s'", fig.env))
655
}
656
fig.pos <- options[['fig.pos']]
657
if (nzchar(fig.pos)) {
658
keyvalue <- c(keyvalue, sprintf("fig-pos='%s'", fig.pos))
659
# if we are echoing code, there is no default fig-pos, and
660
# we are not using a layout then automatically set fig-pos to 'H'
661
} else if (
662
latexOutput &&
663
isTRUE(options[["echo"]]) &&
664
length(names(options)[startsWith(names(options), "layout")]) == 0 &&
665
is.null(defaultFigPos)
666
) {
667
keyvalue <- c(keyvalue, "fig-pos='H'")
668
}
669
fig.alt <- options[["fig.alt"]]
670
escapeAttr <- function(x) gsub("'", "\\'", x, fixed = TRUE)
671
if (!is.null(fig.alt) && nzchar(fig.alt)) {
672
keyvalue <- c(keyvalue, sprintf("fig-alt='%s'", escapeAttr(fig.alt)))
673
}
674
fig.scap <- options[['fig.scap']]
675
if (!is.null(fig.scap)) {
676
keyvalue <- c(keyvalue, sprintf("fig-scap='%s'", escapeAttr(fig.scap)))
677
}
678
resize.width <- options[['resize.width']]
679
if (!is.null(resize.width)) {
680
keyvalue <- c(keyvalue, sprintf("resize.width='%s'", resize.width))
681
}
682
resize.height <- options[['resize.height']]
683
if (!is.null(resize.height)) {
684
keyvalue <- c(keyvalue, sprintf("resize.height='%s'", resize.height))
685
}
686
687
# add keyvalue
688
keyvalue <- paste(
689
c(
690
keyvalue,
691
sprintf('width=%s', options[['out.width']]),
692
sprintf('height=%s', options[['out.height']]),
693
options[['out.extra']]
694
),
695
collapse = ' '
696
)
697
if (nzchar(keyvalue)) {
698
attr <- paste(attr, keyvalue)
699
}
700
701
# create attributes if we have them
702
if (nzchar(attr)) {
703
attr <- paste0("{", trimws(attr), "}")
704
}
705
706
# special handling for animations
707
if (animate) {
708
# get the caption (then remove it so the hook doesn't include it)
709
caption <- figure_cap(options)
710
options[["fig.cap"]] <- NULL
711
options[["fig.subcap"]] <- NULL
712
713
# check for latex
714
if (is_pandoc_latex_output(format)) {
715
# include dependency on animate package
716
knitr::knit_meta_add(list(
717
rmarkdown::latex_dependency("animate")
718
))
719
720
latexOutput <- paste(
721
"```{=latex}",
722
latex_animation(x, options),
723
"```",
724
sep = "\n"
725
)
726
727
# add the caption if we have one
728
if (nzchar(caption)) {
729
latexOutput <- paste0(latexOutput, "\n\n", caption, "\n")
730
}
731
732
# enclose in output div
733
output_div(latexOutput, label, classes)
734
735
# otherwise assume html
736
} else {
737
# render the animation
738
hook <- knitr:::hook_animation(options)
739
htmlOutput <- hook(x, options)
740
htmlOutput <- htmlPreserve(htmlOutput)
741
742
# add the caption if we have one
743
if (nzchar(caption)) {
744
htmlOutput <- paste0(htmlOutput, "\n\n", caption, "\n")
745
}
746
747
# enclose in output div
748
output_div(htmlOutput, label, classes)
749
}
750
} else {
751
# generate markdown for image
752
md <- sprintf("![%s](%s)%s", figure_cap(options), x, attr)
753
754
# enclose in link if requested
755
link <- options[["fig.link"]]
756
if (!is.null(link)) {
757
md <- sprintf("[%s](%s)", md, link)
758
}
759
760
# result = "asis" specific
761
if (identical(options[["results"]], "asis")) {
762
return(md)
763
}
764
765
# enclose in output div
766
output_div(md, NULL, classes)
767
}
768
}
769
}
770
771
knitr_options_hook <- function(options) {
772
if (!knitr_has_yaml_chunk_options()) {
773
# partition yaml options
774
results <- partition_yaml_options(options$engine, options$code)
775
if (!is.null(results$yaml)) {
776
# convert any option with fig- into fig. and out- to out.
777
# we need to do this to the yaml options prior to merging
778
# so that the correctly interact with standard fig. and
779
# out. options provided within knitr
780
results$yaml <- normalize_options(results$yaml)
781
# alias 'warning' explicitly set here to 'message'
782
if (!is.null(results$yaml[["warning"]])) {
783
options[["message"]] = results$yaml[["warning"]]
784
}
785
# merge with other options
786
options <- merge_list(options, results$yaml)
787
# set code
788
options$code <- results$code
789
}
790
options[["yaml.code"]] <- results$yamlSource
791
} else {
792
# from knitr 1.44 onwards the normalization is done at parsing time by knitr
793
# for all known options c(names(opts_chunk_attr), names(opts_chunk$get()))
794
# so normalization here should not be necessary anymore at some point
795
# TODO: remove normalization here in a few years
796
# when 1.44 is widely used version
797
options <- normalize_options(options)
798
}
799
800
# some aliases not normalized
801
# from knitr 1.44, `fig.format` and `fig.dpi` are now aliased
802
# to `dev` and `dpi`
803
# TODO: remove below in a few years when 1.44 is widely used version
804
if (!is.null(options[["fig-format"]])) {
805
options[["dev"]] <- options[["fig-format"]]
806
}
807
if (!is.null(options[["fig-dpi"]])) {
808
options[["dpi"]] <- options[["fig-dpi"]]
809
}
810
811
# if there are line annotations in the code then we need to
812
# force disable messages/warnings
813
comment_chars <- engine_comment_chars(options$engine)
814
pattern <- paste0(".*\\Q", comment_chars[[1]], "\\E\\s*", "<[0-9]+>\\s*")
815
if (length(comment_chars) > 1) {
816
pattern <- paste0(pattern, ".*\\Q", comment_chars[[2]], "\\E\\s*")
817
}
818
pattern <- paste0(pattern, "$")
819
if (any(grepl(pattern, options$code))) {
820
options$warning <- FALSE
821
options$results <- "hold"
822
}
823
824
# fig.subcap: TRUE means fig.subcap: "" (more natural way
825
# to specify that empty subcaps are okay)
826
if (isTRUE(options[["fig.subcap"]])) {
827
options[["fig.subcap"]] <- ""
828
}
829
830
# return options
831
options
832
}
833
834
# convert any option with e.g. fig- into fig.
835
# we do this so that all downstream code can consume a single
836
# variation of these functions. We support both syntaxes because
837
# quarto/pandoc generally uses - as a delimeter everywhere,
838
# however we want to support all existing knitr code as well
839
# as support all documented knitr chunk options without the user
840
# needing to replace . with -
841
# from knitr 1.44 onwards the normalization is done at parsing time by knitr
842
# for all known options c(names(opts_chunk_attr), names(opts_chunk$get()))
843
# so normalization here should not be necessary anymore at some point
844
# TODO: remove normalization here in a few years
845
# when 1.44 is widely used version
846
normalize_options <- function(options) {
847
# TODO: knitr 1.44 store all known options as it does the normalization
848
# they are in `c(names(opts_chunk_attr), names(opts_chunk$get()))`
849
knitr_options_dashed <- c(
850
# Text output
851
"strip-white",
852
"class-output",
853
"class-message",
854
"class-warning",
855
"class-error",
856
"attr-output",
857
"attr-message",
858
"attr-warning",
859
"attr-error",
860
# Paged tables
861
"max-print",
862
"sql-max-print",
863
"paged-print",
864
"rows-print",
865
"cols-print",
866
"cols-min-print",
867
"pages-print",
868
"paged-print",
869
"rownames-print",
870
# Code decoration
871
"tidy-opts",
872
"class-source",
873
"attr-source",
874
# Cache
875
"cache-path",
876
"cache-vars",
877
"cache-globals",
878
"cache-lazy",
879
"cache-comments",
880
"cache-rebuild",
881
# Plots
882
"fig-path",
883
"fig-keep",
884
"fig-show",
885
"dev-args",
886
"fig-ext",
887
"fig-width",
888
"fig-height",
889
"fig-asp",
890
"fig-dim",
891
"out-width",
892
"out-height",
893
"out-extra",
894
"fig-retina",
895
"resize-width",
896
"resize-height",
897
"fig-align",
898
"fig-link",
899
"fig-env",
900
"fig-cap",
901
"fig-alt",
902
"fig-scap",
903
"fig-lp",
904
"fig-pos",
905
"fig-subcap",
906
"fig-ncol",
907
"fig-sep",
908
"fig-process",
909
"fig-showtext",
910
# Animation
911
"animation-hook",
912
"ffmpeg-bitrate",
913
"ffmpeg-format",
914
# Code chunk
915
"ref-label",
916
# Language engines
917
"engine-path",
918
"engine-opts",
919
"opts-label",
920
# Other chunk options
921
"R-options"
922
)
923
# Un-normalize knitr options, and replace any existing options (e.g default one)
924
for (name in knitr_options_dashed) {
925
if (name %in% names(options)) {
926
options[[gsub("-", ".", name)]] <- options[[name]]
927
options[[name]] <- NULL
928
}
929
}
930
options
931
}
932
933
934
partition_yaml_options <- function(engine, code) {
935
# mask out empty blocks
936
if (length(code) == 0) {
937
return(list(
938
yaml = NULL,
939
yamlSource = NULL,
940
code = code
941
))
942
}
943
comment_chars <- engine_comment_chars(engine)
944
comment_start <- paste0(comment_chars[[1]], "| ")
945
comment_end <- ifelse(length(comment_chars) > 1, comment_chars[[2]], "")
946
947
# check for option comments
948
match_start <- startsWith(code, comment_start)
949
match_end <- endsWith(trimws(code, "right"), comment_end)
950
matched_lines <- match_start & match_end
951
952
# has to have at least one matched line at the beginning
953
if (isTRUE(matched_lines[[1]])) {
954
# divide into yaml and code
955
if (all(matched_lines)) {
956
yamlSource <- code
957
code <- c()
958
} else {
959
last_match <- which.min(matched_lines) - 1
960
yamlSource <- code[1:last_match]
961
code <- code[(last_match + 1):length(code)]
962
}
963
964
# trim right
965
if (any(match_end)) {
966
yamlSource <- trimws(yamlSource, "right")
967
}
968
969
# extract yaml from comments, then parse it
970
yaml <- substr(
971
yamlSource,
972
nchar(comment_start) + 1,
973
nchar(yamlSource) - nchar(comment_end)
974
)
975
yaml_options <- yaml::yaml.load(yaml, eval.expr = TRUE)
976
if (!is.list(yaml_options) || length(names(yaml_options)) == 0) {
977
warning(
978
"Invalid YAML option format in chunk: \n",
979
paste(yaml, collapse = "\n"),
980
"\n"
981
)
982
yaml_options <- list()
983
}
984
985
# extract code
986
if (length(code) > 0 && knitr:::is_blank(code[[1]])) {
987
code <- code[-1]
988
yamlSource <- c(yamlSource, "")
989
}
990
991
list(
992
yaml = yaml_options,
993
yamlSource = yamlSource,
994
code = code
995
)
996
} else {
997
list(
998
yaml = NULL,
999
yamlSource = NULL,
1000
code = code
1001
)
1002
}
1003
}
1004
1005
engine_comment_chars <- function(engine) {
1006
comment_chars <- list(
1007
r = "#",
1008
python = "#",
1009
julia = "#",
1010
scala = "//",
1011
matlab = "%",
1012
csharp = "//",
1013
fsharp = "//",
1014
c = c("/*", "*/"),
1015
css = c("/*", "*/"),
1016
sas = c("*", ";"),
1017
powershell = "#",
1018
bash = "#",
1019
sql = "--",
1020
mysql = "--",
1021
psql = "--",
1022
lua = "--",
1023
Rcpp = "//",
1024
cc = "//",
1025
stan = "#",
1026
octave = "#",
1027
fortran = "!",
1028
fortran95 = "!",
1029
awk = "#",
1030
gawk = "#",
1031
stata = "*",
1032
java = "//",
1033
groovy = "//",
1034
sed = "#",
1035
perl = "#",
1036
ruby = "#",
1037
tikz = "%",
1038
js = "//",
1039
d3 = "//",
1040
node = "//",
1041
sass = "//",
1042
coffee = "#",
1043
go = "//",
1044
asy = "//",
1045
haskell = "--",
1046
dot = "//",
1047
apl = "\u235D",
1048
ocaml = c("(*", "*)"),
1049
q = "/",
1050
rust = "//"
1051
)
1052
comment_chars[[engine]] %||% "#"
1053
}
1054
1055
1056
# helper to create an output div
1057
output_div <- function(x, label, classes, attr = NULL) {
1058
div <- "::: {"
1059
if (!is.null(label) && nzchar(label)) {
1060
div <- paste0(div, labelId(label), " ")
1061
}
1062
paste0(
1063
div,
1064
paste(paste0(".", classes), collapse = " "),
1065
ifelse(!is.null(attr), paste0(" ", attr), ""),
1066
"}\n",
1067
x,
1068
"\n:::\n\n"
1069
)
1070
}
1071
1072
labelId <- function(label) {
1073
if (!is.null(label) && !startsWith(label, "#")) paste0("#", label) else label
1074
}
1075
1076
figure_cap <- function(options) {
1077
output_label <- output_label(options)
1078
if (is.null(output_label) || is_figure_label(output_label)) {
1079
fig.cap <- options[["fig.cap"]]
1080
fig.subcap <- options[["fig.subcap"]]
1081
if (length(fig.subcap) != 0) {
1082
fig.subcap
1083
} else if (length(fig.cap) != 0) {
1084
fig.cap
1085
} else {
1086
""
1087
}
1088
} else {
1089
""
1090
}
1091
}
1092
1093
1094
output_label <- function(options) {
1095
label <- options[["label"]]
1096
if (!is.null(label) && grepl("^#?(fig)-", label)) {
1097
label
1098
} else {
1099
NULL
1100
}
1101
}
1102
1103
output_label_placeholder <- function(options) {
1104
kPlaceholder <- "D08295A6-16DC-499D-85A8-8BA656E013A2"
1105
label <- output_label(options)
1106
if (is_figure_label(label)) paste0(label, kPlaceholder) else NULL
1107
}
1108
1109
is_figure_label <- function(label) {
1110
is_label_type("fig", label)
1111
}
1112
1113
is_table_label <- function(label) {
1114
is_label_type("tbl", label)
1115
}
1116
1117
is_label_type <- function(type, label) {
1118
!is.null(label) && grepl(paste0("^#?", type, "-"), label)
1119
}
1120
1121
1122
block_attr <- function(id = NULL, lang = NULL, class = NULL, attr = NULL) {
1123
id <- labelId(id)
1124
if (!is.null(lang) && nzchar(lang)) {
1125
lang <- paste0(".", lang)
1126
} else {
1127
lang <- NULL
1128
}
1129
if (!is.null(class)) {
1130
class <- paste(block_class(class))
1131
}
1132
attributes <- c(id, lang, class, attr)
1133
attributes <- paste(attributes[!is.null(attributes)], collapse = " ")
1134
if (nzchar(attributes)) paste0("{", attributes, "}") else ""
1135
}
1136
1137
block_class <- function(x) {
1138
if (length(x) > 0) gsub('^[.]*', '.', unlist(strsplit(x, '\\s+')))
1139
}
1140
1141
latex_sizes_to_percent <- function(options) {
1142
# \linewidth
1143
width <- options[["out.width"]]
1144
if (!is.null(width)) {
1145
latex_width <- regmatches(
1146
width,
1147
regexec("^([0-9\\.]+)\\\\linewidth$", width)
1148
)
1149
if (length(latex_width[[1]]) > 1) {
1150
width <- paste0(as.numeric(latex_width[[1]][[2]]) * 100, "%")
1151
options[["out.width"]] <- width
1152
}
1153
}
1154
# \textheight
1155
height <- options[["out.height"]]
1156
if (!is.null(height)) {
1157
latex_height <- regmatches(
1158
height,
1159
regexec("^([0-9\\.]+)\\\\textheight$", height)
1160
)
1161
if (length(latex_height[[1]]) > 1) {
1162
height <- paste0(as.numeric(latex_height[[1]][[2]]) * 100, "%")
1163
options[["out.height"]] <- height
1164
}
1165
}
1166
options
1167
}
1168
1169
# ported from:
1170
# https://github.com/yihui/knitr/blob/f8f90baad99d873202b8dc8042eab7a88fac232f/R/hooks-latex.R#L151-L171
1171
latex_animation <- function(x, options) {
1172
fig.num = options$fig.num %||% 1L
1173
1174
ow = options$out.width
1175
# maxwidth does not work with animations
1176
if (identical(ow, '\\maxwidth')) {
1177
ow = NULL
1178
}
1179
if (is.numeric(ow)) {
1180
ow = paste0(ow, 'px')
1181
}
1182
size = paste(
1183
c(
1184
sprintf('width=%s', ow),
1185
sprintf('height=%s', options$out.height),
1186
options$out.extra
1187
),
1188
collapse = ','
1189
)
1190
1191
aniopts = options$aniopts
1192
aniopts = if (is.na(aniopts)) NULL else gsub(';', ',', aniopts)
1193
size = paste(c(size, sprintf('%s', aniopts)), collapse = ',')
1194
if (nzchar(size)) {
1195
size = sprintf('[%s]', size)
1196
}
1197
sprintf(
1198
'\\animategraphics%s{%s}{%s}{%s}{%s}',
1199
size,
1200
1 / options$interval,
1201
sub(sprintf('%d$', fig.num), '', xfun::sans_ext(x)),
1202
1L,
1203
fig.num
1204
)
1205
}
1206
1207
is_ipynb_output <- function(to) {
1208
identical(to, "ipynb")
1209
}
1210
1211