Allow to add specific shiny-prerendered parts in HTML template (#2064)

A new pandoc variable `shiny-prerendered` is set when rendering a shiny prerendered document. This allow to add specific content for this type of rendered document in an HTML template. It is used in all HTML templates to add a special comment `` required by htmltools / shiny to reinsert the HTML dependencies. Following #1942, it was put by default at the end of the error which caused issue in leanr, e.g rstudio/learnr#499 This will fix #2060 following change in 49c0c2b.
rstudio · Mar 4, 2021 · 61db7a9 · 61db7a9
1 parent c0b8584
commit 61db7a9
Show file tree

Hide file tree

Showing 11 changed files with 105 additions and 29 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: rmarkdown
 Type: Package
 Title: Dynamic Documents for R
-Version: 2.7.2
+Version: 2.7.3
 Authors@R: c(
   person("JJ", "Allaire", role = "aut", email = "jj@rstudio.com"),
   person("Yihui", "Xie", role = c("aut", "cre"), email = "xie@yihui.name", comment = c(ORCID = "0000-0003-0645-5666")),

diff --git a/NEWS.md b/NEWS.md
@@ -3,7 +3,7 @@ rmarkdown 2.8
 
 - Provided a `runtime: shiny` fix for output formats that pass a modified `bslib::bs_theme()` object to `html_document_base()`'s `theme` (thanks, @cpsievert, #2049).
 
-- Rendering using `runtime: shiny_prerendered` will now produce valid HTML by not inserting anymore the full document as body in the resulting shiny apps. (thanks, @dakep, #1942).
+- Rendering using `runtime: shiny_prerendered` or `runtime: shinyrmd` will now produce valid HTML by not inserting anymore the full document as body in the resulting shiny apps (thanks, @dakep, #1912). Header content usually containing html dependencies will be inserted in the HTML document at the end of the head before `</head>`, unless the rendered HTML contains `<!-- HEAD_CONTENT -->` special comment (see `htmltools::renderDocument()`). A new Pandoc variable is set in for shiny prerendered document to allow conditional insertion of such content in the the HTML template using `$if(shiny-prerendered)$`. This has been done in all HTML template in this package. Users of custom template should make this change to provide support for this runtime. See **rmarkdown** default template (`default.html`) for an example (#2064).
 
 rmarkdown 2.7
 ================================================================================

diff --git a/R/render.R b/R/render.R
@@ -844,6 +844,10 @@ render <- function(input,
                                             shiny_prerendered_dependencies,
                                             files_dir,
                                             output_dir)
+      # indicate to Pandoc we are in a shiny prerendered document to activate
+      # specific parts in the template.
+      output_format$pandoc$args <- c(output_format$pandoc$args,
+                                     pandoc_variable_arg("shiny-prerendered"))
     }
 
     perf_timer_stop("pre-processor")

diff --git a/R/shiny_prerendered.R b/R/shiny_prerendered.R
@@ -160,13 +160,20 @@ shiny_prerendered_html <- function(input_rmd, render_args) {
   # return html w/ dependencies
   html_with_deps <- shinyHTML_with_deps(rendered_html, dependencies)
 
-  # add placeholder for additional dependencies at the end of the <head> element
-  # using a template expansion expected by shiny (usually done in shiny:::renderPage)
-  sub('</head>',
-      paste0('\n', htmltools::htmlTemplate(text_ = "{{ headContent() }}"), '\n</head>'),
+  # The html template used to render the UI should contain the placeholder
+  # expected by shiny in `shiny:::renderPage()` which uses
+  # `htmltools::renderDocument`.
+  # If it is not present in the template, we add this placeholder at the end of
+  # the <head> element
+  if (!any(grepl(headContent <- "<!-- HEAD_CONTENT -->", html_with_deps, fixed = TRUE))) {
+    html_with_deps <- sub(
+      '</head>',
+      paste0('\n', headContent, '\n</head>'),
       html_with_deps,
       fixed = TRUE,
       useBytes = TRUE)
+  }
+  html_with_deps
 }
 
 shiny_prerendered_ui <- function(html, deps) {

diff --git a/inst/rmd/h/default.html b/inst/rmd/h/default.html
@@ -26,6 +26,9 @@
 $for(header-includes)$
 $header-includes$
 $endfor$
+$if(shiny-prerendered)$
+<!-- HEAD_CONTENT -->
+$endif$
 
 <style type="text/css">
   code{white-space: pre-wrap;}

diff --git a/inst/rmd/ioslides/default.html b/inst/rmd/ioslides/default.html
@@ -59,6 +59,9 @@
 $for(header-includes)$
   $header-includes$
 $endfor$
+$if(shiny-prerendered)$
+  <!-- HEAD_CONTENT -->
+$endif$
 
   <style type="text/css">
 

diff --git a/inst/rmd/slidy/default.html b/inst/rmd/slidy/default.html
@@ -44,6 +44,9 @@
 $for(header-includes)$
   $header-includes$
 $endfor$
+$if(shiny-prerendered)$
+  <!-- HEAD_CONTENT -->
+$endif$
 $for(css)$
   <link rel="stylesheet" type="text/css" media="screen, projection, print"
    href="$css$" />

diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R
@@ -4,14 +4,34 @@ local_rmd_file <- function(..., .env = parent.frame()) {
   path
 }
 
-skip_if_not_pandoc <- function(ver) {
+.render_and_read <- function(input, ...) {
+  skip_if_not_pandoc()
+  output_file <- withr::local_tempfile()
+  res <- rmarkdown::render(input, output_file = output_file, quiet = TRUE, ...)
+  xfun::read_utf8(res)
+}
+
+# Use to test pandoc availability or version lower than
+skip_if_not_pandoc <- function(ver = NULL) {
   if (!pandoc_available(ver)) {
-    skip(sprintf("Version of Pandoc is lower than %s.", ver))
+    msg <- if (is.null(ver)) {
+      "Pandoc is not available"
+    } else {
+      sprintf("Version of Pandoc is lower than %s.", ver)
+    }
+    skip(msg)
   }
 }
 
-skip_if_pandoc <- function(ver) {
+# Use to test version greater than
+skip_if_pandoc <- function(ver = NULL) {
   if (pandoc_available(ver)) {
-    skip(sprintf("Version of Pandoc is greater than %s.", ver))
+    msg <- if (is.null(ver)) {
+      "Pandoc is available"
+    } else {
+      sprintf("Version of Pandoc is greater than %s.", ver)
+    }
+    skip(msg)
   }
 }
+
diff --git a/tests/testthat/test-lua-filters.R b/tests/testthat/test-lua-filters.R
@@ -1,8 +1,6 @@
 .generate_md_and_convert <- function(content, output_format) {
   input_file <- local_rmd_file(c("---\ntitle: Test\n---\n", content))
-  output_file <- withr::local_tempfile()
-  res <- rmarkdown::render(input_file, output_format = output_format, output_file = output_file, quiet = TRUE)
-  xfun::read_utf8(res)
+  .render_and_read(input_file, output_format = output_format)
 }
 
 # Lua filters exists only since pandoc 2.0

diff --git a/tests/testthat/test-shiny.R b/tests/testthat/test-shiny.R
@@ -1,6 +1,7 @@
+# TODO: added for new tests - to remove when switching the package to edition 3
+local_edition(3)
+
 test_that("file.path.ci returns correctly no matter the case", {
-  # TODO: added for new tests - to remove when switching the package to edition 3
-  local_edition(3)
   tmp_dir <- withr::local_tempdir()
   expect_equal(file.path.ci(tmp_dir, "global.R"), file.path(tmp_dir, "global.R"))
 
@@ -26,17 +27,3 @@ test_that("set_current_theme() informs shiny::getCurrentTheme()", {
   set_current_theme(NULL)
   expect_null(shiny::getCurrentTheme())
 })
-
-test_that("html_prerendered is a full document template to use as UI for shiny", {
-  tmp_rmd <- local_rmd_file(c("---", "title: shiny", "runtime: shiny_prerendered", "---", "", "```{r}", "1+1", "```"))
-  html <- shiny_prerendered_html(tmp_rmd, list(quiet = TRUE))
-  expect_match(html, "<!-- HEAD_CONTENT -->")
-})
-
-test_that("html can be annotated as being a full document with deps attached", {
-  html <- HTML("dummy")
-  deps <- list(htmltools::htmlDependency("a", "1.1", c(href = "/")))
-  ui <- shiny_prerendered_ui(html, deps)
-  expect_s3_class(ui, "html_document")
-  expect_equal(htmltools::htmlDependencies(ui), deps)
-})
diff --git a/tests/testthat/test-shiny_prerendered.R b/tests/testthat/test-shiny_prerendered.R
@@ -0,0 +1,51 @@
+# TODO: added for new tests - to remove when switching the package to edition 3
+local_edition(3)
+
+test_that("HTML template contains special comment when in shiny prerendered", {
+  skip_if_not_pandoc()
+  special_comment <- "<!-- HEAD_CONTENT -->"
+  content <- c("---", "title: shiny", "runtime: shiny_prerendered", "---", "", "```{r}", "1+1", "```")
+  tmp_rmd <- local_rmd_file(content)
+  html <- .render_and_read(tmp_rmd, output_format = "html_document")
+  expect_match(one_string(html), special_comment, fixed = TRUE,
+               label = "hmlt_document template")
+  html <- .render_and_read(tmp_rmd, output_format = "ioslides_presentation")
+  expect_match(one_string(html), special_comment, fixed = TRUE,
+               label = "ioslides_presentation template")
+  html <- .render_and_read(tmp_rmd, output_format = "slidy_presentation")
+  expect_match(one_string(html), special_comment, fixed = TRUE,
+               label = "slidy_presentation template")
+  # no runtime shiny prerendered
+  content <- content[-which(grepl("^runtime", content))]
+  tmp_rmd <- local_rmd_file(content)
+  html <- .render_and_read(tmp_rmd, output_format = "html_document")
+  expect_false(any(grepl(special_comment, html)))
+})
+
+test_that("Special HEAD comment is added if none in rendered HTML when in shiny prerendered", {
+  skip_if_not_pandoc()
+  special_comment <- "<!-- HEAD_CONTENT -->"
+  tmp_rmd <- local_rmd_file(c("---", "title: shiny", "runtime: shiny_prerendered", "---", "", "```{r}", "1+1", "```"))
+  html <- shiny_prerendered_html(tmp_rmd, list(quiet = TRUE))
+  expect_length(which(special_comment == xfun::split_lines(html)), 1L)
+  tmp_rmd <- local_rmd_file(c("---", "title: shiny", "runtime: shiny_prerendered", "---", "", "```{r}", "1+1", "```"))
+  opts <- list(template = NULL, mathjax = NULL)
+  html <- shiny_prerendered_html(tmp_rmd, list(output_options = opts, quiet = TRUE))
+  expect_length(which(special_comment == xfun::split_lines(html)), 1L)
+})
+
+test_that("html can be annotated as being a full document with deps attached", {
+  html <- HTML("dummy")
+  deps <- list(htmltools::htmlDependency("a", "1.1", c(href = "/")))
+  ui <- shiny_prerendered_ui(html, deps)
+  expect_s3_class(ui, "html_document")
+  expect_equal(htmltools::htmlDependencies(ui), deps)
+})
+
+# As we don't use directly `{{ headContent() }}`, this test should help detect
+# if htmltools has change this special token in the future. In our CI tests, but also
+# in reverse dependency test
+test_that("htmtools still use the special token rmarkdown uses in its template", {
+  htmltools_headcontent <- as.character(htmltools::htmlTemplate(text_ = "{{ headContent() }}"))
+  expect_match(htmltools_headcontent, "<!-- HEAD_CONTENT -->", fixed = TRUE)
+})