/
shinywrappers.R
234 lines (218 loc) · 7.7 KB
/
shinywrappers.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
suppressPackageStartupMessages({
library(caTools)
library(xtable)
})
#' Plot Output
#'
#' Creates a reactive plot that is suitable for assigning to an \code{output}
#' slot.
#'
#' The corresponding HTML output tag should be \code{div} or \code{img} and have
#' the CSS class name \code{shiny-plot-output}.
#'
#' @param func A function that generates a plot.
#' @param width The width of the rendered plot, in pixels; or \code{'auto'} to
#' use the \code{offsetWidth} of the HTML element that is bound to this plot.
#' You can also pass in a function that returns the width in pixels or
#' \code{'auto'}; in the body of the function you may reference reactive
#' values and functions.
#' @param height The height of the rendered plot, in pixels; or \code{'auto'} to
#' use the \code{offsetHeight} of the HTML element that is bound to this plot.
#' You can also pass in a function that returns the width in pixels or
#' \code{'auto'}; in the body of the function you may reference reactive
#' values and functions.
#' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
#' These can be used to set the width, height, background color, etc.
#'
#' @export
reactivePlot <- function(func, width='auto', height='auto', ...) {
args <- list(...)
if (is.function(width))
width <- reactive(width)
if (is.function(height))
height <- reactive(height)
return(function(shinyapp, name, ...) {
png.file <- tempfile(fileext='.png')
if (is.function(width))
width <- width()
if (is.function(height))
height <- height()
# Note that these are reactive calls. A change to the width and height
# will inherently cause a reactive plot to redraw (unless width and
# height were explicitly specified).
prefix <- '.shinyout_'
if (width == 'auto')
width <- shinyapp$session$get(paste(prefix, name, '_width', sep=''));
if (height == 'auto')
height <- shinyapp$session$get(paste(prefix, name, '_height', sep=''));
if (width <= 0 || height <= 0)
return(NULL)
do.call(png, c(args, filename=png.file, width=width, height=height))
on.exit(unlink(png.file))
tryCatch(
func(),
finally=dev.off())
bytes <- file.info(png.file)$size
if (is.na(bytes))
return(NULL)
pngData <- readBin(png.file, 'raw', n=bytes)
if (shinyapp$allowDataUriScheme) {
b64 <- base64encode(pngData)
return(paste("data:image/png;base64,", b64, sep=''))
}
else {
imageUrl <- shinyapp$savePlot(name, pngData, 'image/png')
return(imageUrl)
}
})
}
#' Table Output
#'
#' Creates a reactive table that is suitable for assigning to an \code{output}
#' slot.
#'
#' The corresponding HTML output tag should be \code{div} and have the CSS class
#' name \code{shiny-html-output}.
#'
#' @param func A function that returns an R object that can be used with
#' \code{\link[xtable]{xtable}}.
#' @param ... Arguments to be passed through to \code{\link[xtable]{xtable}} and
#' \code{\link[xtable]{print.xtable}}.
#'
#' @export
reactiveTable <- function(func, ...) {
reactive(function() {
classNames <- getOption('shiny.table.class', 'data table table-bordered table-condensed')
data <- func()
if (is.null(data) || is.na(data))
return("")
return(paste(
capture.output(
print(xtable(data, ...),
type='html',
html.table.attributes=paste('class="',
htmlEscape(classNames, TRUE),
'"',
sep=''), ...)),
collapse="\n"))
})
}
#' Printable Output
#'
#' Makes a reactive version of the given function that also turns its printable
#' result into a string. The reactive function is suitable for assigning to an
#' \code{output} slot.
#'
#' The corresponding HTML output tag can be anything (though \code{pre} is
#' recommended if you need a monospace font and whitespace preserved) and should
#' have the CSS class name \code{shiny-text-output}.
#'
#' The result of executing \code{func} will be printed inside a
#' \code{\link[utils]{capture.output}} call.
#'
#' @param func A function that returns a printable R object.
#'
#' @export
reactivePrint <- function(func) {
reactive(function() {
return(paste(capture.output(print(func())), collapse="\n"))
})
}
#' Text Output
#'
#' Makes a reactive version of the given function that also uses
#' \code{\link[base]{cat}} to turn its result into a single-element character
#' vector.
#'
#' The corresponding HTML output tag can be anything (though \code{pre} is
#' recommended if you need a monospace font and whitespace preserved) and should
#' have the CSS class name \code{shiny-text-output}.
#'
#' The result of executing \code{func} will passed to \code{cat}, inside a
#' \code{\link[utils]{capture.output}} call.
#'
#' @param func A function that returns an R object that can be used as an
#' argument to \code{cat}.
#'
#' @export
reactiveText <- function(func) {
reactive(function() {
return(paste(capture.output(cat(func())), collapse="\n"))
})
}
#' UI Output
#'
#' \bold{Experimental feature.} Makes a reactive version of a function that
#' generates HTML using the Shiny UI library.
#'
#' The corresponding HTML output tag should be \code{div} and have the CSS class
#' name \code{shiny-html-output} (or use \code{\link{uiOutput}}).
#'
#' @param func A function that returns a Shiny tag object, \code{\link{HTML}},
#' or a list of such objects.
#'
#' @seealso conditionalPanel
#'
#' @export
#' @examples
#' \dontrun{
#' output$moreControls <- reactiveUI(function() {
#' list(
#'
#' )
#' })
#' }
reactiveUI <- function(func) {
reactive(function() {
result <- func()
if (is.null(result) || length(result) == 0)
return(NULL)
return(as.character(result))
})
}
#' File Downloads
#'
#' Allows content from the Shiny application to be made available to the user as
#' file downloads (for example, downloading the currently visible data as a CSV
#' file). Both filename and contents can be calculated dynamically at the time
#' the user initiates the download. Assign the return value to a slot on
#' \code{output} in your server function, and in the UI use
#' \code{\link{downloadButton}} or \code{\link{downloadLink}} to make the
#' download available.
#'
#' @param filename A string of the filename, including extension, that the
#' user's web browser should default to when downloading the file; or a
#' function that returns such a string. (Reactive values and functions may be
#' used from this function.)
#' @param content A function that takes a single argument \code{file} that is a
#' file path (string) of a nonexistent temp file, and writes the content to
#' that file path. (Reactive values and functions may be used from this
#' function.)
#' @param contentType A string of the download's
#' \href{http://en.wikipedia.org/wiki/Internet_media_type}{content type}, for
#' example \code{"text/csv"} or \code{"image/png"}. If \code{NULL} or
#' \code{NA}, the content type will be guessed based on the filename
#' extension, or \code{application/octet-stream} if the extension is unknown.
#'
#' @examples
#' \dontrun{
#' # In server.R:
#' output$downloadData <- downloadHandler(
#' filename = function() {
#' paste('data-', Sys.Date(), '.csv', sep='')
#' },
#' content = function(file) {
#' write.csv(data, file)
#' }
#' )
#'
#' # In ui.R:
#' downloadLink('downloadData', 'Download')
#' }
#'
#' @export
downloadHandler <- function(filename, content, contentType=NA) {
return(function(shinyapp, name, ...) {
shinyapp$registerDownload(name, filename, contentType, content)
})
}