1#' @include utils.R
2NULL
3
4#' Create a Bootstrap page
5#'
6#' Create a Shiny UI page that loads the CSS and JavaScript for
7#' [Bootstrap](https://getbootstrap.com/), and has no content in the page
8#' body (other than what you provide).
9#'
10#' This function is primarily intended for users who are proficient in HTML/CSS,
11#' and know how to lay out pages in Bootstrap. Most applications should use
12#' [fluidPage()] along with layout functions like
13#' [fluidRow()] and [sidebarLayout()].
14#'
15#' @param ... The contents of the document body.
16#' @param title The browser window title (defaults to the host URL of the page)
17#' @param theme One of the following:
18#'   * `NULL` (the default), which implies a "stock" build of Bootstrap 3.
19#'   * A [bslib::bs_theme()] object. This can be used to replace a stock
20#'   build of Bootstrap 3 with a customized version of Bootstrap 3 or higher.
21#'   * A character string pointing to an alternative Bootstrap stylesheet
22#'   (normally a css file within the www directory, e.g. `www/bootstrap.css`).
23#' @param lang ISO 639-1 language code for the HTML page, such as "en" or "ko".
24#'   This will be used as the lang in the \code{<html>} tag, as in \code{<html lang="en">}.
25#'   The default (NULL) results in an empty string.
26#'
27#' @return A UI defintion that can be passed to the [shinyUI] function.
28#'
29#' @note The `basicPage` function is deprecated, you should use the
30#'   [fluidPage()] function instead.
31#'
32#' @seealso [fluidPage()], [fixedPage()]
33#' @export
34bootstrapPage <- function(..., title = NULL, theme = NULL, lang = NULL) {
35
36  args <- list(
37    jqueryDependency(),
38    if (!is.null(title)) tags$head(tags$title(title)),
39    if (is.character(theme)) {
40      if (length(theme) > 1) stop("`theme` must point to a single CSS file, not multiple files.")
41      tags$head(tags$link(rel="stylesheet", type="text/css", href=theme))
42    },
43    # remainder of tags passed to the function
44    list2(...)
45  )
46
47  # If theme is a bslib::bs_theme() object, bootstrapLib() needs to come first
48  # (so other tags, when rendered via tagFunction(), know about the relevant
49  # theme). However, if theme is anything else, we intentionally avoid changing
50  # the tagList() contents to avoid breaking user code that makes assumptions
51  # about the return value https://github.com/rstudio/shiny/issues/3235
52  if (is_bs_theme(theme)) {
53    args <- c(bootstrapLib(theme), args)
54    ui <- do.call(tagList, args)
55  } else {
56    ui <- do.call(tagList, args)
57    ui <- attachDependencies(ui, bootstrapLib())
58  }
59
60  setLang(ui, lang)
61}
62
63setLang <- function(ui, lang) {
64  # Add lang attribute to be passed to renderPage function
65  attr(ui, "lang") <- lang
66  ui
67}
68getLang <- function(ui) {
69  # Check if ui has lang attribute; otherwise, NULL
70  attr(ui, "lang", exact = TRUE)
71}
72
73#' Bootstrap libraries
74#'
75#' This function defines a set of web dependencies necessary for using Bootstrap
76#' components in a web page.
77#'
78#' It isn't necessary to call this function if you use [bootstrapPage()] or
79#' others which use `bootstrapPage`, such [fluidPage()], [navbarPage()],
80#' [fillPage()], etc, because they already include the Bootstrap web dependencies.
81#'
82#' @inheritParams bootstrapPage
83#' @export
84bootstrapLib <- function(theme = NULL) {
85  tagFunction(function() {
86    if (isRunning()) {
87      setCurrentTheme(theme)
88    }
89
90    # If we're not compiling Bootstrap Sass (from bslib), return the
91    # static Bootstrap build.
92    if (!is_bs_theme(theme)) {
93      # We'll enter here if `theme` is the path to a .css file, like that
94      # provided by `shinythemes::shinytheme("darkly")`.
95      return(bootstrapDependency(theme))
96    }
97
98    # Make bootstrap Sass available so other tagFunction()s (e.g.,
99    # sliderInput() et al) can resolve their HTML dependencies at render time
100    # using getCurrentTheme(). Note that we're making an implicit assumption
101    # that this tagFunction() executes *before* all other tagFunction()s; but
102    # that should be fine considering that, DOM tree order is preorder,
103    # depth-first traversal, and at least in the bootstrapPage(theme) case, we
104    # have control over the relative ordering.
105    # https://dom.spec.whatwg.org/#concept-tree
106    # https://stackoverflow.com/a/16113998/1583084
107    #
108    # Note also that since this is shinyOptions() (and not options()), the
109    # option is automatically reset when the app (or session) exits
110    if (isRunning()) {
111      registerThemeDependency(bs_theme_deps)
112
113    } else {
114      # Technically, this a potential issue (someone trying to execute/render
115      # bootstrapLib outside of a Shiny app), but it seems that, in that case,
116      # you likely have other problems, since sliderInput() et al. already assume
117      # that Shiny is the one doing the rendering
118      #warning(
119      #  "It appears `shiny::bootstrapLib()` was rendered outside of an Shiny ",
120      #  "application context, likely by calling `as.tags()`, `as.character()`, ",
121      #  "or `print()` directly on `bootstrapLib()` or UI components that may ",
122      #  "depend on it (e.g., `fluidPage()`, etc). For 'themable' UI components ",
123      #  "(e.g., `sliderInput()`, `selectInput()`, `dateInput()`, etc) to style ",
124      #  "themselves based on the Bootstrap theme, make sure `bootstrapLib()` is ",
125      #  "provided directly to the UI and that the UI is provided direction to ",
126      #  "`shinyApp()` (or `runApp()`)", call. = FALSE
127      #)
128    }
129
130    bslib::bs_theme_dependencies(theme)
131  })
132}
133
134# This is defined outside of bootstrapLib() because registerThemeDependency()
135# wants a non-anonymous function with a single argument
136bs_theme_deps <- function(theme) {
137  bslib::bs_theme_dependencies(theme)
138}
139
140is_bs_theme <- function(x) {
141  is_available("bslib", "0.2.0.9000") &&
142    bslib::is_bs_theme(x)
143}
144
145#' Obtain Shiny's Bootstrap Sass theme
146#'
147#' Intended for use by Shiny developers to create Shiny bindings with intelligent
148#' styling based on the [bootstrapLib()]'s `theme` value.
149#'
150#' @return If called at render-time (i.e., inside a [htmltools::tagFunction()]),
151#' and [bootstrapLib()]'s `theme` has been set to a [bslib::bs_theme()]
152#' object, then this returns the `theme`. Otherwise, this returns `NULL`.
153#' @seealso [getCurrentOutputInfo()], [bootstrapLib()], [htmltools::tagFunction()]
154#'
155#' @keywords internal
156#' @export
157getCurrentTheme <- function() {
158  getShinyOption("bootstrapTheme", default = NULL)
159}
160
161getCurrentThemeVersion <- function() {
162  theme <- getCurrentTheme()
163  if (bslib::is_bs_theme(theme)) {
164    bslib::theme_version(theme)
165  } else {
166    strsplit(bootstrapVersion, ".", fixed = TRUE)[[1]][[1]]
167  }
168}
169
170setCurrentTheme <- function(theme) {
171  shinyOptions(bootstrapTheme = theme)
172}
173
174#' Register a theme dependency
175#'
176#' This function registers a function that returns an [htmlDependency()] or list
177#' of such objects. If `session$setCurrentTheme()` is called, the function will
178#' be re-executed, and the resulting html dependency will be sent to the client.
179#'
180#' Note that `func` should **not** be an anonymous function, or a function which
181#' is defined within the calling function. This is so that,
182#' `registerThemeDependency()` is called multiple times with the function, it
183#' tries to deduplicate them
184#'
185#' @param func A function that takes one argument, `theme` (which is a
186#'   [sass::sass_layer()] object), and returns an htmlDependency object, or list
187#'   of them.
188#'
189#' @export
190#' @keywords internal
191registerThemeDependency <- function(func) {
192  func_expr <- substitute(func)
193  if (is.call(func_expr) && identical(func_expr[[1]], as.symbol("function"))) {
194    warning("`func` should not be an anonymous function. ",
195      "It should be declared outside of the function that calls registerThemeDependency(); ",
196      "otherwise it will not be deduplicated by Shiny and multiple copies of the ",
197      "resulting htmlDependency may be computed and sent to the client.")
198  }
199  if (!is.function(func) || length(formals(func)) != 1) {
200    stop("`func` must be a function with one argument (the current theme)")
201  }
202
203  # Note that this will automatically scope to the app or session level,
204  # depending on if this is called from within a session or not.
205  funcs <- getShinyOption("themeDependencyFuncs", default = list())
206
207  # Don't add func if it's already present.
208  have_func <- any(vapply(funcs, identical, logical(1), func))
209  if (!have_func) {
210    funcs[[length(funcs) + 1]] <- func
211  }
212
213  shinyOptions("themeDependencyFuncs" = funcs)
214}
215
216bootstrapDependency <- function(theme) {
217  htmlDependency(
218    "bootstrap", bootstrapVersion,
219    c(
220      href = "shared/bootstrap",
221      file = system.file("www/shared/bootstrap", package = "shiny")
222    ),
223    script = c(
224      "js/bootstrap.min.js",
225      # Safely adding accessibility plugin for screen readers and keyboard users; no break for sighted aspects (see https://github.com/paypal/bootstrap-accessibility-plugin)
226      "accessibility/js/bootstrap-accessibility.min.js"
227    ),
228    stylesheet = c(
229      theme %||% "css/bootstrap.min.css",
230      # Safely adding accessibility plugin for screen readers and keyboard users; no break for sighted aspects (see https://github.com/paypal/bootstrap-accessibility-plugin)
231      "accessibility/css/bootstrap-accessibility.min.css"
232    ),
233    meta = list(viewport = "width=device-width, initial-scale=1")
234  )
235}
236
237bootstrapVersion <- "3.4.1"
238
239
240#' @rdname bootstrapPage
241#' @export
242basicPage <- function(...) {
243  bootstrapPage(div(class="container-fluid", list(...)))
244}
245
246
247#' Create a page that fills the window
248#'
249#' `fillPage` creates a page whose height and width always fill the
250#' available area of the browser window.
251#'
252#' The [fluidPage()] and [fixedPage()] functions are used
253#' for creating web pages that are laid out from the top down, leaving
254#' whitespace at the bottom if the page content's height is smaller than the
255#' browser window, and scrolling if the content is larger than the window.
256#'
257#' `fillPage` is designed to latch the document body's size to the size of
258#' the window. This makes it possible to fill it with content that also scales
259#' to the size of the window.
260#'
261#' For example, `fluidPage(plotOutput("plot", height = "100%"))` will not
262#' work as expected; the plot element's effective height will be `0`,
263#' because the plot's containing elements (`<div>` and `<body>`) have
264#' *automatic* height; that is, they determine their own height based on
265#' the height of their contained elements. However,
266#' `fillPage(plotOutput("plot", height = "100%"))` will work because
267#' `fillPage` fixes the `<body>` height at 100% of the window height.
268#'
269#' Note that `fillPage(plotOutput("plot"))` will not cause the plot to fill
270#' the page. Like most Shiny output widgets, `plotOutput`'s default height
271#' is a fixed number of pixels. You must explicitly set `height = "100%"`
272#' if you want a plot (or htmlwidget, say) to fill its container.
273#'
274#' One must be careful what layouts/panels/elements come between the
275#' `fillPage` and the plots/widgets. Any container that has an automatic
276#' height will cause children with `height = "100%"` to misbehave. Stick
277#' to functions that are designed for fill layouts, such as the ones in this
278#' package.
279#'
280#' @param ... Elements to include within the page.
281#' @param padding Padding to use for the body. This can be a numeric vector
282#'   (which will be interpreted as pixels) or a character vector with valid CSS
283#'   lengths. The length can be between one and four. If one, then that value
284#'   will be used for all four sides. If two, then the first value will be used
285#'   for the top and bottom, while the second value will be used for left and
286#'   right. If three, then the first will be used for top, the second will be
287#'   left and right, and the third will be bottom. If four, then the values will
288#'   be interpreted as top, right, bottom, and left respectively.
289#' @param title The title to use for the browser window/tab (it will not be
290#'   shown in the document).
291#' @param bootstrap If `TRUE`, load the Bootstrap CSS library.
292#' @inheritParams bootstrapPage
293#'
294#' @family layout functions
295#'
296#' @examples
297#' fillPage(
298#'   tags$style(type = "text/css",
299#'     ".half-fill { width: 50%; height: 100%; }",
300#'     "#one { float: left; background-color: #ddddff; }",
301#'     "#two { float: right; background-color: #ccffcc; }"
302#'   ),
303#'   div(id = "one", class = "half-fill",
304#'     "Left half"
305#'   ),
306#'   div(id = "two", class = "half-fill",
307#'     "Right half"
308#'   ),
309#'   padding = 10
310#' )
311#'
312#' fillPage(
313#'   fillRow(
314#'     div(style = "background-color: red; width: 100%; height: 100%;"),
315#'     div(style = "background-color: blue; width: 100%; height: 100%;")
316#'   )
317#' )
318#' @export
319fillPage <- function(..., padding = 0, title = NULL, bootstrap = TRUE,
320  theme = NULL, lang = NULL) {
321
322  fillCSS <- tags$head(tags$style(type = "text/css",
323    "html, body { width: 100%; height: 100%; overflow: hidden; }",
324    sprintf("body { padding: %s; margin: 0; }", collapseSizes(padding))
325  ))
326
327  if (isTRUE(bootstrap)) {
328    ui <- bootstrapPage(title = title, theme = theme, fillCSS, lang = lang, ...)
329  } else {
330    ui <- tagList(
331      fillCSS,
332      if (!is.null(title)) tags$head(tags$title(title)),
333      ...
334    )
335
336    ui <- setLang(ui, lang)
337  }
338
339  return(ui)
340}
341
342collapseSizes <- function(padding) {
343  paste(
344    sapply(padding, shiny::validateCssUnit, USE.NAMES = FALSE),
345    collapse = " ")
346}
347
348#' Create a page with a top level navigation bar
349#'
350#' Create a page that contains a top level navigation bar that can be used to
351#' toggle a set of [tabPanel()] elements.
352#'
353#' @param title The title to display in the navbar
354#' @param ... [tabPanel()] elements to include in the page. The
355#'   `navbarMenu` function also accepts strings, which will be used as menu
356#'   section headers. If the string is a set of dashes like `"----"` a
357#'   horizontal separator will be displayed in the menu.
358#' @param id If provided, you can use `input$`*`id`* in your
359#'   server logic to determine which of the current tabs is active. The value
360#'   will correspond to the `value` argument that is passed to
361#'   [tabPanel()].
362#' @param selected The `value` (or, if none was supplied, the `title`)
363#'   of the tab that should be selected by default. If `NULL`, the first
364#'   tab will be selected.
365#' @param position Determines whether the navbar should be displayed at the top
366#'   of the page with normal scrolling behavior (`"static-top"`), pinned at
367#'   the top (`"fixed-top"`), or pinned at the bottom
368#'   (`"fixed-bottom"`). Note that using `"fixed-top"` or
369#'   `"fixed-bottom"` will cause the navbar to overlay your body content,
370#'   unless you add padding, e.g.: \code{tags$style(type="text/css", "body
371#'   {padding-top: 70px;}")}
372#' @param header Tag or list of tags to display as a common header above all
373#'   tabPanels.
374#' @param footer Tag or list of tags to display as a common footer below all
375#'   tabPanels
376#' @param inverse `TRUE` to use a dark background and light text for the
377#'   navigation bar
378#' @param collapsible `TRUE` to automatically collapse the navigation
379#'   elements into a menu when the width of the browser is less than 940 pixels
380#'   (useful for viewing on smaller touchscreen device)
381#' @param fluid `TRUE` to use a fluid layout. `FALSE` to use a fixed
382#'   layout.
383#' @param windowTitle the browser window title (as a character string). The
384#'   default value, `NA`, means to use any character strings that appear in
385#'   `title` (if none are found, the host URL of the page is displayed by
386#'   default).
387#' @inheritParams bootstrapPage
388#' @param icon Optional icon to appear on a `navbarMenu` tab.
389#'
390#' @return A UI defintion that can be passed to the [shinyUI] function.
391#'
392#' @details The `navbarMenu` function can be used to create an embedded
393#'   menu within the navbar that in turns includes additional tabPanels (see
394#'   example below).
395#'
396#' @seealso [tabPanel()], [tabsetPanel()],
397#'   [updateNavbarPage()], [insertTab()],
398#'   [showTab()]
399#'
400#' @family layout functions
401#'
402#' @examples
403#' navbarPage("App Title",
404#'   tabPanel("Plot"),
405#'   tabPanel("Summary"),
406#'   tabPanel("Table")
407#' )
408#'
409#' navbarPage("App Title",
410#'   tabPanel("Plot"),
411#'   navbarMenu("More",
412#'     tabPanel("Summary"),
413#'     "----",
414#'     "Section header",
415#'     tabPanel("Table")
416#'   )
417#' )
418#' @export
419navbarPage <- function(title,
420                       ...,
421                       id = NULL,
422                       selected = NULL,
423                       position = c("static-top", "fixed-top", "fixed-bottom"),
424                       header = NULL,
425                       footer = NULL,
426                       inverse = FALSE,
427                       collapsible = FALSE,
428                       fluid = TRUE,
429                       theme = NULL,
430                       windowTitle = NA,
431                       lang = NULL) {
432  remove_first_class(bslib::page_navbar(
433    ..., title = title, id = id, selected = selected,
434    position = match.arg(position),
435    header = header, footer = footer,
436    inverse = inverse, collapsible = collapsible,
437    fluid = fluid,
438    theme = theme,
439    window_title = windowTitle,
440    lang = lang
441  ))
442}
443
444#' @param menuName A name that identifies this `navbarMenu`. This
445#'   is needed if you want to insert/remove or show/hide an entire
446#'   `navbarMenu`.
447#'
448#' @rdname navbarPage
449#' @export
450navbarMenu <- function(title, ..., menuName = title, icon = NULL) {
451  bslib::nav_menu(title, ..., value = menuName, icon = icon)
452}
453
454#' Create a well panel
455#'
456#' Creates a panel with a slightly inset border and grey background. Equivalent
457#' to Bootstrap's `well` CSS class.
458#'
459#' @param ... UI elements to include inside the panel.
460#' @return The newly created panel.
461#' @export
462wellPanel <- function(...) {
463  div(class="well", ...)
464}
465
466#' Conditional Panel
467#'
468#' Creates a panel that is visible or not, depending on the value of a
469#' JavaScript expression. The JS expression is evaluated once at startup and
470#' whenever Shiny detects a relevant change in input/output.
471#'
472#' In the JS expression, you can refer to `input` and `output`
473#' JavaScript objects that contain the current values of input and output. For
474#' example, if you have an input with an id of `foo`, then you can use
475#' `input.foo` to read its value. (Be sure not to modify the input/output
476#' objects, as this may cause unpredictable behavior.)
477#'
478#' @param condition A JavaScript expression that will be evaluated repeatedly to
479#'   determine whether the panel should be displayed.
480#' @param ns The [`namespace()`][NS] object of the current module, if
481#'   any.
482#' @param ... Elements to include in the panel.
483#'
484#' @note You are not recommended to use special JavaScript characters such as a
485#'   period `.` in the input id's, but if you do use them anyway, for
486#'   example, `inputId = "foo.bar"`, you will have to use
487#'   `input["foo.bar"]` instead of `input.foo.bar` to read the input
488#'   value.
489#' @examples
490#' ## Only run this example in interactive R sessions
491#' if (interactive()) {
492#'   ui <- fluidPage(
493#'     sidebarPanel(
494#'       selectInput("plotType", "Plot Type",
495#'         c(Scatter = "scatter", Histogram = "hist")
496#'       ),
497#'       # Only show this panel if the plot type is a histogram
498#'       conditionalPanel(
499#'         condition = "input.plotType == 'hist'",
500#'         selectInput(
501#'           "breaks", "Breaks",
502#'           c("Sturges", "Scott", "Freedman-Diaconis", "[Custom]" = "custom")
503#'         ),
504#'         # Only show this panel if Custom is selected
505#'         conditionalPanel(
506#'           condition = "input.breaks == 'custom'",
507#'           sliderInput("breakCount", "Break Count", min = 1, max = 50, value = 10)
508#'         )
509#'       )
510#'     ),
511#'     mainPanel(
512#'       plotOutput("plot")
513#'     )
514#'   )
515#'
516#'   server <- function(input, output) {
517#'     x <- rnorm(100)
518#'     y <- rnorm(100)
519#'
520#'     output$plot <- renderPlot({
521#'       if (input$plotType == "scatter") {
522#'         plot(x, y)
523#'       } else {
524#'         breaks <- input$breaks
525#'         if (breaks == "custom") {
526#'           breaks <- input$breakCount
527#'         }
528#'
529#'         hist(x, breaks = breaks)
530#'       }
531#'     })
532#'   }
533#'
534#'   shinyApp(ui, server)
535#' }
536#' @export
537conditionalPanel <- function(condition, ..., ns = NS(NULL)) {
538  div(`data-display-if`=condition, `data-ns-prefix`=ns(""), ...)
539}
540
541#' Create a help text element
542#'
543#' Create help text which can be added to an input form to provide additional
544#' explanation or context.
545#'
546#' @param ... One or more help text strings (or other inline HTML elements)
547#' @return A help text element that can be added to a UI definition.
548#'
549#' @examples
550#' helpText("Note: while the data view will show only",
551#'          "the specified number of observations, the",
552#'          "summary will be based on the full dataset.")
553#' @export
554helpText <- function(...) {
555  span(class="help-block", ...)
556}
557
558
559#' Create a tab panel
560#'
561#'
562#' @param title Display title for tab
563#' @param ... UI elements to include within the tab
564#' @param value The value that should be sent when `tabsetPanel` reports
565#'   that this tab is selected. If omitted and `tabsetPanel` has an
566#'   `id`, then the title will be used.
567#' @param icon Optional icon to appear on the tab. This attribute is only
568#' valid when using a `tabPanel` within a [navbarPage()].
569#' @return A tab that can be passed to [tabsetPanel()]
570#'
571#' @seealso [tabsetPanel()]
572#'
573#' @examples
574#' # Show a tabset that includes a plot, summary, and
575#' # table view of the generated distribution
576#' mainPanel(
577#'   tabsetPanel(
578#'     tabPanel("Plot", plotOutput("plot")),
579#'     tabPanel("Summary", verbatimTextOutput("summary")),
580#'     tabPanel("Table", tableOutput("table"))
581#'   )
582#' )
583#' @export
584#' @describeIn tabPanel Create a tab panel that can be included within a [tabsetPanel()] or a [navbarPage()].
585tabPanel <- function(title, ..., value = title, icon = NULL) {
586  bslib::nav(title, ..., value = value, icon = icon)
587}
588
589#' @export
590#' @describeIn tabPanel Create a tab panel that drops the title argument.
591#'   This function should be used within `tabsetPanel(type = "hidden")`. See [tabsetPanel()] for example usage.
592tabPanelBody <- function(value, ..., icon = NULL) {
593  bslib::nav_content(value, ..., icon = icon)
594}
595
596#' Create a tabset panel
597#'
598#' Create a tabset that contains [tabPanel()] elements. Tabsets are
599#' useful for dividing output into multiple independently viewable sections.
600#'
601#' @param ... [tabPanel()] elements to include in the tabset
602#' @param id If provided, you can use `input$`*`id`* in your
603#'   server logic to determine which of the current tabs is active. The value
604#'   will correspond to the `value` argument that is passed to
605#'   [tabPanel()].
606#' @param selected The `value` (or, if none was supplied, the `title`)
607#'   of the tab that should be selected by default. If `NULL`, the first
608#'   tab will be selected.
609#' @param type  \describe{
610#'   \item{`"tabs"`}{Standard tab look}
611#'   \item{`"pills"`}{Selected tabs use the background fill color}
612#'   \item{`"hidden"`}{Hides the selectable tabs. Use `type = "hidden"` in
613#'   conjunction with [tabPanelBody()] and [updateTabsetPanel()] to control the
614#'   active tab via other input controls. (See example below)}
615#' }
616#' @inheritParams navbarPage
617#' @return A tabset that can be passed to [mainPanel()]
618#'
619#' @seealso [tabPanel()], [updateTabsetPanel()],
620#'   [insertTab()], [showTab()]
621#'
622#' @examples
623#' # Show a tabset that includes a plot, summary, and
624#' # table view of the generated distribution
625#' mainPanel(
626#'   tabsetPanel(
627#'     tabPanel("Plot", plotOutput("plot")),
628#'     tabPanel("Summary", verbatimTextOutput("summary")),
629#'     tabPanel("Table", tableOutput("table"))
630#'   )
631#' )
632#'
633#' ui <- fluidPage(
634#'   sidebarLayout(
635#'     sidebarPanel(
636#'       radioButtons("controller", "Controller", 1:3, 1)
637#'     ),
638#'     mainPanel(
639#'       tabsetPanel(
640#'         id = "hidden_tabs",
641#'         # Hide the tab values.
642#'         # Can only switch tabs by using `updateTabsetPanel()`
643#'         type = "hidden",
644#'         tabPanelBody("panel1", "Panel 1 content"),
645#'         tabPanelBody("panel2", "Panel 2 content"),
646#'         tabPanelBody("panel3", "Panel 3 content")
647#'       )
648#'     )
649#'   )
650#' )
651#'
652#' server <- function(input, output, session) {
653#'   observeEvent(input$controller, {
654#'     updateTabsetPanel(session, "hidden_tabs", selected = paste0("panel", input$controller))
655#'   })
656#' }
657#'
658#' if (interactive()) {
659#'   shinyApp(ui, server)
660#' }
661#' @export
662tabsetPanel <- function(...,
663                        id = NULL,
664                        selected = NULL,
665                        type = c("tabs", "pills", "hidden"),
666                        header = NULL,
667                        footer = NULL) {
668
669  func <- switch(
670    match.arg(type),
671    tabs = bslib::navs_tab,
672    pills = bslib::navs_pill,
673    hidden = bslib::navs_hidden
674  )
675
676  # bslib adds a class to make the content browsable() by default,
677  # but that's probably too big of a change for shiny
678  remove_first_class(
679    func(..., id = id, selected = selected, header = header, footer = footer)
680  )
681}
682
683#' Create a navigation list panel
684#'
685#' Create a navigation list panel that provides a list of links on the left
686#' which navigate to a set of tabPanels displayed to the right.
687#'
688#' @param ... [tabPanel()] elements to include in the navlist
689#' @param id If provided, you can use `input$`*`id`* in your
690#'   server logic to determine which of the current navlist items is active. The
691#'   value will correspond to the `value` argument that is passed to
692#'   [tabPanel()].
693#' @param selected The `value` (or, if none was supplied, the `title`)
694#'   of the navigation item that should be selected by default. If `NULL`,
695#'   the first navigation will be selected.
696#' @param well `TRUE` to place a well (gray rounded rectangle) around the
697#'   navigation list.
698#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
699#'   layout.
700#' @param widths Column widths of the navigation list and tabset content areas
701#'   respectively.
702#' @inheritParams tabsetPanel
703#' @inheritParams navbarPage
704#'
705#' @details You can include headers within the `navlistPanel` by including
706#'   plain text elements in the list. Versions of Shiny before 0.11 supported
707#'   separators with "------", but as of 0.11, separators were no longer
708#'   supported. This is because version 0.11 switched to Bootstrap 3, which
709#'   doesn't support separators.
710#'
711#' @seealso [tabPanel()], [updateNavlistPanel()],
712#'    [insertTab()], [showTab()]
713#'
714#' @examples
715#' fluidPage(
716#'
717#'   titlePanel("Application Title"),
718#'
719#'   navlistPanel(
720#'     "Header",
721#'     tabPanel("First"),
722#'     tabPanel("Second"),
723#'     tabPanel("Third")
724#'   )
725#' )
726#' @export
727navlistPanel <- function(...,
728                         id = NULL,
729                         selected = NULL,
730                         header = NULL,
731                         footer = NULL,
732                         well = TRUE,
733                         fluid = TRUE,
734                         widths = c(4, 8)) {
735  remove_first_class(bslib::navs_pill_list(
736    ..., id = id, selected = selected,
737    header = header, footer = footer,
738    well = well, fluid = fluid, widths = widths
739  ))
740}
741
742remove_first_class <- function(x) {
743  class(x) <- class(x)[-1]
744  x
745}
746
747#' Create a text output element
748#'
749#' Render a reactive output variable as text within an application page.
750#' `textOutput()` is usually paired with [renderText()] and puts regular text
751#' in `<div>` or `<span>`; `verbatimTextOutput()` is usually paired with
752#' [renderPrint()] and provides fixed-width text in a `<pre>`.
753#'
754#' In both functions, text is HTML-escaped prior to rendering.
755#'
756#' @param outputId output variable to read the value from
757#' @param container a function to generate an HTML element to contain the text
758#' @param inline use an inline (`span()`) or block container (`div()`)
759#'   for the output
760#' @return An output element for use in UI.
761#' @examples
762#' ## Only run this example in interactive R sessions
763#' if (interactive()) {
764#'   shinyApp(
765#'     ui = basicPage(
766#'       textInput("txt", "Enter the text to display below:"),
767#'       textOutput("text"),
768#'       verbatimTextOutput("verb")
769#'     ),
770#'     server = function(input, output) {
771#'       output$text <- renderText({ input$txt })
772#'       output$verb <- renderText({ input$txt })
773#'     }
774#'   )
775#' }
776#' @export
777textOutput <- function(outputId, container = if (inline) span else div, inline = FALSE) {
778  container(id = outputId, class = "shiny-text-output")
779}
780
781#' @param placeholder if the output is empty or `NULL`, should an empty
782#'   rectangle be displayed to serve as a placeholder? (does not affect
783#'   behavior when the output is nonempty)
784#' @export
785#' @rdname textOutput
786verbatimTextOutput <- function(outputId, placeholder = FALSE) {
787  pre(id = outputId,
788    class = "shiny-text-output",
789    class = if (!placeholder) "noplaceholder"
790  )
791}
792
793
794#' @name plotOutput
795#' @rdname plotOutput
796#' @export
797imageOutput <- function(outputId, width = "100%", height="400px",
798                        click = NULL, dblclick = NULL, hover = NULL, brush = NULL,
799                        inline = FALSE) {
800
801  style <- if (!inline) {
802    # Using `css()` here instead of paste/sprintf so that NULL values will
803    # result in the property being dropped altogether
804    css(width = validateCssUnit(width), height = validateCssUnit(height))
805  }
806
807
808  # Build up arguments for call to div() or span()
809  args <- list(
810    id = outputId,
811    class = "shiny-image-output",
812    style = style
813  )
814
815  # Given a named list with options, replace names like "delayType" with
816  # "data-hover-delay-type" (given a prefix "hover")
817  formatOptNames <- function(opts, prefix) {
818    newNames <- paste("data", prefix, names(opts), sep = "-")
819    # Replace capital letters with "-" and lowercase letter
820    newNames <- gsub("([A-Z])", "-\\L\\1", newNames, perl = TRUE)
821    names(opts) <- newNames
822    opts
823  }
824
825  if (!is.null(click)) {
826    # If click is a string, turn it into clickOpts object
827    if (is.character(click)) {
828      click <- clickOpts(id = click)
829    }
830    args <- c(args, formatOptNames(click, "click"))
831  }
832
833  if (!is.null(dblclick)) {
834    if (is.character(dblclick)) {
835      dblclick <- clickOpts(id = dblclick)
836    }
837    args <- c(args, formatOptNames(dblclick, "dblclick"))
838  }
839
840  if (!is.null(hover)) {
841    if (is.character(hover)) {
842      hover <- hoverOpts(id = hover)
843    }
844    args <- c(args, formatOptNames(hover, "hover"))
845  }
846
847  if (!is.null(brush)) {
848    if (is.character(brush)) {
849      brush <- brushOpts(id = brush)
850    }
851    args <- c(args, formatOptNames(brush, "brush"))
852  }
853
854  container <- if (inline) span else div
855  do.call(container, args)
856}
857
858#' Create an plot or image output element
859#'
860#' Render a [renderPlot()] or [renderImage()] within an
861#' application page.
862#'
863#' @section Interactive plots:
864#'
865#'   Plots and images in Shiny support mouse-based interaction, via clicking,
866#'   double-clicking, hovering, and brushing. When these interaction events
867#'   occur, the mouse coordinates will be sent to the server as `input$`
868#'   variables, as specified by `click`, `dblclick`, `hover`, or
869#'   `brush`.
870#'
871#'   For `plotOutput`, the coordinates will be sent scaled to the data
872#'   space, if possible. (At the moment, plots generated by base graphics and
873#'   ggplot2 support this scaling, although plots generated by lattice and
874#'   others do not.) If scaling is not possible, the raw pixel coordinates will
875#'   be sent. For `imageOutput`, the coordinates will be sent in raw pixel
876#'   coordinates.
877#'
878#'   With ggplot2 graphics, the code in `renderPlot` should return a ggplot
879#'   object; if instead the code prints the ggplot2 object with something like
880#'   `print(p)`, then the coordinates for interactive graphics will not be
881#'   properly scaled to the data space.
882#'
883#' @param outputId output variable to read the plot/image from.
884#' @param width,height Image width/height. Must be a valid CSS unit (like
885#'   `"100%"`, `"400px"`, `"auto"`) or a number, which will be
886#'   coerced to a string and have `"px"` appended. These two arguments are
887#'   ignored when `inline = TRUE`, in which case the width/height of a plot
888#'   must be specified in `renderPlot()`. Note that, for height, using
889#'   `"auto"` or `"100%"` generally will not work as expected,
890#'   because of how height is computed with HTML/CSS.
891#' @param click This can be `NULL` (the default), a string, or an object
892#'   created by the [clickOpts()] function. If you use a value like
893#'   `"plot_click"` (or equivalently, `clickOpts(id="plot_click")`),
894#'   the plot will send coordinates to the server whenever it is clicked, and
895#'   the value will be accessible via `input$plot_click`. The value will be
896#'   a named list  with `x` and `y` elements indicating the mouse
897#'   position.
898#' @param dblclick This is just like the `click` argument, but for
899#'   double-click events.
900#' @param hover Similar to the `click` argument, this can be `NULL`
901#'   (the default), a string, or an object created by the
902#'   [hoverOpts()] function. If you use a value like
903#'   `"plot_hover"` (or equivalently, `hoverOpts(id="plot_hover")`),
904#'   the plot will send coordinates to the server pauses on the plot, and the
905#'   value will be accessible via `input$plot_hover`. The value will be a
906#'   named list with `x` and `y` elements indicating the mouse
907#'   position. To control the hover time or hover delay type, you must use
908#'   [hoverOpts()].
909#' @param brush Similar to the `click` argument, this can be `NULL`
910#'   (the default), a string, or an object created by the
911#'   [brushOpts()] function. If you use a value like
912#'   `"plot_brush"` (or equivalently, `brushOpts(id="plot_brush")`),
913#'   the plot will allow the user to "brush" in the plotting area, and will send
914#'   information about the brushed area to the server, and the value will be
915#'   accessible via `input$plot_brush`. Brushing means that the user will
916#'   be able to draw a rectangle in the plotting area and drag it around. The
917#'   value will be a named list with `xmin`, `xmax`, `ymin`, and
918#'   `ymax` elements indicating the brush area. To control the brush
919#'   behavior, use [brushOpts()]. Multiple
920#'   `imageOutput`/`plotOutput` calls may share the same `id`
921#'   value; brushing one image or plot will cause any other brushes with the
922#'   same `id` to disappear.
923#' @inheritParams textOutput
924#' @note The arguments `clickId` and `hoverId` only work for R base graphics
925#'   (see the \pkg{\link[graphics:graphics-package]{graphics}} package). They do
926#'   not work for \pkg{\link[grid:grid-package]{grid}}-based graphics, such as
927#'   \pkg{ggplot2}, \pkg{lattice}, and so on.
928#' @return A plot or image output element that can be included in a panel.
929#' @seealso For the corresponding server-side functions, see [renderPlot()] and
930#'   [renderImage()].
931#'
932#' @examples
933#' # Only run these examples in interactive R sessions
934#' if (interactive()) {
935#'
936#' # A basic shiny app with a plotOutput
937#' shinyApp(
938#'   ui = fluidPage(
939#'     sidebarLayout(
940#'       sidebarPanel(
941#'         actionButton("newplot", "New plot")
942#'       ),
943#'       mainPanel(
944#'         plotOutput("plot")
945#'       )
946#'     )
947#'   ),
948#'   server = function(input, output) {
949#'     output$plot <- renderPlot({
950#'       input$newplot
951#'       # Add a little noise to the cars data
952#'       cars2 <- cars + rnorm(nrow(cars))
953#'       plot(cars2)
954#'     })
955#'   }
956#' )
957#'
958#'
959#' # A demonstration of clicking, hovering, and brushing
960#' shinyApp(
961#'   ui = basicPage(
962#'     fluidRow(
963#'       column(width = 4,
964#'         plotOutput("plot", height=300,
965#'           click = "plot_click",  # Equiv, to click=clickOpts(id="plot_click")
966#'           hover = hoverOpts(id = "plot_hover", delayType = "throttle"),
967#'           brush = brushOpts(id = "plot_brush")
968#'         ),
969#'         h4("Clicked points"),
970#'         tableOutput("plot_clickedpoints"),
971#'         h4("Brushed points"),
972#'         tableOutput("plot_brushedpoints")
973#'       ),
974#'       column(width = 4,
975#'         verbatimTextOutput("plot_clickinfo"),
976#'         verbatimTextOutput("plot_hoverinfo")
977#'       ),
978#'       column(width = 4,
979#'         wellPanel(actionButton("newplot", "New plot")),
980#'         verbatimTextOutput("plot_brushinfo")
981#'       )
982#'     )
983#'   ),
984#'   server = function(input, output, session) {
985#'     data <- reactive({
986#'       input$newplot
987#'       # Add a little noise to the cars data so the points move
988#'       cars + rnorm(nrow(cars))
989#'     })
990#'     output$plot <- renderPlot({
991#'       d <- data()
992#'       plot(d$speed, d$dist)
993#'     })
994#'     output$plot_clickinfo <- renderPrint({
995#'       cat("Click:\n")
996#'       str(input$plot_click)
997#'     })
998#'     output$plot_hoverinfo <- renderPrint({
999#'       cat("Hover (throttled):\n")
1000#'       str(input$plot_hover)
1001#'     })
1002#'     output$plot_brushinfo <- renderPrint({
1003#'       cat("Brush (debounced):\n")
1004#'       str(input$plot_brush)
1005#'     })
1006#'     output$plot_clickedpoints <- renderTable({
1007#'       # For base graphics, we need to specify columns, though for ggplot2,
1008#'       # it's usually not necessary.
1009#'       res <- nearPoints(data(), input$plot_click, "speed", "dist")
1010#'       if (nrow(res) == 0)
1011#'         return()
1012#'       res
1013#'     })
1014#'     output$plot_brushedpoints <- renderTable({
1015#'       res <- brushedPoints(data(), input$plot_brush, "speed", "dist")
1016#'       if (nrow(res) == 0)
1017#'         return()
1018#'       res
1019#'     })
1020#'   }
1021#' )
1022#'
1023#'
1024#' # Demo of clicking, hovering, brushing with imageOutput
1025#' # Note that coordinates are in pixels
1026#' shinyApp(
1027#'   ui = basicPage(
1028#'     fluidRow(
1029#'       column(width = 4,
1030#'         imageOutput("image", height=300,
1031#'           click = "image_click",
1032#'           hover = hoverOpts(
1033#'             id = "image_hover",
1034#'             delay = 500,
1035#'             delayType = "throttle"
1036#'           ),
1037#'           brush = brushOpts(id = "image_brush")
1038#'         )
1039#'       ),
1040#'       column(width = 4,
1041#'         verbatimTextOutput("image_clickinfo"),
1042#'         verbatimTextOutput("image_hoverinfo")
1043#'       ),
1044#'       column(width = 4,
1045#'         wellPanel(actionButton("newimage", "New image")),
1046#'         verbatimTextOutput("image_brushinfo")
1047#'       )
1048#'     )
1049#'   ),
1050#'   server = function(input, output, session) {
1051#'     output$image <- renderImage({
1052#'       input$newimage
1053#'
1054#'       # Get width and height of image output
1055#'       width  <- session$clientData$output_image_width
1056#'       height <- session$clientData$output_image_height
1057#'
1058#'       # Write to a temporary PNG file
1059#'       outfile <- tempfile(fileext = ".png")
1060#'
1061#'       png(outfile, width=width, height=height)
1062#'       plot(rnorm(200), rnorm(200))
1063#'       dev.off()
1064#'
1065#'       # Return a list containing information about the image
1066#'       list(
1067#'         src = outfile,
1068#'         contentType = "image/png",
1069#'         width = width,
1070#'         height = height,
1071#'         alt = "This is alternate text"
1072#'       )
1073#'     })
1074#'     output$image_clickinfo <- renderPrint({
1075#'       cat("Click:\n")
1076#'       str(input$image_click)
1077#'     })
1078#'     output$image_hoverinfo <- renderPrint({
1079#'       cat("Hover (throttled):\n")
1080#'       str(input$image_hover)
1081#'     })
1082#'     output$image_brushinfo <- renderPrint({
1083#'       cat("Brush (debounced):\n")
1084#'       str(input$image_brush)
1085#'     })
1086#'   }
1087#' )
1088#'
1089#' }
1090#' @export
1091plotOutput <- function(outputId, width = "100%", height="400px",
1092                       click = NULL, dblclick = NULL, hover = NULL, brush = NULL,
1093                       inline = FALSE) {
1094
1095  # Result is the same as imageOutput, except for HTML class
1096  res <- imageOutput(outputId, width, height, click, dblclick,
1097                     hover, brush, inline)
1098
1099  res$attribs$class <- "shiny-plot-output"
1100  res
1101}
1102
1103#' @param outputId output variable to read the table from
1104#' @rdname renderTable
1105#' @export
1106tableOutput <- function(outputId) {
1107  div(id = outputId, class="shiny-html-output")
1108}
1109
1110dataTableDependency <- list(
1111  htmlDependency(
1112    "datatables", "1.10.5", c(href = "shared/datatables"),
1113    script = "js/jquery.dataTables.min.js"
1114  ),
1115  htmlDependency(
1116    "datatables-bootstrap", "1.10.5", c(href = "shared/datatables"),
1117    stylesheet = c("css/dataTables.bootstrap.css", "css/dataTables.extra.css"),
1118    script = "js/dataTables.bootstrap.js"
1119  )
1120)
1121
1122#' @rdname renderDataTable
1123#' @export
1124dataTableOutput <- function(outputId) {
1125  attachDependencies(
1126    div(id = outputId, class="shiny-datatable-output"),
1127    dataTableDependency
1128  )
1129}
1130
1131#' Create an HTML output element
1132#'
1133#' Render a reactive output variable as HTML within an application page. The
1134#' text will be included within an HTML `div` tag, and is presumed to
1135#' contain HTML content which should not be escaped.
1136#'
1137#' `uiOutput` is intended to be used with `renderUI` on the server
1138#' side. It is currently just an alias for `htmlOutput`.
1139#'
1140#' @param outputId output variable to read the value from
1141#' @param ... Other arguments to pass to the container tag function. This is
1142#'   useful for providing additional classes for the tag.
1143#' @inheritParams textOutput
1144#' @return An HTML output element that can be included in a panel
1145#' @examples
1146#' htmlOutput("summary")
1147#'
1148#' # Using a custom container and class
1149#' tags$ul(
1150#'   htmlOutput("summary", container = tags$li, class = "custom-li-output")
1151#' )
1152#' @export
1153htmlOutput <- function(outputId, inline = FALSE,
1154  container = if (inline) span else div, ...)
1155{
1156  if (anyUnnamed(list(...))) {
1157    warning("Unnamed elements in ... will be replaced with dynamic UI.")
1158  }
1159  container(id = outputId, class="shiny-html-output", ...)
1160}
1161
1162#' @rdname htmlOutput
1163#' @export
1164uiOutput <- htmlOutput
1165
1166#' Create a download button or link
1167#'
1168#' Use these functions to create a download button or link; when clicked, it
1169#' will initiate a browser download. The filename and contents are specified by
1170#' the corresponding [downloadHandler()] defined in the server
1171#' function.
1172#'
1173#' @param outputId The name of the output slot that the `downloadHandler`
1174#'   is assigned to.
1175#' @param label The label that should appear on the button.
1176#' @param class Additional CSS classes to apply to the tag, if any.
1177#' @param icon An [icon()] to appear on the button. Default is `icon("download")`.
1178#' @param ... Other arguments to pass to the container tag function.
1179#'
1180#' @examples
1181#' \dontrun{
1182#' ui <- fluidPage(
1183#'   downloadButton("downloadData", "Download")
1184#' )
1185#'
1186#' server <- function(input, output) {
1187#'   # Our dataset
1188#'   data <- mtcars
1189#'
1190#'   output$downloadData <- downloadHandler(
1191#'     filename = function() {
1192#'       paste("data-", Sys.Date(), ".csv", sep="")
1193#'     },
1194#'     content = function(file) {
1195#'       write.csv(data, file)
1196#'     }
1197#'   )
1198#' }
1199#'
1200#' shinyApp(ui, server)
1201#' }
1202#'
1203#' @aliases downloadLink
1204#' @seealso [downloadHandler()]
1205#' @export
1206downloadButton <- function(outputId,
1207                           label="Download",
1208                           class=NULL,
1209                           ...,
1210                           icon = shiny::icon("download")) {
1211  aTag <- tags$a(id=outputId,
1212                 class=paste('btn btn-default shiny-download-link', class),
1213                 href='',
1214                 target='_blank',
1215                 download=NA,
1216                 validateIcon(icon),
1217                 label, ...)
1218}
1219
1220#' @rdname downloadButton
1221#' @export
1222downloadLink <- function(outputId, label="Download", class=NULL, ...) {
1223  tags$a(id=outputId,
1224         class=paste(c('shiny-download-link', class), collapse=" "),
1225         href='',
1226         target='_blank',
1227         download=NA,
1228         label, ...)
1229}
1230
1231
1232#' Create an icon
1233#'
1234#' Create an icon for use within a page. Icons can appear on their own, inside
1235#' of a button, and/or used with [tabPanel()] and [navbarMenu()].
1236#'
1237#' @param name The name of the icon. A name from either [Font
1238#'   Awesome](https://fontawesome.com/) (when `lib="font-awesome"`) or
1239#'   [Bootstrap
1240#'   Glyphicons](https://getbootstrap.com/docs/3.3/components/#glyphicons) (when
1241#'   `lib="glyphicon"`) may be provided. Note that the `"fa-"` and
1242#'   `"glyphicon-"` prefixes should not appear in name (i.e., the
1243#'   `"fa-calendar"` icon should be referred to as `"calendar"`). A `name` of
1244#'   `NULL` may also be provided to get a raw `<i>` tag with no library attached
1245#'   to it.
1246#' @param class Additional classes to customize the style of an icon (see the
1247#'   [usage examples](https://fontawesome.com/how-to-use) for details on
1248#'   supported styles).
1249#' @param lib The icon library to use. Either `"font-awesome"` or `"glyphicon"`.
1250#' @param ... Arguments passed to the `<i>` tag of [htmltools::tags].
1251#'
1252#' @return An `<i>` (icon) HTML tag.
1253#'
1254#' @seealso For lists of available icons, see <https://fontawesome.com/icons>
1255#'   and <https://getbootstrap.com/docs/3.3/components/#glyphicons>
1256#'
1257#' @examples
1258#' # add an icon to a submit button
1259#' submitButton("Update View", icon = icon("redo"))
1260#'
1261#' navbarPage("App Title",
1262#'   tabPanel("Plot", icon = icon("bar-chart-o")),
1263#'   tabPanel("Summary", icon = icon("list-alt")),
1264#'   tabPanel("Table", icon = icon("table"))
1265#' )
1266#' @export
1267icon <- function(name, class = NULL, lib = "font-awesome", ...) {
1268
1269  # A NULL name allows for a generic <i> not tied to any library
1270  if (is.null(name)) {
1271    lib <- "none"
1272  }
1273
1274  switch(
1275    lib %||% "",
1276    "none" = iconTag(name, class = class, ...),
1277    "font-awesome" = fontawesome::fa_i(name = name, class = class, ...),
1278    "glyphicon" = iconTag(
1279      name, class = "glyphicon", class = paste0("glyphicon-", name),
1280      class = class, ...
1281    ),
1282    stop("Unknown icon library: ", lib, ". See `?icon` for supported libraries.")
1283  )
1284}
1285
1286iconTag <- function(name, ...) {
1287  htmltools::browsable(
1288    tags$i(..., role = "presentation", `aria-label` = paste(name, "icon"))
1289  )
1290}
1291