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
|
#' @importFrom htmltools renderTags
embed_tags <- function(obj, ...) {
obj <- render_tags(obj, ...)
# render dependencies as data URIs (for standalone HTML)
html_deps <- lapply(obj$dependencies, render_dependency)
sprintf(HTML_SKELETON, paste(html_deps, collapse = '\n'), obj$html)
}
render_tags <- function(obj, ...) {
obj <- renderTags(obj)
if (nchar(obj$head) > 0) {
# TODO:
# (1) can this be done?
# (2) what about singletons?
warning('Inserting HTML strings into <head> is currently not supported')
}
if (getOption('repr.html.deduplicate')) {
# ignore dependencies that already exist in the notebook
obj$dependencies <- setdiff(obj$dependencies, html_dependencies$get())
# add these (new) dependencies to the dependency manager
html_dependencies$add(obj$dependencies)
}
list(
dependencies = obj$dependencies,
html = obj$html
)
}
render_dependency <- function(dep) {
html <- c()
if (length(dep$script) > 0) {
f <- file.path(dep$src$file, dep$script)
# TODO: is this *always* the correct mime type?
html <- c(html, sprintf(
'<script title="%s" src="%s"></script>',
sub('"', '', dep$name),
data_uris(mime = 'application/javascript', files = f)
))
}
if (length(dep$stylesheet) > 0) {
f <- file.path(dep$src$file, dep$stylesheet)
# TODO: is this *always* the correct mime type? Use base64enc::checkUTF8() to ensure UTF-8 is OK?
html <- c(html, sprintf(
'<link href="%s" rel="stylesheet" />',
data_uris(mime = 'text/css;charset-utf-8', files = f)
))
}
paste(html, collapse = '\n')
}
HTML_SKELETON <-
'<!doctype html>
<html>
<head>
<meta charset="utf-8">
%s
</head>
<body>
%s
</body>
</html>
'
# find a new folder name under the working directory
new_dir <- function() {
dir_candidate <- new_id()
while (dir.exists(dir_candidate)) {
dir_candidate <- new_id()
}
dir_candidate
}
new_id <- function() basename(tempfile(''))
# keep track of what dependencies have been included and where they are located
dependency_manager <- function() {
deps <- NULL
dep_dir <- new_dir()
as.environment(list(
get = function() deps,
add = function(dep) deps <<- unique(c(deps, dep)),
clear = function() {
deps <<- NULL
unlink(dep_dir, recursive = TRUE)
},
dir = function() dep_dir
))
}
#' @name repr_*.htmlwidget
#' @export
html_dependencies <- dependency_manager()
# delete the dependency files that have been copied to the jupyter notebook
# webserver location (when this object is garbage collected or upon exiting R)
reg.finalizer(html_dependencies, function(deps) deps$clear(), onexit = TRUE)
#' HTML widget representations
#'
#' Standalone HTML representation and dummy text representation.
#'
#' \code{html_dependencies} is an \link[base]{environment} containing the following functions.
#' \code{getOption(\link[=repr-options]{'repr.html.deduplicate'})}
#' \describe{
#' \item{\code{get()}}{Get the list of added dependencies}
#' \item{\code{add(dep)}}{Marks a dependency as added. Call this e.g. after appending a script tag with the dependency.}
#' \item{\code{clear()}}{Clear the list as seen dependencies. Now everything will be added again when encountered.}
#' \item{\code{dir()}}{Returns the directory in which the dependencies reside.}
#' }
#'
#' @param obj The htmlwidget, shiny.tag, or shiny.tag.list to create a representation for
#' @param ... ignored
#'
#' @name repr_*.htmlwidget
#' @export
repr_text.htmlwidget <- function(obj, ...) 'HTML widgets cannot be represented in plain text (need html)'
#' @name repr_*.htmlwidget
#' @export
repr_html.htmlwidget <- embed_tags
#' @aliases repr_*.shiny.tag
#' @name repr_*.htmlwidget
#' @export
repr_text.shiny.tag <- function(obj, ...) 'Shiny tags cannot be represented in plain text (need html)'
#' @name repr_*.htmlwidget
#' @export
repr_html.shiny.tag <- embed_tags
#' @aliases repr_*.shiny.tag.list
#' @name repr_*.htmlwidget
#' @export
repr_text.shiny.tag.list <- function(obj, ...) 'Shiny tags cannot be represented in plain text (need html)'
#' @name repr_*.htmlwidget
#' @export
repr_html.shiny.tag.list <- embed_tags
|
