-
-
Notifications
You must be signed in to change notification settings - Fork 979
/
shiny_prerendered.R
779 lines (656 loc) · 26.5 KB
/
shiny_prerendered.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
# Create a shiny app object from an Rmd w/ runtime: shiny_prerendered
shiny_prerendered_app <- function(input_rmd, render_args) {
# get rendered html and capture dependencies
html <- shiny_prerendered_html(input_rmd, render_args)
deps <- htmltools::htmlDependencies(html)
# create the server environment
server_envir = new.env(parent = globalenv())
# read the html
html_lines <- strsplit(html, "\n", fixed = TRUE)[[1]]
# read and remove server-extras (used for both embedded and server.R use cases)
server_extras <- shiny_prerendered_extract_context(html_lines, "server-extras")
if (length(server_extras) > 0) {
html_lines <- shiny_prerendered_remove_contexts(html_lines, "server-extras")
}
# extract the server-start context
server_start_context <- shiny_prerendered_extract_context(html_lines,
"server-start")
# extract the code used for server startup (this encompasses both the
# context="server-start" code and the context="data" code). This can be
# retrieved later via the shiny_prerendered_server_start_code function. The
# purpose of this is for appliations which want to run user in other
# processes while still duplicating the setup context (e.g. tutorials).
server_start_code <- one_string(c(server_start_context,
shiny_prerendered_extract_context(html_lines, "data")))
onStart <- function() {
# save the server_start_code
assign(".shiny_prerendered_server_start_code", server_start_code, envir = server_envir)
# execute the startup code (server_start_context + context="data" loading)
eval(xfun::parse_only(server_start_context), envir = server_envir)
shiny_prerendered_data_load(input_rmd, server_envir)
# lock the environment to prevent inadvertent assignments
lockEnvironment(server_envir)
}
# extract the server context
.server_context <- c(server_extras,
shiny_prerendered_extract_context(html_lines, "server"))
server_envir$.server_context <- .server_context
server <- function(input, output, session) {
eval(xfun::parse_only(.server_context))
}
environment(server) <- new.env(parent = server_envir)
# remove server code before serving
server_contexts <- c("server-start", "data", "server")
redacted_html_lines <- shiny_prerendered_remove_contexts(html_lines, server_contexts)
# if there were server contexts then update html w/ removed contexts
if (length(redacted_html_lines) < length(html_lines)) {
html <- HTML(one_string(redacted_html_lines))
}
# if there were not server contexts then this may be a ui-only rmd,
# check for a server.R
else if (file.exists(file.path(dirname(input_rmd), "server.R"))) {
# source global.R onStart
onStart <- function() {
global_r <- file.path.ci(dirname(input_rmd), "global.R")
if (file.exists(global_r)) {
source(global_r, local = FALSE)
}
}
# server function from server.R
server_r <- file.path(dirname(input_rmd), "server.R")
server_r_env = new.env(parent = globalenv())
if (length(server_extras) > 0) {
eval(xfun::parse_only(server_extras), envir = server_r_env)
}
server <- source(server_r, local = server_r_env)$value
} else {
stop("No server contexts or server.R available for ", input_rmd)
}
html_ui <- shiny_prerendered_ui(html, deps)
# create shiny app
shiny::shinyApp(
ui = function(req) html_ui,
server = server,
onStart = onStart,
uiPattern = "^/$|^(/.*\\.[Rrq][Mm][Dd])$"
)
}
# Generate the html for a runtime: shiny_prerendered Rmd (attempts to use
# an existing rendering of the html if it's still valid)
shiny_prerendered_html <- function(input_rmd, render_args) {
# determine the path to the rendered_html
output_file <- render_args$output_file
if (is.null(output_file))
output_file <- file_with_ext(basename(input_rmd), "html")
output_dir <- render_args$output_dir
if (is.null(output_dir))
output_dir <- dirname(input_rmd)
rendered_html <- file.path(output_dir, output_file)
# determine whether we need to render the Rmd in advance
prerender_option <- tolower(Sys.getenv("RMARKDOWN_RUN_PRERENDER", "1"))
prerender <- shiny_prerendered_prerender(
input_rmd,
rendered_html,
output_dir,
prerender_option
)
# prerender if necessary
if (prerender) {
args <- merge_lists(list(input = input_rmd), render_args)
# force prerender to execute in separate environment to ensure that
# running w/ prerender step is equivalent to running the prerendered app
args$envir <- new.env(parent = args$envir %||% globalenv())
# execute the render
rendered_html <- do.call(render, args)
}
if (!file.exists(rendered_html)) {
stop("Prerendered HTML file not found at ", rendered_html)
}
# normalize paths
rendered_html <- normalize_path(rendered_html)
output_dir <- dirname(rendered_html)
add_resource_path <- function(path, prefix = basename(path), temporary = TRUE) {
if (dir_exists(path)) {
shiny::addResourcePath(prefix, path)
# Remove resource paths so they don't clash with 'down-stream' resources
removeResourcePath <- if (temporary)
try(getFromNamespace("removeResourcePath", "shiny"), silent = TRUE)
if (is.function(removeResourcePath)) {
shiny::onStop(function() { removeResourcePath(prefix) }, NULL)
}
}
}
files_dir <- knitr_files_dir(rendered_html)
add_resource_path(files_dir)
add_resource_path(file.path(output_dir,"css"))
add_resource_path(file.path(output_dir,"js"))
add_resource_path(file.path(output_dir,"images"))
add_resource_path(file.path(output_dir,"www"))
# extract dependencies from html
html_lines <- read_utf8(rendered_html)
dependencies <- shiny_prerendered_extract_context_serialized(html_lines, "dependencies")
# resolve package paths (this will happen automatically for the
# development version of htmltools but this isn't on CRAN yet)
dependencies <- lapply(dependencies, function(dependency) {
if (!is.null(dependency$package) && !is.null(dependency$src$file)) {
dependency$src$file <- system.file(dependency$src$file,
package = dependency$package)
dependency$package <- NULL
}
dependency
})
# attach rstudio rsiframe script if we are in rstudio
if (nzchar(Sys.getenv("RSTUDIO")))
dependencies <- append(dependencies, list(html_dependency_rsiframe()))
# return html w/ dependencies
html_with_deps <- shinyHTML_with_deps(rendered_html, dependencies)
# The html template used to render the UI should contain the placeholder
# expected by shiny in `shiny:::renderPage()` which uses `htmltools::renderDocument`.
# This should be included during render() as a header include file. As a safety measure,
# if it is not present in the template, we add this placeholder at the end of
# the <head> element. This should not happen really.
# Context: https://github.com/rstudio/rmarkdown/pull/2249
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)
Encoding(html_with_deps) <- "UTF-8"
}
html_with_deps
}
shiny_prerendered_ui <- function(html, deps) {
# prerendered html is a full document that should not be expanded in shiny::renderPage()
# so make shiny aware of that with the attributes 'html_document' to mimic the result of
# htmltools::htmlTemplate(document_ = TRUE).
# https://github.com/rstudio/rmarkdown/issues/1912
html_doc <- htmltools::tagList(html)
class(html_doc) <- c("html_document", class(html_doc))
# attach dependencies to final html
htmltools::attachDependencies(html_doc, deps)
}
shiny_prerendered_prerender <- function(
input_rmd,
rendered_html,
output_dir,
prerender_option
) {
if (file.access(output_dir, 2) != 0) {
if (!file.exists(rendered_html))
stop("Unable to write prerendered HTML file to ", rendered_html)
return(FALSE)
}
if (identical(prerender_option, "0")) {
return(FALSE)
}
if (!identical(prerender_option, "1")) {
stop("Invalid value '", prerender_option, "' for RMARKDOWN_RUN_PRERENDER")
}
# determine the last modified time of the output file
if (file.exists(rendered_html)) {
output_last_modified <- as.integer(file.info(rendered_html)$mtime)
} else {
output_last_modified <- 0L
}
# short circuit for Rmd modified. if it hasn't been modified since the
# html was generated look at external resources
input_last_modified <- as.integer(file.info(input_rmd)$mtime)
if (input_last_modified > output_last_modified) {
return(TRUE)
}
# find external resources referenced by the file
external_resources <- find_external_resources(input_rmd)
# get paths to external resources
input_files <- c(input_rmd, file.path(output_dir, external_resources$path))
# what's the maximum last_modified time of an input file
input_last_modified <- max(as.integer(file.info(input_files)$mtime), na.rm = TRUE)
# render if an input file was modified after the output file
if (input_last_modified > output_last_modified) {
return(TRUE)
}
html_lines <- read_utf8(rendered_html)
# check that all html dependencies exist
dependencies <- tryCatch(
shiny_prerendered_extract_context_serialized(html_lines, "dependencies"),
error = function(...) NULL
)
if (is.null(dependencies)) {
# Pre-render needed: failed to parse deps from pre-rendered HTML
return(TRUE)
}
pkgsSeen <- list()
for (dep in dependencies) {
if (is.null(dep$package)) {
src_file <- dep$src$file
if (!is.null(src_file)) {
if (!file.exists(src_file)) {
# might create a missing file compile-time error,
# but that's better than a missing file prerendered error
return(TRUE)
}
}
# if there is a dep$src$href but no dep$package,
# then we can't determine where the file came from.
# Ignore checking for the href files for now, as pkg versions are checked below
} else {
depPkg <- dep$package
depVer <- dep$pkgVersion
if (is.null(pkgsSeen[[depPkg]])) {
# has not seen pkg
# depVer could be NULL, producing a logical(0)
# means old prerender version, render again
if (!isTRUE(get_package_version_string(depPkg) == depVer)) {
# was not rendered with the same R package. must render again
return(TRUE)
}
pkgsSeen[[depPkg]] <- depVer
}
}
}
# all html dependencies are accounted for
# check for execution package version differences
execution_info <- tryCatch(
shiny_prerendered_extract_context_serialized(html_lines, "execution_dependencies"),
error = function(...) NULL
)
if (is.null(execution_info)) {
# Pre-render needed: failed to parse execution deps from pre-rendered HTML
return(TRUE)
}
execution_pkg_names <- execution_info$packages$packages
execution_pkg_versions <- execution_info$packages$version
for (i in seq_along(execution_pkg_names)) {
if (!identical(
get_package_version_string(execution_pkg_names[i]),
execution_pkg_versions[i]
)) {
return(TRUE)
}
}
# all execution packages match
return(FALSE)
}
# Write the dependencies for a shiny_prerendered document.
shiny_prerendered_append_dependencies <- function(input, # always UTF-8
shiny_prerendered_dependencies,
files_dir,
output_dir) {
# transform dependencies (if we aren't in debug mode)
dependencies <- lapply(shiny_prerendered_dependencies$deps, function(dependency) {
# no transformation in dev mode (so browser dev tools can map directly
# to the locations of CSS and JS files in their pkg src directory)
if (nzchar(Sys.getenv("RMARKDOWN_SHINY_PRERENDERED_DEVMODE")))
return(dependency)
# see if we can convert absolute paths into package-aliased ones
if (is.null(dependency$package) && is.character(dependency$src$file)) {
# check for a package directory parent
package_dir <- proj_root(dependency$src$file)
# if we have one then populate the package field and make the
# src$file relative to the package
if (!is.null(package_dir)) {
package_desc <- read.dcf(file.path(package_dir, "DESCRIPTION"),
all = TRUE)
dependency$package <- package_desc$Package
# named to something that doesn't start with 'package' to deter lazy name matching
dependency$pkgVersion <- package_desc$Version
dependency$src$file <- normalized_relative_to(package_dir,
dependency$src$file)
}
}
# if we couldn't resolve the src to a package then copy the files
if (is.null(dependency$package) && !is.null(dependency$src$file)) {
dependency <- copyDependencyToDir(dependency, files_dir)
dependency <- makeDependencyRelative(dependency, output_dir)
dependency$src = list(href = unname(dependency$src))
}
if (!is.null(dependency$package)) {
dependency$pkgVersion <- get_package_version_string(dependency$package)
}
# return dependency
dependency
})
# remove NULLs (excluded dependencies)
dependencies <- dependencies[!sapply(dependencies, is.null)]
# append them to the file (guaranteed to be UTF-8)
con <- file(input, open = "at", encoding = "UTF-8")
on.exit(close(con), add = TRUE)
# Add newline before adding any raw html dependency script
# https://github.com/rstudio/rmarkdown/issues/2336
writeLines("", con = con)
# write deps to connection
dependencies_json <- jsonlite::serializeJSON(dependencies, pretty = FALSE)
shiny_prerendered_append_context(con, "dependencies", dependencies_json)
# write r major version and execution package dependencies
execution_json <- jsonlite::serializeJSON(
# visibly display what is being stored
shiny_prerendered_dependencies["packages"],
pretty = FALSE
)
shiny_prerendered_append_context(con, "execution_dependencies", execution_json)
}
shiny_prerendered_extract_context_serialized <- function(html_lines, context = "dependencies") {
json_str <- shiny_prerendered_extract_context(html_lines, context)
json_str <- unique(json_str)
if (length(json_str) > 1) {
warning("Multiple ", context, " contexts found in prerendered HTML, using last.")
json_str <- json_str[length(json_str)]
}
jsonlite::unserializeJSON(json_str)
}
#' Clean prerendered content for the specified Rmd input file
#'
#' Remove the associated html file and supporting _files directory
#' for a shiny_prerendered documet.
#'
#' @param input Rmd input file to clean content for
#'
#' @export
shiny_prerendered_clean <- function(input) {
# html file
html_file <- file_with_ext(input, "html")
if (file.exists(html_file))
file.remove(html_file)
# cache dir
cache_dir <- knitr_root_cache_dir(input)
if (dir_exists(cache_dir))
unlink(cache_dir, recursive = TRUE)
# files dir
files_dir <- knitr_files_dir(input)
if (dir_exists(files_dir))
unlink(files_dir, recursive = TRUE)
# data dir
data_dir <- shiny_prerendered_data_dir(input)
if (dir_exists(data_dir))
unlink(data_dir, recursive = TRUE)
}
#' Add code to a shiny_prerendered context
#'
#' Programmatic equivalent to including a code chunk with a
#' context in a runtime: shiny_prerendered document.
#'
#' @param context Context name (e.g. "server", "server-start")
#' @param code Character vector with code
#' @param singleton Collapse multiple identical versions of this
#' chunk into a single chunk.
#'
#' @export
shiny_prerendered_chunk <- function(context, code, singleton = FALSE) {
# verify we are in runtime: shiny_prerendered
if (!is_shiny_prerendered(knitr::opts_knit$get("rmarkdown.runtime")))
stop2("The shiny_prerendered_chunk function can only be called from ",
"within a shiny server compatible document"
)
# add the prerendered chunk to knit_meta
knitr::knit_meta_add(list(
structure(class = "shiny_prerendered", list(
name = context,
code = code,
singleton = singleton
))
))
# return NULL invisibly
invisible(NULL)
}
#' Get the server startup code for a shiny_prerendered server instance
#'
#' @param server_envir Shiny server environment to get code for
#'
#' @keywords internal
#' @export
shiny_prerendered_server_start_code <- function(server_envir) {
if (exists(".shiny_prerendered_server_start_code", envir = server_envir))
get(".shiny_prerendered_server_start_code", envir = server_envir)
else
""
}
# Record which context="data" chunks are actually executed during
# the current render as well as the file names they are saved with.
# We'll use this later to determine which .RData files in the _data
# directory should actually be loaded (as some could be from chunks
# that used to be cached / were cached under different names)
shiny_prerendered_option_hook <- function(input) {
function(options) {
# convert chunk labels to contexts as necessary
if (options$label %in% c("setup", "data", "server_start", "server"))
options$context <- options$label
if (identical(options$context, "data")) {
data_file <- shiny_prerendered_data_file_name(options$label,
options$cache > 0)
data_dir <- shiny_prerendered_data_dir(input, create = TRUE)
index_file <- shiny_prerendered_data_chunks_index(data_dir)
conn <- file(index_file, open = "ab", encoding = "UTF-8")
on.exit(close(conn), add = TRUE)
write(data_file, file = conn, append = TRUE)
}
if (identical(options$context, "server")) {
# if empty server context, set a default server function
if (all(xfun::is_blank(options$code))) {
options$code <- "# empty server context"
}
}
options
}
}
# Evaluate hook to capture chunks with e.g. context="server" and
# append their code to the appropriate shiny_prerendered_context
shiny_prerendered_evaluate_hook <- function(input) {
function(code, envir, ...) {
# get the context (default to "render")
context <- knitr::opts_current$get("context")
if (is.null(context))
context <- "render"
# "setup" is an alias for c("render", "server-start")
if ("setup" %in% context) {
context <- c(context[!context == "setup"], "render", "server-start")
context <- unique(context)
}
# if there are server-side contexts then emit knit_meta for them
for (name in context) {
if (!name %in% c("render"))
shiny_prerendered_chunk(name, code)
}
# capture and serialize data for context = "data"
if ("data" %in% context) {
# determine whether caching is active
label <- knitr::opts_current$get("label")
cache_option <- knitr::opts_current$get("cache")
cache <- !is.null(cache_option) && cache_option > 0
# evaluate the chunk in a new environment parented by the default envir
data_env <- new.env(parent = envir)
result <- evaluate::evaluate(code, data_env, ...)
# save all of the created objects then move them back into the parent
data_dir <- shiny_prerendered_data_dir(input, create = TRUE)
# use a special path prefix for cached chunks so we know not
# to remove them at the beginning of render
rdata_file <- file.path(data_dir,
shiny_prerendered_data_file_name(label, cache))
save(list = ls(data_env),
file = rdata_file,
envir = data_env,
compress = FALSE)
for (name in ls(data_env)) {
assign(name, get(name, envir = data_env), envir = envir)
remove(list = c(name), envir = data_env)
}
# return results of evaluation (used for knitr cache)
result
}
# straight evaluate if this is a render context
else if ("render" %in% context) {
evaluate::evaluate(code, envir, ...)
}
# otherwise parse so we can throw an error for invalid code
else {
xfun::parse_only(code)
list()
}
}
}
# Remove prerendered .RData that isn't in the cache (as data in the
# cache won't necessarily be recreated during the next render)
shiny_prerendered_remove_uncached_data <- function(input) {
data_dir <- shiny_prerendered_data_dir(input)
if (dir_exists(data_dir)) {
index_file <- shiny_prerendered_data_chunks_index(data_dir)
if (file.exists(index_file))
unlink(index_file)
rdata_files <- list.files(data_dir, pattern = utils::glob2rx("*.RData"))
cached_rdata_files <- list.files(data_dir, pattern = utils::glob2rx("*.cached.RData"))
uncached_rdata_files <- setdiff(rdata_files, cached_rdata_files)
unlink(file.path(data_dir, uncached_rdata_files))
}
}
# Extract application/shiny-prerendered script tags from an html document
shiny_prerendered_extract_context <- function(html_lines, context) {
# look for lines that start the context
pattern <- paste0('<script type="application/shiny-prerendered" data-context="', context, '">')
matches <- regmatches(html_lines, regexec(pattern, html_lines, fixed = TRUE))
# extract the code within the contexts
in_context <- FALSE
context_lines <- character()
for (i in 1:length(matches)) {
if (length(matches[[i]]) > 0) {
in_context <- TRUE
next
}
else if (in_context && identical(html_lines[[i]], "</script>")) {
in_context <- FALSE
}
if (in_context)
context_lines <- c(context_lines, html_lines[[i]])
}
# unescape code, see https://github.com/rstudio/rmarkdown/issues/943
context_lines <- gsub("<\\u002f", "</", context_lines, fixed = TRUE)
context_lines
}
shiny_prerendered_remove_contexts <- function(html_lines, contexts) {
# look for lines that start the contexts
pattern <- paste0('<script type="application/shiny-prerendered" data-context="')
matches <- regmatches(html_lines, regexec(pattern, html_lines, fixed = TRUE))
# create a regex pattern used for matching named contexts
contexts_pattern <- paste0(pattern, "(", paste(contexts, collapse = "|"), ")")
# new_html_lines to return
new_html_lines <- character()
# ignore the code within the contexts
in_context <- FALSE
for (i in 1:length(matches)) {
if (length(matches[[i]]) > 0 && grepl(contexts_pattern, html_lines[[i]])) {
in_context = TRUE
}
else if (in_context && identical(html_lines[[i]], "</script>")) {
in_context <- FALSE
}
else if (!in_context)
new_html_lines <- c(new_html_lines, html_lines[[i]])
}
# return
new_html_lines
}
# Gather shiny_prerendred contexts and append them as script tags to
# the passed file
shiny_prerendered_append_contexts <- function(runtime, file) {
# collect contexts
shiny_prerendered_contexts <- knit_meta_reset(class = "shiny_prerendered")
if (length(shiny_prerendered_contexts) > 0) {
# validate we are in runtime: shiny_prerendered
if (!is_shiny_prerendered(runtime)) {
stop2("The code within this document requires server: shiny")
}
# open the file
con <- file(file, open = "at", encoding = 'UTF-8')
on.exit(close(con), add = TRUE)
# track singletons
singletons <- list()
# append the contexts as script tags
for (context in shiny_prerendered_contexts) {
# resolve singletons
if (isTRUE(context$singleton)) {
found_singleton <- FALSE
for (singleton in singletons) {
if (identical(context, singleton)) {
found_singleton <- TRUE
break
}
}
if (found_singleton) next
singletons[[length(singletons) + 1]] <- context
}
# append context
shiny_prerendered_append_context(con, context$name, context$code)
}
}
}
shiny_prerendered_append_context <- function(con, name, code) {
lines <- c('<!--html_preserve-->',
paste0('<script type="application/shiny-prerendered" ',
'data-context="', name ,'">'),
# escape code, see https://github.com/rstudio/rmarkdown/issues/943
gsub("</", "<\\u002f", code, fixed = TRUE),
'</script>',
'<!--/html_preserve-->')
writeLines(lines, con = con)
}
# Prerendred data_dir for a given Rmd input file
shiny_prerendered_data_dir <- function(input, create = FALSE) {
data_dir <- paste0(xfun::sans_ext(input), "_data")
if (create && !dir_exists(data_dir))
dir.create(data_dir)
data_dir
}
# Load prerendred data into the server environment. There are two
# reasons we load data based on a previously generated index file:
#
# (1) We don't remove all of the previously generated .RData files
# at the beginning of a render. Specifically, we don't remove
# .RData files that were created within a chunk w/ caching
# enabled, since that .RData won't necessarily be re-created on
# the next render. This means that we could be left with "stale"
# .RData files from cached chunks. Reading based on the list
# ensures that we only read .RData for chunks that were
# included in the last rendered document.
#
# (2) We want to load data into the server environment in the
# exact same chunk order that it appears in the document.
#
shiny_prerendered_data_load <- function(input_rmd, server_envir) {
# check for data_dir
data_dir <- shiny_prerendered_data_dir(input_rmd)
if (dir_exists(data_dir)) {
# read index of data files
index_file <- shiny_prerendered_data_chunks_index(data_dir)
if (file.exists(index_file)) {
rdata_files <- read_utf8(index_file)
# load each of the files in the index
for (rdata_file in rdata_files) {
rdata_file <- file.path(data_dir,rdata_file)
if (file.exists(rdata_file)) # won't exist if the chunk has no code
load(rdata_file, envir = server_envir)
}
}
}
}
# File used to store names of chunks which had cache=TRUE during the last render
shiny_prerendered_data_chunks_index <- function(data_dir) {
file.path(data_dir, "data_chunks_index.txt")
}
# Form the name of a shiny_prerendered .RData file
shiny_prerendered_data_file_name <- function(label, cache) {
type <- ifelse(cache, ".cached", "")
sprintf("%s%s.RData", label, type)
}
# Use me instead of html_dependency_bootstrap() in a shiny runtime to get
# dynamic theming (i.e., have it work with session$setCurrentTheme())
shiny_bootstrap_lib <- function(theme) {
theme <- resolve_theme(theme)
if (!is_bs_theme(theme)) {
return(NULL)
}
if (!is_available("shiny", "1.6.0")) {
stop(
"Using a {bslib} theme with `runtime: shiny` requires shiny 1.6.0 or higher."
)
}
shiny::bootstrapLib(theme)
}