1
# execute.R
2
# Copyright (C) 2020-2022 Posit Software, PBC
3

4
# quarto_process_inline_uuid: uuid_5b6f6da5_61c6_4cec_a0e0_0cdeaa1cb2b8
5
# we replace - with _ so that it's a valid R identifier without
6
# requiring backticks (because we'll use it in inline code that is itself wrapped in backticks)
7

8
# execute rmarkdown::render
9
execute <- function(
10
  input,
11
  format,
12
  tempDir,
13
  libDir,
14
  dependencies,
15
  cwd,
16
  params,
17
  resourceDir,
18
  handledLanguages,
19
  markdown
20
) {
21
  # calculate knit_root_dir (before we setwd below)
22
  knit_root_dir <- if (!is.null(cwd)) {
23
    tools::file_path_as_absolute(cwd)
24
  } else {
25
    NULL
26
  }
27

28
  # change to input dir and make input relative (matches
29
  # behavior/expectations of rmarkdown::render code)
30
  oldwd <- setwd(dirname(rmarkdown:::abs_path(input)))
31
  on.exit(setwd(oldwd), add = TRUE)
32
  input <- basename(input)
33

34
  # rmd input filename
35
  rmd_input <- paste0(xfun::sans_ext(input), ".rmarkdown")
36

37
  # swap out the input by reading then writing content.
38
  # This handles `\r\n` EOL on windows in `markdown` string
39
  # by spliting in lines
40
  xfun::write_utf8(
41
    xfun::read_utf8(textConnection(markdown, encoding = "UTF-8")),
42
    rmd_input
43
  )
44
  input <- rmd_input
45

46
  # remove the rmd input on exit
47
  rmd_input_path <- rmarkdown:::abs_path(rmd_input)
48
  on.exit(unlink(rmd_input_path), add = TRUE)
49

50
  # give the input an .Rmd extension if it doesn't already have one
51
  # (this is a temporary copy which we'll remove before exiting). note
52
  # that we only need to do this for older versions of rmarkdown
53
  #if (utils::packageVersion("rmarkdown") < "2.9.4") {
54
  #  if (!tolower(xfun::file_ext(input)) %in% c("r", "rmd", "rmarkdown")) {
55
  #    # rmd input filename
56
  #    rmd_input <- paste0(xfun::sans_ext(input), ".Rmd")
57
  #
58
  #    # swap out the input
59
  #    write(markdown, rmd_input)
60
  #    input <- rmd_input
61
  #
62
  #    # remove the rmd input on exit
63
  #    rmd_input_path <- rmarkdown:::abs_path(rmd_input)
64
  #    on.exit(unlink(rmd_input_path))
65
  #  }
66
  #}
67

68
  # pass through ojs chunks
69
  knitr::knit_engines$set(ojs = function(options) {
70
    knitr:::one_string(c(
71
      "```{ojs}",
72
      options$yaml.code,
73
      options$code,
74
      "```"
75
    ))
76
  })
77

78
  # pass through all languages handled by cell handlers in quarto
79
  langs = lapply(
80
    setNames(handledLanguages, handledLanguages),
81
    function(lang) {
82
      function(options) {
83
        knitr:::one_string(c(
84
          paste0("```{", lang, "}"),
85
          options$yaml.code,
86
          options$code,
87
          "```"
88
        ))
89
      }
90
    }
91
  )
92
  knitr::knit_engines$set(langs)
93

94
  # apply r-options (if any)
95
  r_options <- format$metadata$`r-options`
96
  if (!is.null(r_options)) {
97
    do.call(options, r_options)
98
  }
99

100
  # set some default DT options for dashboards (if not otherwise specified)
101
  if (is_dashboard_output(format)) {
102
    if (is.na(getOption("DT.options", NA))) {
103
      options(
104
        DT.options = list(
105
          bPaginate = FALSE,
106
          dom = "ifrt",
107
          language = list(info = "Showing _TOTAL_ entries")
108
        )
109
      )
110
    }
111
  }
112

113
  # get kntir options
114
  knitr <- knitr_options(format, resourceDir, handledLanguages)
115

116
  # fixup options for cache
117
  knitr <- knitr_options_with_cache(input, format, knitr)
118

119
  # Apply patches to current R environments (like modifying function in packages' namespace)
120
  apply_responsive_patch(format)
121

122
  post_knit <- function(...) {
123
    # provide ojs integration for shiny prerendered
124
    if (is_shiny_prerendered(knitr::opts_knit$get("rmarkdown.runtime"))) {
125
      code <- readLines(file.path(resourceDir, "rmd", "ojs.R"))
126
      rmarkdown::shiny_prerendered_chunk("server-extras", code, TRUE)
127
    }
128

129
    # This truly awful hack ensures that rmarkdown doesn't tell us we're
130
    # producing HTML widgets when targeting a non-html format (doing this
131
    # is triggered by the "prefer-html" options)
132
    if (is_html_prefered(format) || is_pandoc_to_format(format, c("native"))) {
133
      render_env <- parent.env(parent.frame())
134
      render_env$front_matter$always_allow_html <- TRUE
135
    }
136

137
    # return no new pandoc args
138
    NULL
139
  }
140

141
  # determine df_print
142
  df_print <- format$execute$`df-print`
143
  if (
144
    df_print == "paged" &&
145
      !is_pandoc_html_format(format) &&
146
      !is_html_prefered(format)
147
  ) {
148
    df_print <- "kable"
149
  }
150

151
  # synthesize rmarkdown output format
152
  output_format <- rmarkdown::output_format(
153
    knitr = knitr,
154
    pandoc = pandoc_options(format),
155
    post_knit = post_knit,
156
    keep_md = FALSE,
157
    clean_supporting = TRUE,
158
    df_print = df_print
159
  )
160

161
  # we need ojs only if markdown has ojs code cells
162
  # inspect code cells for spaces after line breaks
163

164
  needs_ojs <- grepl("(\n|^)[[:space:]]*```+\\{ojs[^}]*\\}", markdown)
165
  # FIXME this test isn't failing in shiny mode, but it doesn't look to be
166
  # breaking quarto-shiny-ojs. We should make sure this is right.
167
  if (
168
    !is_shiny_prerendered(knitr::opts_knit$get("rmarkdown.runtime")) &&
169
      needs_ojs
170
  ) {
171
    local({
172
      # create a hidden environment to store specific objects
173
      .quarto_tools_env <- attach(NULL, name = "tools:quarto")
174
      # source ojs_define() function and save it in the tools environment
175
      source(file.path(resourceDir, "rmd", "ojs_static.R"), local = TRUE)
176
      assign("ojs_define", ojs_define, envir = .quarto_tools_env)
177
    })
178
  }
179

180
  env <- globalenv()
181
  env$.QuartoInlineRender <- function(v) {
182
    if (is.null(v)) {
183
      "NULL"
184
    } else if (inherits(v, "AsIs")) {
185
      v
186
    } else if (is.character(v)) {
187
      gsub(
188
        pattern = "(\\[|\\]|[`*_{}()>#+-.!])",
189
        x = v,
190
        replacement = "\\\\\\1"
191
      )
192
    } else {
193
      v
194
    }
195
  }
196

197
  render_output <- rmarkdown::render(
198
    input = input,
199
    output_format = output_format,
200
    knit_root_dir = knit_root_dir,
201
    params = params,
202
    run_pandoc = FALSE,
203
    envir = env
204
  )
205
  knit_meta <- attr(render_output, "knit_meta")
206
  files_dir <- attr(render_output, "files_dir")
207
  intermediates_dir <- attr(render_output, "intermediates_dir")
208

209
  # preserve chunks as necessary
210
  output_file <- file.path(dirname(input), render_output)
211
  preserved <- extract_preserve_chunks(output_file, format)
212

213
  # include supporting files
214
  supporting <- if (
215
    !is.null(intermediates_dir) && file_test("-d", intermediates_dir)
216
  ) {
217
    rmarkdown:::abs_path(intermediates_dir)
218
  } else {
219
    character()
220
  }
221

222
  # ammend knit_meta with paged table if df_print == "paged"
223
  if (df_print == "paged") {
224
    knit_meta <- append(
225
      knit_meta,
226
      list(rmarkdown::html_dependency_pagedtable())
227
    )
228
  }
229

230
  # see if we are going to resolve knit_meta now or later
231
  if (dependencies) {
232
    engineDependencies <- NULL
233
    includes <- pandoc_includes(
234
      input,
235
      format,
236
      output_file,
237
      ifelse(!is.null(libDir), libDir, files_dir),
238
      knit_meta,
239
      tempDir
240
    )
241
  } else {
242
    includes <- NULL
243
    engineDependencies = list(
244
      knitr = I(list(jsonlite::serializeJSON(knit_meta)))
245
    )
246
  }
247

248
  # include postprocessing if required
249
  if (!is.null(preserved)) {
250
    preserve <- split(unname(preserved), names(preserved))
251
  } else {
252
    preserve <- NA
253
  }
254
  postProcess <- !identical(preserve, NA) || isTRUE(format$render$`code-link`)
255

256
  # read and then delete the rendered output file
257
  markdown <- xfun::read_utf8(output_file)
258
  unlink(output_file)
259

260
  # results
261
  list(
262
    engine = "knitr",
263
    markdown = paste(markdown, collapse = "\n"),
264
    supporting = I(supporting),
265
    filters = I("rmarkdown/pagebreak.lua"),
266
    includes = includes,
267
    engineDependencies = engineDependencies,
268
    preserve = preserve,
269
    postProcess = postProcess
270
  )
271
}
272

