R/bootstrap-layout.R

Defines functions fluidPage fluidRow fixedPage fixedRow column titlePanel sidebarLayout sidebarPanel mainPanel verticalLayout flowLayout inputPanel splitLayout fillRow fillCol flexfill css empty

Documented in column fillCol fillRow fixedPage fixedRow flowLayout fluidPage fluidRow inputPanel mainPanel sidebarLayout sidebarPanel splitLayout titlePanel verticalLayout

#' Create a page with fluid layout
#'
#' Functions for creating fluid page layouts. A fluid page layout consists of
#' rows which in turn include columns. Rows exist for the purpose of making sure
#' their elements appear on the same line (if the browser has adequate width).
#' Columns exist for the purpose of defining how much horizontal space within a
#' 12-unit wide grid it's elements should occupy. Fluid pages scale their
#' components in realtime to fill all available browser width.
#'
#' @param ... Elements to include within the page
#' @param title The browser window title (defaults to the host URL of the page).
#'   Can also be set as a side effect of the [titlePanel()] function.
#' @param responsive This option is deprecated; it is no longer optional with
#'   Bootstrap 3.
#' @param theme Alternative Bootstrap stylesheet (normally a css file within the
#'   www directory). For example, to use the theme located at
#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
#'
#' @return A UI defintion that can be passed to the [shinyUI] function.
#'
#' @details To create a fluid page use the `fluidPage` function and include
#'   instances of `fluidRow` and [column()] within it. As an
#'   alternative to low-level row and column functions you can also use
#'   higher-level layout functions like [sidebarLayout()].
#'
#' @note See the [
#'   Shiny-Application-Layout-Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fluid
#'   pages.
#'
#' @family layout functions
#' @seealso [column()]
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' # Example of UI with fluidPage
#' ui <- fluidPage(
#'
#'   # Application title
#'   titlePanel("Hello Shiny!"),
#'
#'   sidebarLayout(
#'
#'     # Sidebar with a slider input
#'     sidebarPanel(
#'       sliderInput("obs",
#'                   "Number of observations:",
#'                   min = 0,
#'                   max = 1000,
#'                   value = 500)
#'     ),
#'
#'     # Show a plot of the generated distribution
#'     mainPanel(
#'       plotOutput("distPlot")
#'     )
#'   )
#' )
#'
#' # Server logic
#' server <- function(input, output) {
#'   output$distPlot <- renderPlot({
#'     hist(rnorm(input$obs))
#'   })
#' }
#'
#' # Complete app with UI and server components
#' shinyApp(ui, server)
#'
#'
#' # UI demonstrating column layouts
#' ui <- fluidPage(
#'   title = "Hello Shiny!",
#'   fluidRow(
#'     column(width = 4,
#'       "4"
#'     ),
#'     column(width = 3, offset = 2,
#'       "3 offset 2"
#'     )
#'   )
#' )
#'
#' shinyApp(ui, server = function(input, output) { })
#' }
#' @rdname fluidPage
#' @export
fluidPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
  bootstrapPage(div(class = "container-fluid", ...),
                title = title,
                responsive = responsive,
                theme = theme)
}


#' @rdname fluidPage
#' @export
fluidRow <- function(...) {
  div(class = "row", ...)
}

