R/dashboardSidebar.R

In shinydashboard: Create Dashboards with 'Shiny'

#' Create a dashboard sidebar.
#'
#' A dashboard sidebar typically contains a [sidebarMenu()], although
#' it may also contain a [sidebarSearchForm()], or other Shiny inputs.
#'
#' @param ... Items to put in the sidebar.
#' @param disable If `TRUE`, the sidebar will be disabled.
#' @param width The width of the sidebar. This must either be a number which
#'   specifies the width in pixels, or a string that specifies the width in CSS
#'   units.
#' @param collapsed If `TRUE`, the sidebar will be collapsed on app startup.
#'
#' @seealso [sidebarMenu()]
#'
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#' header <- dashboardHeader()
#'
#' sidebar <- dashboardSidebar(
#'   sidebarUserPanel("User Name",
#'     subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"),
#'     # Image file should be in www/ subdir
#'     image = "userimage.png"
#'   ),
#'   sidebarSearchForm(label = "Enter a number", "searchText", "searchButton"),
#'   sidebarMenu(
#'     # Setting id makes input$tabs give the tabName of currently-selected tab
#'     id = "tabs",
#'     menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
#'     menuItem("Widgets", icon = icon("th"), tabName = "widgets", badgeLabel = "new",
#'              badgeColor = "green"),
#'     menuItem("Charts", icon = icon("bar-chart-o"),
#'       menuSubItem("Sub-item 1", tabName = "subitem1"),
#'       menuSubItem("Sub-item 2", tabName = "subitem2")
#'     )
#'   )
#' )
#'
#' body <- dashboardBody(
#'   tabItems(
#'     tabItem("dashboard",
#'       div(p("Dashboard tab content"))
#'     ),
#'     tabItem("widgets",
#'       "Widgets tab content"
#'     ),
#'     tabItem("subitem1",
#'       "Sub-item 1 tab content"
#'     ),
#'     tabItem("subitem2",
#'       "Sub-item 2 tab content"
#'     )
#'   )
#' )
#'
#' shinyApp(
#'   ui = dashboardPage(header, sidebar, body),
#'   server = function(input, output) { }
#' )
#' }
#' @export
dashboardSidebar <- function(
  ...,
  disable = FALSE,
  width = NULL,
  collapsed = FALSE
) {
  width <- validateCssUnit(width)

  # Set up custom CSS for custom width
  custom_css <- NULL
  if (!is.null(width)) {
    # This CSS is derived from the sidebar-related instances of '230px' (the
    # default sidebar width) from inst/AdminLTE/AdminLTE.css. One difference is
    # that instead making changes to the global settings, we've put them in a
    # media query (min-width: 768px), so that it won't override other media
    # queries (like max-width: 767px) that work for narrower screens.
    custom_css <- tags$head(tags$style(HTML(gsub(
      "_WIDTH_",
      width,
      fixed = TRUE,
      '
      .main-sidebar, .left-side {
        width: _WIDTH_;
      }
      @media (min-width: 768px) {
        .content-wrapper,
        .right-side,
        .main-footer {
          margin-left: _WIDTH_;
        }
        .main-sidebar,
        .left-side {
          width: _WIDTH_;
        }
      }
      @media (max-width: 767px) {
        .sidebar-open .content-wrapper,
        .sidebar-open .right-side,
        .sidebar-open .main-footer {
          -webkit-transform: translate(_WIDTH_, 0);
          -ms-transform: translate(_WIDTH_, 0);
          -o-transform: translate(_WIDTH_, 0);
          transform: translate(_WIDTH_, 0);
        }
      }
      @media (max-width: 767px) {
        .main-sidebar,
        .left-side {
          -webkit-transform: translate(-_WIDTH_, 0);
          -ms-transform: translate(-_WIDTH_, 0);
          -o-transform: translate(-_WIDTH_, 0);
          transform: translate(-_WIDTH_, 0);
        }
      }
      @media (min-width: 768px) {
        .sidebar-collapse .main-sidebar,
        .sidebar-collapse .left-side {
          -webkit-transform: translate(-_WIDTH_, 0);
          -ms-transform: translate(-_WIDTH_, 0);
          -o-transform: translate(-_WIDTH_, 0);
          transform: translate(-_WIDTH_, 0);
        }
      }
    '
    ))))
  }

  # If we're restoring a bookmarked app, this holds the value of whether or not the
  # sidebar was collapsed. If this is not the case, the default is whatever the user
  # specified in the `collapsed` argument.
  dataValue <- shiny::restoreInput(id = "sidebarCollapsed", default = collapsed)
  if (disable) dataValue <- TRUE # this is a workaround to fix #209
  dataValueString <- if (dataValue) "true" else "false"

  # The expanded/collapsed state of the sidebar is actually set by adding a
  # class to the body (not to the sidebar). However, it makes sense for the
  # `collapsed` argument to belong in this function. So this information is
  # just passed through (as the `data-collapsed` attribute) to the
  # `dashboardPage()` function
  tags$aside(
    id = "sidebarCollapsed",
    class = "main-sidebar",
    `data-collapsed` = dataValueString,
    custom_css,
    tags$section(
      id = "sidebarItemExpanded",
      class = "sidebar",
      `data-disable` = if (disable) 1 else NULL,
      list(...)
    )
  )
}