273
pandoc_options <- function(format) {
274
  # note: pandoc_options args is used for various r-specific scenarios:
275
  #   - https://github.com/rstudio/rmarkdown/pull/1468
276
  #   - force an id-prefix for runtime: shiny
277
  # we don't provide them here b/c we manage interaction w/ pandoc not
278
  # rmarkdown::render. note though that we do pass a --to argument to
279
  # work around an issue w/ rmarkdown where at least 1 argument
280
  # must be passed or there is a runtime error
281
  rmarkdown::pandoc_options(
282
    to = format$pandoc$to,
283
    from = format$pandoc$from,
284
    args = c("--to", format$pandoc$to),
285
    keep_tex = isTRUE(format$render$`keep-tex`)
286
  )
287
}
288

289
# knitr options for format
290
knitr_options <- function(format, resourceDir, handledLanguages) {
291
  # may need some knit hooks
292
  knit_hooks <- list()
293

294
  # opt_knit for compatibility w/ rmarkdown::render
295
  to <- format$pandoc$to
296
  if (identical(to, "pdf")) {
297
    to <- "latex"
298
  }
299
  opts_knit <- list(
300
    quarto.version = 1,
301
    rmarkdown.pandoc.from = format$pandoc$from,
302
    rmarkdown.pandoc.to = to,
303
    rmarkdown.version = 3,
304
    rmarkdown.runtime = "static"
305
  )
306

307
  # opts_chunk
308
  opts_chunk <- list(
309
    # options derived from format
310
    fig.width = format$execute$`fig-width`,
311
    fig.height = format$execute$`fig-height`,
312
    fig.asp = format$execute$`fig-asp`,
313
    dev = format$execute$`fig-format`,
314
    dpi = format$execute$`fig-dpi`,
315
    eval = format$execute[["eval"]],
316
    error = format$execute[["error"]],
317
    echo = !isFALSE(format$execute[["echo"]]),
318
    fenced.echo = identical(format$execute[["echo"]], "fenced"),
319
    warning = isTRUE(format$execute[["warning"]]),
320
    message = isTRUE(format$execute[["warning"]]),
321
    include = isTRUE(format$execute[["include"]]),
322
    comment = NA
323
  )
324

325
  # forward output: false option to results, fig.show, warning, and message
326
  if (isFALSE(format$execute[["output"]])) {
327
    opts_chunk$results <- "hide"
328
    opts_chunk$fig.show <- "hide"
329
    opts_chunk$warning <- FALSE
330
    opts_chunk$message <- FALSE
331
  } else if (identical(format$execute[["output"]], "asis")) {
332
    opts_chunk$results <- "asis"
333
  }
334

335
  # add screenshot force if prefer-html specified
336
  if (is_html_prefered(format)) {
337
    opts_chunk$screenshot.force <- FALSE
338
  }
339

340
  # add fig.retina if requested
341
  if (opts_chunk$dev == "retina") {
342
    opts_chunk$dev <- "png"
343
    opts_chunk$fig.retina = 2
344
  }
345

346
  # set the dingbats option for the pdf device if required
347
  if (opts_chunk$dev == 'pdf') {
348
    opts_chunk$dev.args <- list(pdf = list(useDingbats = FALSE))
349
    if (has_crop_tools(FALSE)) {
350
      knit_hooks$crop <- function(before, options, envir) {
351
        if (isTRUE(options$crop)) {
352
          knitr::hook_pdfcrop(before, options, envir)
353
        }
354
      }
355
      opts_chunk$crop <- TRUE
356
    }
357
  }
358

359
  # instruct flextable to not use shadow dom until Deno Dom supports the
360
  # <template> tag (see https://github.com/davidgohel/flextable/issues/385)
361
  opts_chunk$ft.shadow <- FALSE
362

363
  # return options
364
  knitr <- list()
365
  if (is.list(format$metadata$knitr)) {
366
    knitr <- format$metadata$knitr
367
  }
368
  hooks <- knitr_hooks(format, resourceDir, handledLanguages)
369
  rmarkdown::knitr_options(
370
    opts_knit = rmarkdown:::merge_lists(opts_knit, knitr$opts_knit),
371
    opts_chunk = rmarkdown:::merge_lists(opts_chunk, knitr$opts_chunk),
372
    opts_hooks = hooks$opts,
373
    knit_hooks = rmarkdown:::merge_lists(knit_hooks, hooks$knit)
374
  )
375
}
376

