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
|
ggvisLayout <- function(plot_id, has_controls = TRUE, spec = NULL,
shiny = TRUE) {
plot_div <- ggvisOutputElements(plot_id, spec = spec, shiny = shiny)
if (!has_controls) {
plot_div
} else {
shiny::bootstrapPage(
sidebarBottomPage(
sidebarBottomPanel(ggvisControlOutput("ggvis_controls", plot_id)),
mainTopPanel(plot_div)
)
)
}
}
# This is the user-facing wrapper for ggvisOutputElements. When the user calls
# it, it will always be used with Shiny.
#' @rdname shiny-ggvis
#' @param plot_id unique identifier to use for the div containing the ggvis plot.
#' @export
ggvisOutput <- function(plot_id = rand_id("plot_id")) {
ggvisOutputElements(plot_id, spec = NULL, shiny = TRUE)
}
#' Create HTML elements for ggvis output
#'
#' This is an internal-facing function similar to ggvisOutput, but with more
#' options.
#'
#' @param plot_id Unique identifier to use for the div containing the ggvis plot.
#' @param spec Plot specification, used internally.
#' @param shiny Should this include headers for Shiny? For dynamic and
#' interactive plots, this should be TRUE; otherwise FALSE.
#' @keywords internal
ggvisOutputElements <- function(plot_id = rand_id("plot_id"), spec = NULL,
shiny = TRUE) {
validate_plot_id(plot_id)
htmltools::attachDependencies(
htmltools::tagList(
ggvisPlot(plot_id),
ggvisSpec(plot_id, spec)
),
c(
ggvis_dependencies(),
if (shiny) list(shiny_dependency())
)
)
}
ggvisPlot <- function(plot_id) {
htmltools::div(id = paste0(plot_id, "-container"), class = "ggvis-output-container",
# Div containing the plot
htmltools::div(id = plot_id, class = "ggvis-output"),
htmltools::div(class = "plot-gear-icon",
ggvisControlGroup(plot_id)
)
)
}
ggvisSpec <- function(plot_id, spec = NULL) {
if (is.null(spec)) return()
json <- jsonlite::toJSON(spec, pretty = TRUE, auto_unbox = TRUE, force = TRUE,
null = "null")
htmltools::tags$script(type = "text/javascript", paste0('\n',
'var ', plot_id, '_spec = ', json, ';\n',
'ggvis.getPlot("', plot_id, '").parseSpec(', plot_id, '_spec);\n'
))
}
# Controls drop down
ggvisControlGroup <- function(plot_id) {
# The <a> tags need the onclick so that they work properly in Shiny Doc iframes
htmltools::tags$nav(class = "ggvis-control",
htmltools::tags$a(class = "ggvis-dropdown-toggle", title = "Controls",
onclick = "return false;"),
htmltools::tags$ul(class = "ggvis-dropdown",
htmltools::tags$li(
"Renderer: ",
htmltools::tags$a(
id = paste0(plot_id, "_renderer_svg"),
class = "ggvis-renderer-button",
onclick = "return false;",
`data-plot-id` = plot_id,
`data-renderer` = "svg",
"SVG"
),
" | ",
htmltools::tags$a(
id = paste0(plot_id, "_renderer_canvas"),
class = "ggvis-renderer-button",
onclick = "return false;",
`data-plot-id` = plot_id,
`data-renderer` = "canvas",
"Canvas"
)
),
htmltools::tags$li(htmltools::tags$a(
id = paste0(plot_id, "_download"),
class = "ggvis-download",
`data-plot-id` = plot_id,
"Download"
))
)
)
}
#' Create a page with a sidebar
#'
#' This creates a page with a sidebar, where the sidebar moves to the bottom
#' when the width goes below a particular value.
#'
#' @param sidebarPanel The \code{\link{sidebarBottomPanel}} containing input
#' controls.
#' @param mainPanel The \code{\link{mainTopPanel}} containing the main content.
#' @param shiny_headers Should Shiny headers be embedded in the page? This
#' should be TRUE for interactive/dynamic pages, FALSE for static pages.
#' @param ... Additional tags.
#' @export
#' @examples
#' sidebarBottomPage(sidebarBottomPanel(), mainTopPanel())
sidebarBottomPage <- function(sidebarPanel, mainPanel, shiny_headers = TRUE) {
content <- htmltools::div(
class = "container-fluid",
htmltools::div(class = "row-fluid",
mainPanel,
sidebarPanel
)
)
if (shiny_headers) {
shiny::bootstrapPage(content)
} else {
content
}
}
#' @export
#' @rdname sidebarBottomPage
sidebarBottomPanel <- function(...) {
htmltools::div(class = "col-sm-4 sidebar-bottom",
htmltools::tags$form(class = "well well-small",
...
)
)
}
#' @rdname sidebarBottomPage
#' @export
mainTopPanel <- function(...) {
htmltools::div(class = "col-sm-8 main-top",
...
)
}
#' Create a ggvis control output element in UI
#'
#' This is effectively the same as \code{\link[shiny]{uiOutput}}, except that
#' on the client side it may call some plot resizing functions after new
#' controls are drawn.
#'
#' \code{ggvisControlOutput} is intended to be used with
#' \code{\link{bind_shiny}} on the server side.
#'
#' @param outputId The output variable to read the value from.
#' @param plotId An optional plot ID or vector of plot IDs. The plots will
#' have their .onControlOutput functions called after the controls are drawn.
#' @examples
#' ggvisControlOutput("plot1")
#' @export
ggvisControlOutput <- function(outputId, plotId = NULL) {
if (is.null(plotId)) {
htmltools::div(id = outputId, class = "ggvis-control-output")
} else {
htmltools::div(
id = outputId,
class = "ggvis-control-output",
`data-plot-id` = paste(plotId, collapse = " ")
)
}
}
|