#' Create a page with a fixed layout
#'
#' Functions for creating fixed page layouts. A fixed page layout consists of
#' rows which in turn include columns. Rows exist for the purpose of making sure
#' their elements appear on the same line (if the browser has adequate width).
#' Columns exist for the purpose of defining how much horizontal space within a
#' 12-unit wide grid it's elements should occupy. Fixed pages limit their width
#' to 940 pixels on a typical display, and 724px or 1170px on smaller and larger
#' displays respectively.
#'
#' @param ... Elements to include within the container
#' @param title The browser window title (defaults to the host URL of the page)
#' @param responsive This option is deprecated; it is no longer optional with
#'   Bootstrap 3.
#' @param theme Alternative Bootstrap stylesheet (normally a css file within the
#'   www directory). For example, to use the theme located at
#'   `www/bootstrap.css` you would use `theme = "bootstrap.css"`.
#'
#' @return A UI defintion that can be passed to the [shinyUI] function.
#'
#' @details To create a fixed page use the `fixedPage` function and include
#'   instances of `fixedRow` and [column()] within it. Note that
#'   unlike [fluidPage()], fixed pages cannot make use of higher-level
#'   layout functions like `sidebarLayout`, rather, all layout must be done
#'   with `fixedRow` and `column`.
#'
#' @note See the [
#'   Shiny Application Layout Guide](http://shiny.rstudio.com/articles/layout-guide.html) for additional details on laying out fixed
#'   pages.
#'
#' @family layout functions
#'
#' @seealso [column()]
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fixedPage(
#'   title = "Hello, Shiny!",
#'   fixedRow(
#'     column(width = 4,
#'       "4"
#'     ),
#'     column(width = 3, offset = 2,
#'       "3 offset 2"
#'     )
#'   )
#' )
#'
#' shinyApp(ui, server = function(input, output) { })
#' }
#'
#' @rdname fixedPage
#' @export
fixedPage <- function(..., title = NULL, responsive = NULL, theme = NULL) {
  bootstrapPage(div(class = "container", ...),
                title = title,
                responsive = responsive,
                theme = theme)
}

#' @rdname fixedPage
#' @export
fixedRow <- function(...) {
  div(class = "row", ...)
}


#' Create a column within a UI definition
#'
#' Create a column for use within a  [fluidRow()] or
#' [fixedRow()]
#'
#' @param width The grid width of the column (must be between 1 and 12)
#' @param ... Elements to include within the column
#' @param offset The number of columns to offset this column from the end of the
#'   previous column.
#'
#' @return A column that can be included within a
#'   [fluidRow()] or [fixedRow()].
#'
#'
#' @seealso [fluidRow()], [fixedRow()].
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   fluidRow(
#'     column(4,
#'       sliderInput("obs", "Number of observations:",
#'                   min = 1, max = 1000, value = 500)
#'     ),
#'     column(8,
#'       plotOutput("distPlot")
#'     )
#'   )
#' )
#'
#' server <- function(input, output) {
#'   output$distPlot <- renderPlot({
#'     hist(rnorm(input$obs))
#'   })
#' }
#'
#' shinyApp(ui, server)
#'
#'
#'
#' ui <- fluidPage(
#'   fluidRow(
#'     column(width = 4,
#'       "4"
#'     ),
#'     column(width = 3, offset = 2,
#'       "3 offset 2"
#'     )
#'   )
#' )
#' shinyApp(ui, server = function(input, output) { })
#' }
#' @export
column <- function(width, ..., offset = 0) {

  if (!is.numeric(width) || (width < 1) || (width > 12))
    stop("column width must be between 1 and 12")

  colClass <- paste0("col-sm-", width)
  if (offset > 0) {
    # offset-md-x is for bootstrap 4 forward compat
    # (every size tier has been bumped up one level)
    # https://github.com/twbs/bootstrap/blob/74b8fe7/docs/4.3/migration/index.html#L659
    colClass <- paste0(colClass, " offset-md-", offset, " col-sm-offset-", offset)
  }
  div(class = colClass, ...)
}


#' Create a panel containing an application title.
#'
#' @param title An application title to display
#' @param windowTitle The title that should be displayed by the browser window.
#'
#' @details Calling this function has the side effect of including a
#'   `title` tag within the head. You can also specify a page title
#'   explicitly using the `title` parameter of the top-level page function.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   titlePanel("Hello Shiny!")
#' )
#' shinyApp(ui, server = function(input, output) { })
#' }
#' @export
titlePanel <- function(title, windowTitle=title) {
  tagList(
    tags$head(tags$title(windowTitle)),
    h2(title)
  )
}

#' Layout a sidebar and main area
#'
#' Create a layout (`sidebarLayout()`) with a sidebar (`sidebarPanel()`) and
#' main area (`mainPanel()`). The sidebar is displayed with a distinct
#' background color and typically contains input controls. The main
#' area occupies 2/3 of the horizontal width and typically contains outputs.
#'
#' @param sidebarPanel The `sidebarPanel()` containing input controls.
#' @param mainPanel The `mainPanel()` containing outputs.
#' @param position The position of the sidebar relative to the main area ("left"
#'   or "right").
#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
#'   layout.
#' @param width The width of the sidebar and main panel. By default, the
#'   sidebar takes up 1/3 of the width, and the main panel 2/3. The total
#'   width must be 12 or less.
#' @param ... Output elements to include in the sidebar/main panel.
#'
#' @family layout functions
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' # Define UI
#' ui <- fluidPage(
#'
#'   # Application title
#'   titlePanel("Hello Shiny!"),
#'
#'   sidebarLayout(
#'
#'     # Sidebar with a slider input
#'     sidebarPanel(
#'       sliderInput("obs",
#'                   "Number of observations:",
#'                   min = 0,
#'                   max = 1000,
#'                   value = 500)
#'     ),
#'
#'     # Show a plot of the generated distribution
#'     mainPanel(
#'       plotOutput("distPlot")
#'     )
#'   )
#' )
#'
#' # Server logic
#' server <- function(input, output) {
#'   output$distPlot <- renderPlot({
#'     hist(rnorm(input$obs))
#'   })
#' }
#'
#' # Complete app with UI and server components
#' shinyApp(ui, server)
#' }
#' @export
sidebarLayout <- function(sidebarPanel,
                          mainPanel,
                          position = c("left", "right"),
                          fluid = TRUE) {

  # determine the order
  position <- match.arg(position)
  if (position == "left") {
    firstPanel <- sidebarPanel
    secondPanel <- mainPanel
  }
  else if (position == "right") {
    firstPanel <- mainPanel
    secondPanel <- sidebarPanel
  }

  # return as as row
  if (fluid)
    fluidRow(firstPanel, secondPanel)
  else
    fixedRow(firstPanel, secondPanel)
}

#' @export
#' @rdname sidebarLayout
sidebarPanel <- function(..., width = 4) {
  div(class=paste0("col-sm-", width),
    tags$form(class="well",
      ...
    )
  )
}

#' @export
#' @rdname sidebarLayout
mainPanel <- function(..., width = 8) {
  div(class=paste0("col-sm-", width),
    ...
  )
}

#' Lay out UI elements vertically
#'
#' Create a container that includes one or more rows of content (each element
#' passed to the container will appear on it's own line in the UI)
#'
#' @param ... Elements to include within the container
#' @param fluid `TRUE` to use fluid layout; `FALSE` to use fixed
#'   layout.
#'
#' @family layout functions
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   verticalLayout(
#'     a(href="http://example.com/link1", "Link One"),
#'     a(href="http://example.com/link2", "Link Two"),
#'     a(href="http://example.com/link3", "Link Three")
#'   )
#' )
#' shinyApp(ui, server = function(input, output) { })
#' }
#' @export
verticalLayout <- function(..., fluid = TRUE) {
  lapply(list(...), function(row) {
    col <- column(12, row)
    if (fluid)
      fluidRow(col)
    else
      fixedRow(col)
  })
}

#' Flow layout
#'
#' Lays out elements in a left-to-right, top-to-bottom arrangement. The elements
#' on a given row will be top-aligned with each other. This layout will not work
#' well with elements that have a percentage-based width (e.g.
#' [plotOutput()] at its default setting of `width = "100%"`).
#'
#' @param ... Unnamed arguments will become child elements of the layout. Named
#'   arguments will become HTML attributes on the outermost tag.
#' @param cellArgs Any additional attributes that should be used for each cell
#'   of the layout.
#'
#' @family layout functions
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- flowLayout(
#'   numericInput("rows", "How many rows?", 5),
#'   selectInput("letter", "Which letter?", LETTERS),
#'   sliderInput("value", "What value?", 0, 100, 50)
#' )
#' shinyApp(ui, server = function(input, output) { })
#' }
#' @export
flowLayout <- function(..., cellArgs = list()) {

  children <- list(...)
  childIdx <- !nzchar(names(children) %OR% character(length(children)))
  attribs <- children[!childIdx]
  children <- children[childIdx]

  do.call(tags$div, c(list(class = "shiny-flow-layout"),
    attribs,
    lapply(children, function(x) {
      do.call(tags$div, c(cellArgs, list(x)))
    })
  ))
}

#' Input panel
#'
#' A [flowLayout()] with a grey border and light grey background,
#' suitable for wrapping inputs.
#'
#' @param ... Input controls or other HTML elements.
#' @export
inputPanel <- function(...) {
  div(class = "shiny-input-panel",
    flowLayout(...)
  )
}

#' Split layout
#'
#' Lays out elements horizontally, dividing the available horizontal space into
#' equal parts (by default).
#'
#' @param ... Unnamed arguments will become child elements of the layout. Named
#'   arguments will become HTML attributes on the outermost tag.
#' @param cellWidths Character or numeric vector indicating the widths of the
#'   individual cells. Recycling will be used if needed. Character values will
#'   be interpreted as CSS lengths (see [validateCssUnit()]), numeric
#'   values as pixels.
#' @param cellArgs Any additional attributes that should be used for each cell
#'   of the layout.
#'
#' @family layout functions
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' # Server code used for all examples
#' server <- function(input, output) {
#'   output$plot1 <- renderPlot(plot(cars))
#'   output$plot2 <- renderPlot(plot(pressure))
#'   output$plot3 <- renderPlot(plot(AirPassengers))
#' }
#'
#' # Equal sizing
#' ui <- splitLayout(
#'   plotOutput("plot1"),
#'   plotOutput("plot2")
#' )
#' shinyApp(ui, server)
#'
#' # Custom widths
#' ui <- splitLayout(cellWidths = c("25%", "75%"),
#'   plotOutput("plot1"),
#'   plotOutput("plot2")
#' )
#' shinyApp(ui, server)
#'
#' # All cells at 300 pixels wide, with cell padding
#' # and a border around everything
#' ui <- splitLayout(
#'   style = "border: 1px solid silver;",
#'   cellWidths = 300,
#'   cellArgs = list(style = "padding: 6px"),
#'   plotOutput("plot1"),
#'   plotOutput("plot2"),
#'   plotOutput("plot3")
#' )
#' shinyApp(ui, server)
#' }
#' @export
splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {

  children <- list(...)
  childIdx <- !nzchar(names(children) %OR% character(length(children)))
  attribs <- children[!childIdx]
  children <- children[childIdx]
  count <- length(children)

  if (length(cellWidths) == 0 || is.na(cellWidths)) {
    cellWidths <- sprintf("%.3f%%", 100 / count)
  }
  cellWidths <- rep(cellWidths, length.out = count)
  cellWidths <- sapply(cellWidths, validateCssUnit)

  do.call(tags$div, c(list(class = "shiny-split-layout"),
    attribs,
    mapply(children, cellWidths, FUN = function(x, w) {
      do.call(tags$div, c(
        list(style = sprintf("width: %s;", w)),
        cellArgs,
        list(x)
      ))
    }, SIMPLIFY = FALSE)
  ))
}

#' Flex Box-based row/column layouts
#'
#' Creates row and column layouts with proportionally-sized cells, using the
#' Flex Box layout model of CSS3. These can be nested to create arbitrary
#' proportional-grid layouts. **Warning:** Flex Box is not well supported
#' by Internet Explorer, so these functions should only be used where modern
#' browsers can be assumed.
#'
#' @details If you try to use `fillRow` and `fillCol` inside of other
#'   Shiny containers, such as [sidebarLayout()],
#'   [navbarPage()], or even `tags$div`, you will probably find
#'   that they will not appear. This is due to `fillRow` and `fillCol`
#'   defaulting to `height="100%"`, which will only work inside of
#'   containers that have determined their own size (rather than shrinking to
#'   the size of their contents, as is usually the case in HTML).
#'
#'   To avoid this problem, you have two options:
#'   \itemize{
#'     \item only use `fillRow`/`fillCol` inside of `fillPage`,
#'       `fillRow`, or `fillCol`
#'     \item provide an explicit `height` argument to
#'       `fillRow`/`fillCol`
#'   }
#'
#' @param ... UI objects to put in each row/column cell; each argument will
#'   occupy a single cell. (To put multiple items in a single cell, you can use
#'   [tagList()] or [div()] to combine them.) Named
#'   arguments will be used as attributes on the `div` element that
#'   encapsulates the row/column.
#' @param flex Determines how space should be distributed to the cells. Can be a
#'   single value like `1` or `2` to evenly distribute the available
#'   space; or use a vector of numbers to specify the proportions. For example,
#'   `flex = c(2, 3)` would cause the space to be split 40%/60% between
#'   two cells. NA values will cause the corresponding cell to be sized
#'   according to its contents (without growing or shrinking).
#' @param width,height The total amount of width and height to use for the
#'   entire row/column. For the default height of `"100%"` to be
#'   effective, the parent must be `fillPage`, another
#'   `fillRow`/`fillCol`, or some other HTML element whose height is
#'   not determined by the height of its contents.
#'
#' @examples
#' # Only run this example in interactive R sessions.
#' if (interactive()) {
#'
#' ui <- fillPage(fillRow(
#'   plotOutput("plotLeft", height = "100%"),
#'   fillCol(
#'     plotOutput("plotTopRight", height = "100%"),
#'     plotOutput("plotBottomRight", height = "100%")
#'   )
#' ))
#'
#' server <- function(input, output, session) {
#'   output$plotLeft <- renderPlot(plot(cars))
#'   output$plotTopRight <- renderPlot(plot(pressure))
#'   output$plotBottomRight <- renderPlot(plot(AirPassengers))
#' }
#'
#' shinyApp(ui, server)
#'
#' }
#' @export
fillRow <- function(..., flex = 1, width = "100%", height = "100%") {
  flexfill(..., direction = "row", flex = flex, width = width, height = height)
}

#' @rdname fillRow
#' @export
fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
  flexfill(..., direction = "column", flex = flex, width = width, height = height)
}

flexfill <- function(..., direction, flex, width = width, height = height) {
  children <- list(...)
  attrs <- list()

  if (!is.null(names(children))) {
    attrs <- children[names(children) != ""]
    children <- children[names(children) == ""]
  }

  if (length(flex) > length(children)) {
    flex <- flex[seq_along(children)]
  }

  # The dimension along the main axis
  main <- switch(direction,
    row = "width",
    "row-reverse" = "width",
    column = "height",
    "column-reverse" = "height",
    stop("Unexpected direction")
  )
  # The dimension along the cross axis
  cross <- if (main == "width") "height" else "width"

  divArgs <- list(
    class = sprintf("flexfill-container flexfill-container-%s", direction),
    style = css(
      display = "-webkit-flex",
      display = "-ms-flexbox",
      display = "flex",
      .webkit.flex.direction = direction,
      .ms.flex.direction = direction,
      flex.direction = direction,
      width = validateCssUnit(width),
      height = validateCssUnit(height)
    ),
    mapply(children, flex, FUN = function(el, flexValue) {
      if (is.na(flexValue)) {
        # If the flex value is NA, then put the element in a simple flex item
        # that sizes itself (along the main axis) to its contents
        tags$div(
          class = "flexfill-item",
          style = css(
            position = "relative",
            "-webkit-flex" = "none",
            "-ms-flex" = "none",
            flex = "none"
          ),
          style = paste0(main, ":auto;", cross, ":100%;"),
          el
        )
      } else if (is.numeric(flexValue)) {
        # If the flex value is numeric, we need *two* wrapper divs. The outer is
        # the flex item, and the inner is an absolute-fill div that is needed to
        # make percentage-based sizing for el work correctly. I don't understand
        # why this is needed but the truth is probably in this SO page:
        # http://stackoverflow.com/questions/15381172/css-flexbox-child-height-100
        tags$div(
          class = "flexfill-item",
          style = css(
            position = "relative",
            "-webkit-flex" = flexValue,
            "-ms-flex" = flexValue,
            flex = flexValue,
            width = "100%", height = "100%"
          ),
          tags$div(
            class = "flexfill-item-inner",
            style = css(
              position = "absolute",
              top = 0, left = 0, right = 0, bottom = 0
            ),
            el
          )
        )
      } else {
        stop("Unexpected flex argument: ", flexValue)
      }
    }, SIMPLIFY = FALSE, USE.NAMES = FALSE)
  )
  do.call(tags$div, c(attrs, divArgs))
}

css <- function(..., collapse_ = "") {
  props <- list(...)
  if (length(props) == 0) {
    return("")
  }

  if (is.null(names(props)) || any(names(props) == "")) {
    stop("cssList expects all arguments to be named")
  }

  # Necessary to make factors show up as level names, not numbers
  props[] <- lapply(props, paste, collapse = " ")

  # Drop null args
  props <- props[!sapply(props, empty)]
  if (length(props) == 0) {
    return("")
  }

  # Replace all '.' and '_' in property names to '-'
  names(props) <- gsub("[._]", "-", tolower(gsub("([A-Z])", "-\\1", names(props))))

  # Create "!important" suffix for each property whose name ends with !, then
  # remove the ! from the property name
  important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "")
  names(props) <- sub("!$", "", names(props), perl = TRUE)

  paste0(names(props), ":", props, important, ";", collapse = collapse_)
}

empty <- function(x) {
  length(x) == 0 || (is.character(x) && !any(nzchar(x)))
}
tomkuipers1402/shiny documentation built on Feb. 13, 2020, 7:22 p.m.