377

378
knitr_options_with_cache <- function(input, format, opts) {
379
  # handle cache behavior
380
  cache <- format$execute$`cache`
381
  if (!is.null(cache)) {
382
    # remove the cache dir for refresh or false
383
    if (identical(cache, "refresh")) {
384
      cache_dir <- knitr_cache_dir(input, format)
385
      if (rmarkdown:::dir_exists(cache_dir)) {
386
        unlink(cache_dir, recursive = TRUE)
387
      }
388
      cache <- TRUE
389
    }
390

391
    # set the glocal cache option
392
    opts$opts_chunk$cache <- isTRUE(cache)
393

394
    # if cache is FALSE then force all the chunks to FALSE
395
    if (identical(cache, FALSE)) {
396
      opts$opts_hooks$cache <- function(options) {
397
        options$cache <- FALSE
398
        options
399
      }
400
    }
401
  }
402
  opts
403
}
404

405
knitr_cache_dir <- function(input, format) {
406
  pandoc_to <- format$pandoc$to
407
  base_pandoc_to <- gsub('[-+].*', '', pandoc_to)
408
  if (base_pandoc_to == 'html4') {
409
    base_pandoc_to <- 'html'
410
  }
411
  cache_dir <- rmarkdown:::knitr_cache_dir(input, base_pandoc_to)
412
  cache_dir <- gsub("/$", "", cache_dir)
413
  cache_dir
414
}
415