#' A panel displaying user information in a sidebar
#'
#' @param name Name of the user.
#' @param subtitle Text or HTML to be shown below the name.
#' @param image A filename or URL to use for an image of the person. If it is a
#'   local file, the image should be contained under the www/ subdirectory of
#'   the application.
#'
#' @family sidebar items
#'
#' @seealso [dashboardSidebar()] for example usage.
#'
#' @export
sidebarUserPanel <- function(name, subtitle = NULL, image = NULL) {
  div(
    class = "user-panel",
    if (!is.null(image)) {
      div(
        class = "pull-left image",
        img(src = image, class = "img-circle", alt = "User Image")
      )
    },
    div(
      class = "pull-left info",
      # If no image, move text to the left: by overriding default left:55px
      style = if (is.null(image)) "left: 4px",
      p(name),
      subtitle
    )
  )
}

#' Create a search form to place in a sidebar
#'
#' A search form consists of a text input field and a search button.
#'
#' @param textId Shiny input ID for the text input box.
#' @param buttonId Shiny input ID for the search button (which functions like an
#'   [shiny::actionButton()]).
#' @param label Text label to display inside the search box.
#' @param icon An icon tag, created by [shiny::icon()].
#'
#' @family sidebar items
#'
#' @seealso [dashboardSidebar()] for example usage.
#'
#' @export
sidebarSearchForm <- function(
  textId,
  buttonId,
  label = "Search...",
  icon = shiny::icon("search")
) {
  tags$form(
    class = "sidebar-form",
    div(
      class = "input-group",
      tags$input(
        id = textId,
        type = "text",
        class = "form-control",
        placeholder = label,
        style = "margin: 5px;"
      ),
      span(
        class = "input-group-btn",
        tags$button(
          id = buttonId,
          type = "button",
          class = "btn btn-flat action-button",
          icon
        )
      )
    )
  )
}

