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