416
# produce pandoc format (e.g. includes from knit_meta)
417
pandoc_includes <- function(
418
  input,
419
  format,
420
  output,
421
  files_dir,
422
  knit_meta,
423
  tempDir
424
) {
425
  # get dependencies from render
426
  dependencies <- dependencies_from_render(input, files_dir, knit_meta, format)
427

428
  # embed shiny_prerendered dependencies
429
  if (!is.null(dependencies$shiny)) {
430
    rmarkdown:::shiny_prerendered_append_dependencies(
431
      output,
432
      dependencies$shiny,
433
      files_dir,
434
      dirname(input)
435
    )
436
  }
437

438
  # apply any required patches
439
  includes <- apply_patches(format, dependencies$includes)
440

441
  # write the includes to temp files
442
  create_pandoc_includes(includes, tempDir)
443
}
444

445
# get dependencies implied by the result of render (e.g. html dependencies)
446
dependencies_from_render <- function(input, files_dir, knit_meta, format) {
447
  # check for runtime
448
  front_matter <- rmarkdown::yaml_front_matter(input)
449
  runtime <- front_matter$runtime
450
  server <- front_matter[["server"]]
451
  if (is.null(runtime)) {
452
    if (is_shiny_prerendered(runtime, server)) {
453
      runtime <- "shinyrmd"
454
    } else {
455
      runtime <- "static"
456
    }
457
  }
458

459
  # dependencies to return
460
  dependencies <- list()
461

462
  # determine dependency resolver (special resolver for shiny_prerendered)
463
  resolver <- rmarkdown:::html_dependency_resolver
464
  if (is_shiny_prerendered(runtime, server)) {
465
    resolver <- function(deps) {
466
      dependencies$shiny <<- list(
467
        deps = deps,
468
        packages = rmarkdown:::get_loaded_packages()
469
      )
470
      list()
471
    }
472
  }
473

474
  # convert dependencies to in_header includes
475
  dependencies$includes <- list()
476
  if (is_pandoc_html_format(format) || is_html_prefered(format)) {
477
    # get extras (e.g. html dependencies)
478
    # only include these html extras if we're targeting a format that
479
    # supports html (widgets) like this or that prefers html (e.g. Hugo)
480
    extras <- rmarkdown:::html_extras_for_document(
481
      knit_meta,
482
      runtime,
483
      resolver,
484
      list() # format deps
485
    )
486

487
    # We explicitly will inject dependencies for bslib (bootstrap and supporting
488
    # js / css) so we block those dependencies from making their way into the
489
    # document
490
    filteredDependencies = c("bootstrap")
491
    if (is_dashboard_output(format)) {
492
      bslibDepNames <- c(
493
        "bootstrap",
494
        "bslib-webComponents-js",
495
        "bslib-tag-require",
496
        "bslib-card-js",
497
        "bslib-card-styles",
498
        "htmltools-fill",
499
        "bslib-value_box-styles",
500
        "bs3compat",
501
        "bslib-sidebar-js",
502
        "bslib-sidebar-styles",
503
        "bslib-page_fillable-styles",
504
        "bslib-page_navbar-styles",
505
        "bslib-component-js",
506
        "bslib-component-css"
507
      )
508
      append(filteredDependencies, bslibDepNames)
509
    }
510

511
    # filter out bootstrap
512
    extras$dependencies <- Filter(
513
      function(dependency) !(dependency$name %in% filteredDependencies),
514
      extras$dependencies
515
    )
516

517
    if (length(extras$dependencies) > 0) {
518
      deps <- html_dependencies_as_string(extras$dependencies, files_dir)
519
      dependencies$includes$in_header <- deps
520
    }
521

522
    # extract static ojs definitions for HTML only (not prefer-html)
523
    if (is_pandoc_html_format(format)) {
524
      ojs_defines <- rmarkdown:::flatten_dependencies(
525
        knit_meta,
526
        function(dep) inherits(dep, "ojs-define")
527
      )
528
      ojs_define_str <- knitr:::one_string(unlist(ojs_defines))
529
      if (ojs_define_str != "") {
530
        dependencies$includes$in_header <- knitr:::one_string(c(
531
          dependencies$includes$in_header,
532
          ojs_define_str
533
        ))
534
      }
535
    }
536
  } else if (
537
    is_pandoc_latex_output(format) &&
538
      rmarkdown:::has_latex_dependencies(knit_meta)
539
  ) {
540
    latex_dependencies <- rmarkdown:::flatten_latex_dependencies(knit_meta)
541
    dependencies$includes$in_header <- rmarkdown:::latex_dependencies_as_string(
542
      latex_dependencies
543
    )
544
  }
545

546
  # return dependencies
547
  dependencies
548
}
549