#' Create a dashboard sidebar menu and menu items.
#'
#' A `dashboardSidebar` can contain a `sidebarMenu`. A
#' `sidebarMenu` contains `menuItem`s, and they can in turn contain
#' `menuSubItem`s.
#'
#' Menu items (and similarly, sub-items) should have a value for either
#' `href` or `tabName`; otherwise the item would do nothing. If it has
#' a value for `href`, then the item will simply be a link to that value.
#'
#' If a `menuItem` has a non-NULL `tabName`, then the `menuItem`
#' will behave like a tab -- in other words, clicking on the `menuItem`
#' will bring a corresponding `tabItem` to the front, similar to a
#' [shiny::tabPanel()]. One important difference between a
#' `menuItem` and a `tabPanel` is that, for a `menuItem`, you
#' must also supply a corresponding `tabItem` with the same value for
#' `tabName`, whereas for a `tabPanel`, no `tabName` is needed.
#' (This is because the structure of a `tabPanel` is such that the tab name
#' can be automatically generated.) Sub-items are also able to activate
#' `tabItem`s.
#'
#' Menu items (but not sub-items) also may have an optional badge. A badge is a
#' colored oval containing text.
#'
#' @param text Text to show for the menu item.
#' @param id For `sidebarMenu`, if `id` is present, this id will be
#'   used for a Shiny input value, and it will report which tab is selected. For
#'   example, if `id="tabs"`, then `input$tabs` will be the
#'   `tabName` of the currently-selected tab. If you want to be able to
#'   bookmark and restore the selected tab, an `id` is required.
#' @param icon An icon tag, created by [shiny::icon()]. If
#'   `NULL`, don't display an icon.
#' @param badgeLabel A label for an optional badge. Usually a number or a short
#'   word like "new".
#' @param badgeColor A color for the badge. Valid colors are listed in
#'   [validColors].
#' @param href An link address. Not compatible with `tabName`.
#' @param tabName The name of a tab that this menu item will activate. Not
#'   compatible with `href`.
#' @param newtab If `href` is supplied, should the link open in a new
#'   browser tab?
#' @param selected If `TRUE`, this `menuItem` or `menuSubItem`
#'   will start selected. If no item have `selected=TRUE`, then the first
#'   `menuItem` will start selected.
#' @param expandedName A unique name given to each `menuItem` that serves
#'   to indicate which one (if any) is currently expanded. (This is only applicable
#'   to `menuItem`s that have children and it is mostly only useful for
#'   bookmarking state.)
#' @param startExpanded Should this `menuItem` be expanded on app startup?
#'   (This is only applicable to `menuItem`s that have children, and only
#'   one of these can be expanded at any given time).
#' @param ... For menu items, this may consist of [menuSubItem()]s.
#' @param .list An optional list containing items to put in the menu Same as the
#'   `...` arguments, but in list format. This can be useful when working
#'   with programmatically generated items.
#'
#' @family sidebar items
#'
#' @seealso [dashboardSidebar()] for example usage. For
#'   dynamically-generated sidebar menus, see [renderMenu()] and
#'   [sidebarMenuOutput()].
#'
#' @export
sidebarMenu <- function(..., id = NULL, .list = NULL) {
  items <- c(list(...), .list)

  # Restore a selected tab from bookmarked state. Bookmarking was added in Shiny
  # 0.14.
  if (utils::packageVersion("shiny") >= "0.14" && !is.null(id)) {
    selectedTabName <- shiny::restoreInput(id = id, default = NULL)
    if (!is.null(selectedTabName)) {
      # Find the menuItem or menuSubItem with a `tabname` that matches
      # `selectedTab`. Then set `data-start-selected` to 1 for that tab and 0
      # for all others.

      # Given a menuItem and a logical value for `selected`, set the
      # data-start-selected attribute to the appropriate value (1 or 0).
      selectItem <- function(item, selected) {
        # in the cases that the children of menuItems are NOT menuSubItems
        if (is.atomic(item) || length(item$children) == 0) {
          return(item)
        }

        if (selected) value <- 1 else value <- NULL

        # Try to find the child <a data-toggle="tab"> tag and then set
        # data-start-selected="1". The []<- assignment is to preserve
        # attributes.
        item$children[] <- lapply(item$children, function(child) {
          # Find the appropriate <a> child
          if (tagMatches(child, name = "a", `data-toggle` = "tab")) {
            child$attribs[["data-start-selected"]] <- value
          }

          child
        })

        item
      }

      # Given a menuItem and a tabName (string), return TRUE if the menuItem has
      # that tabName, FALSE otherwise.
      itemHasTabName <- function(item, tabName) {
        # Must be a <li> tag
        if (!tagMatches(item, name = "li")) {
          return(FALSE)
        }

        # Look for an <a> child with data-value=tabName
        found <- FALSE
        lapply(item$children, function(child) {
          if (tagMatches(child, name = "a", `data-value` = tabName)) {
            found <<- TRUE
          }
        })

        found
      }

      # Actually do the work of marking selected tabs and unselected ones.
      items <- lapply(items, function(item) {
        if (tagMatches(item, name = "li", class = "treeview")) {
          # Search in menuSubItems
          item$children[] <- lapply(item$children[], function(subItem) {
            if (tagMatches(subItem, name = "ul", class = "treeview-menu")) {
              subItem$children[] <- lapply(
                subItem$children,
                function(subSubItem) {
                  selected <- itemHasTabName(subSubItem, selectedTabName)
                  selectItem(subSubItem, selected)
                }
              )
            }
            subItem
          })
        } else {
          # Regular menuItems
          selected <- itemHasTabName(item, selectedTabName)
          item <- selectItem(item, selected)
        }

        item
      })
    }
    # This is a 0 height div, whose only purpose is to hold the tabName of the currently
    # selected menuItem in its `data-value` attribute. This is the DOM element that is
    # bound to tabItemInputBinding in the JS side.
    items[[length(items) + 1]] <- div(
      id = id,
      class = "sidebarMenuSelectedTabItem",
      `data-value` = selectedTabName %OR% "null"
    )
  }

  # Use do.call so that we don't add an extra list layer to the children of the
  # ul tag. This makes it a little easier to traverse the tree to search for
  # selected items to restore.
  do.call(tags$ul, c(class = "sidebar-menu", items))
}