550
# return the html dependencies as an HTML string suitable for inclusion
551
# in the head of a document
552
html_dependencies_as_string <- function(dependencies, files_dir) {
553
  if (!rmarkdown:::dir_exists(files_dir)) {
554
    dir.create(files_dir, showWarnings = FALSE, recursive = TRUE)
555
  }
556
  dependencies <- lapply(
557
    dependencies,
558
    htmltools::copyDependencyToDir,
559
    files_dir
560
  )
561
  dependencies <- lapply(dependencies, function(dependency) {
562
    dir <- dependency$src$file
563
    if (!is.null(dir)) {
564
      dependency$src$file <- gsub(
565
        "\\\\",
566
        "/",
567
        paste(files_dir, basename(dir), sep = "/")
568
      )
569
    }
570
    dependency
571
  })
572
  return(htmltools::renderDependencies(
573
    dependencies,
574
    "file",
575
    encodeFunc = identity
576
  ))
577
}
578

579
is_shiny_prerendered <- function(runtime, server = NULL) {
580
  if (
581
    identical(runtime, "shinyrmd") || identical(runtime, "shiny_prerendered")
582
  ) {
583
    TRUE
584
  } else if (identical(server, "shiny")) {
585
    TRUE
586
  } else if (is.list(server) && identical(server[["type"]], "shiny")) {
587
    TRUE
588
  } else {
589
    FALSE
590
  }
591
}
592

593
create_pandoc_includes <- function(includes, tempDir) {
594
  pandoc <- list()
595
  write_includes <- function(from, to) {
596
    content <- includes[[from]]
597
    if (!is.null(content)) {
598
      path <- tempfile(tmpdir = tempDir)
599
      xfun::write_utf8(content, path)
600
      pandoc[[to]] <<- I(path)
601
    }
602
  }
603
  write_includes("in_header", "include-in-header")
604
  write_includes("before_body", "include-before-body")
605
  write_includes("after_body", "include-after-body")
606

607
  pandoc
608
}
609

610
# preserve chunks marked w/ e.g. html_preserve
611
extract_preserve_chunks <- function(output_file, format) {
612
  if (is_pandoc_html_format(format)) {
613
    extract <- htmltools::extractPreserveChunks
614
  } else if (format$pandoc$to == "rtf") {
615
    extract <- knitr::extract_raw_output
616
  } else {
617
    extract <- NULL
618
  }
619
  if (!is.null(extract)) {
620
    rmarkdown:::extract_preserve_chunks(output_file, extract)
621
  } else {
622
    NULL
623
  }
624
}
625

626
# inline knitr::pandoc_to from knitr 1.41
627
# before that, the all format (w/ pandoc extension) was checked
628
is_pandoc_to_format <- function(format, check_fmts) {
629
  to <- gsub("[-+].*", "", format$pandoc$to)
630
  to %in% check_fmts
631
}
632

633
# check is pandoc$to is among html formats (html, slides, epub)
634
is_pandoc_html_format <- function(format) {
635
  knitr::is_html_output(
636
    format$pandoc$to,
637
    c("markdown", "epub", "gfm", "commonmark", "commonmark_x", "markua")
638
  )
639
}
640

641
# check if pandoc$to is latex output
642
is_pandoc_latex_output <- function(format) {
643
  is_pandoc_to_format(format, c("latex", "beamer", "pdf"))
644
}
645

646
is_pandoc_ipynb_output <- function(format) {
647
  is_pandoc_to_format(format, c("ipynb"))
648
}
649

650
# check if pandoc$to is among markdown outputs
651
is_pandoc_markdown_output <- function(format) {
652
  markdown_formats <- c(
653
    "markdown",
654
    "markdown_github",
655
    "markdown_mmd",
656
    "markdown_phpextra",
657
    "markdown_strict",
658
    "gfm",
659
    "commonmark",
660
    "commonmark_x",
661
    "markua"
662
  )
663
  is_pandoc_to_format(format, markdown_formats)
664
}
665

666
# should be equivalent of TS function:
667
# isHtmlCompatible() in src/config/format.ts
668
is_html_prefered <- function(format) {
669
  # `prefer-html: true` can be set in markdown format that supports HTML outputs
670
  (is_pandoc_markdown_output(format) &&
671
    isTRUE(format$render$`prefer-html`)) ||
672
    # this could happen when using embed shortcode which convert to ipynb output format.
673
    is_pandoc_ipynb_output(format)
674
}
675

676
is_dashboard_output <- function(format) {
677
  identical(format$identifier[["base-format"]], "dashboard")
678
}
679

680
# apply patches to output as required
681
apply_patches <- function(format, includes) {
682
  if (format$pandoc$to %in% c("slidy", "revealjs")) {
683
    includes <- apply_slides_patch(includes)
684
  }
685
  includes
686
}
687