#' @rdname sidebarMenu
#' @export
menuItem <- function(
  text,
  ...,
  icon = NULL,
  badgeLabel = NULL,
  badgeColor = "green",
  tabName = NULL,
  href = NULL,
  newtab = TRUE,
  selected = NULL,
  expandedName = as.character(gsub("[[:space:]]", "", text)),
  startExpanded = FALSE
) {
  subItems <- list(...)

  if (!is.null(icon)) tagAssert(icon, type = "i")
  if (!is.null(href) + !is.null(tabName) + (length(subItems) > 0) != 1) {
    stop("Must have either href, tabName, or sub-items (contained in ...).")
  }

  if (!is.null(badgeLabel) && length(subItems) != 0) {
    stop("Can't have both badge and subItems")
  }
  validateColor(badgeColor)

  # If there's a tabName, set up the correct href and <a> target
  isTabItem <- FALSE
  target <- NULL
  if (!is.null(tabName)) {
    validateTabName(tabName)
    isTabItem <- TRUE
    href <- paste0("#shiny-tab-", tabName)
  } else if (is.null(href)) {
    href <- "#"
  } else {
    # If supplied href, set up <a> tag's target
    if (newtab) target <- "_blank"
  }

  # Generate badge if needed
  if (!is.null(badgeLabel)) {
    badgeTag <- tags$small(
      class = paste0("badge pull-right bg-", badgeColor),
      badgeLabel
    )
  } else {
    badgeTag <- NULL
  }

  # If no subitems, return a pretty simple tag object
  if (length(subItems) == 0) {
    return(
      tags$li(
        a(
          href = href,
          `data-toggle` = if (isTabItem) "tab",
          `data-value` = if (!is.null(tabName)) tabName,
          `data-start-selected` = if (isTRUE(selected)) 1 else NULL,
          target = target,
          icon,
          span(text),
          badgeTag
        )
      )
    )
  }

  # If we're restoring a bookmarked app, this holds the value of what menuItem (if any)
  # was expanded (this has be to stored separately from the selected menuItem, since
  # these actually independent in AdminLTE). If no menuItem was expanded, `dataExpanded`
  # is NULL. However, we want to this input to get passed on (and not dropped), so we
  # do `%OR% ""` to assure this.
  default <- if (startExpanded) expandedName else ""
  dataExpanded <- shiny::restoreInput(id = "sidebarItemExpanded", default) %OR%
    ""

  # If `dataExpanded` is not the empty string, we need to check that it is eqaul to the
  # this menuItem's `expandedName``
  isExpanded <- nzchar(dataExpanded) && (dataExpanded == expandedName)

  tags$li(
    class = "treeview",
    a(
      href = href,
      icon,
      span(text),
      shiny::icon("angle-left", class = "pull-right")
    ),
    # Use do.call so that we don't add an extra list layer to the children of the
    # ul tag. This makes it a little easier to traverse the tree to search for
    # selected items to restore.
    do.call(
      tags$ul,
      c(
        class = paste0("treeview-menu", if (isExpanded) " menu-open" else ""),
        style = paste0("display: ", if (isExpanded) "block;" else "none;"),
        `data-expanded` = expandedName,
        subItems
      )
    )
  )
}

#' @rdname sidebarMenu
#' @export
menuSubItem <- function(
  text,
  tabName = NULL,
  href = NULL,
  newtab = TRUE,
  icon = shiny::icon("angle-double-right"),
  selected = NULL
) {
  if (!is.null(href) && !is.null(tabName)) {
    stop("Can't specify both href and tabName")
  }

  # If there's a tabName, set up the correct href
  isTabItem <- FALSE
  target <- NULL
  if (!is.null(tabName)) {
    validateTabName(tabName)
    isTabItem <- TRUE
    href <- paste0("#shiny-tab-", tabName)
  } else if (is.null(href)) {
    href <- "#"
  } else {
    # If supplied href, set up <a> tag's target
    if (newtab) target <- "_blank"
  }

  tags$li(
    a(
      href = href,
      `data-toggle` = if (isTabItem) "tab",
      `data-value` = if (!is.null(tabName)) tabName,
      `data-start-selected` = if (isTRUE(selected)) 1 else NULL,
      target = target,
      icon,
      text
    )
  )
}