688
# patch to ensure that htmlwidgets size correctly when slide changes
689
apply_slides_patch <- function(includes) {
690
  slides_js <- '
691
<script>
692
  // htmlwidgets need to know to resize themselves when slides are shown/hidden.
693
  // Fire the "slideenter" event (handled by htmlwidgets.js) when the current
694
  // slide changes (different for each slide format).
695
  (function () {
696
    // dispatch for htmlwidgets
697
    function fireSlideEnter() {
698
      const event = window.document.createEvent("Event");
699
      event.initEvent("slideenter", true, true);
700
      window.document.dispatchEvent(event);
701
    }
702

703
    function fireSlideChanged(previousSlide, currentSlide) {
704
      fireSlideEnter();
705

706
      // dispatch for shiny
707
      if (window.jQuery) {
708
        if (previousSlide) {
709
          window.jQuery(previousSlide).trigger("hidden");
710
        }
711
        if (currentSlide) {
712
          window.jQuery(currentSlide).trigger("shown");
713
        }
714
      }
715
    }
716

717
    // hookup for slidy
718
    if (window.w3c_slidy) {
719
      window.w3c_slidy.add_observer(function (slide_num) {
720
        // slide_num starts at position 1
721
        fireSlideChanged(null, w3c_slidy.slides[slide_num - 1]);
722
      });
723
    }
724

725
  })();
726
</script>
727
'
728
  includes$after_body <- paste0(includes$after_body, slides_js)
729
  includes
730
}
731

732

733
apply_responsive_patch <- function(format) {
734
  if (isTRUE(format$metadata[["fig-responsive"]])) {
735
    # tweak sizing for htmlwidget figures (use 100% to be responsive)
736
    if (requireNamespace("htmlwidgets", quietly = TRUE)) {
737
      htmlwidgets_resolveSizing <- htmlwidgets:::resolveSizing
738
      resolveSizing <- function(x, sp, standalone, knitrOptions = NULL) {
739
        # default sizing resolution
740
        sizing <- htmlwidgets_resolveSizing(x, sp, standalone, knitrOptions)
741

742
        # if this is a knitr figure then set width to 100% and height
743
        # to an appropriately proportioned value based on the assumption
744
        # that the display width will be ~650px
745
        if (
746
          isTRUE(sp$knitr$figure) &&
747
            is.numeric(sizing$height) &&
748
            is.numeric(sizing$width)
749
        ) {
750
          sizing$height <- paste0(
751
            as.integer(sizing$height / sizing$width * 650),
752
            "px"
753
          )
754
          sizing$width <- "100%"
755
        }
756

757
        # return sizing
758
        sizing
759
      }
760

761
      assignInNamespace("resolveSizing", resolveSizing, ns = "htmlwidgets")
762
    }
763
  }
764
}
765

766
# utility functions
767
`%||%` <- function(x, y) {
768
  if (is.null(x)) y else x
769
}
770

771
# from rmarkdown
772
# https://github.com/rstudio/rmarkdown/blob/0951a2fea7e317f77d27969c25f3194ead38805e/R/util.R#L318-L331
773
has_crop_tools <- function(warn = TRUE) {
774
  if (packageVersion("knitr") >= "1.44") {
775
    return(knitr:::has_crop_tools(warn))
776
  }
777
  # for older version we do inline the function from rmarkdown
778
  # but it does not have the knitr improvment for windows
779
  # https://github.com/yihui/knitr/issues/2246
780
  tools <- c(
781
    pdfcrop = unname(rmarkdown:::find_program("pdfcrop")),
782
    ghostscript = unname(tools::find_gs_cmd())
783
  )
784
  missing <- tools[tools == ""]
785
  if (length(missing) == 0) {
786
    return(TRUE)
787
  }
788
  x <- paste0(names(missing), collapse = ", ")
789
  if (warn) {
790
    warning(
791
      sprintf("\nTool(s) not installed or not in PATH: %s", x),
792
      "\n-> As a result, figure cropping will be disabled."
793
    )
794
  }
795
  FALSE
796
}
797

798