Merge pull request #350 from RinteRface/dev

CRAN release 2.3.0

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: bs4Dash
 Type: Package
 Title: A 'Bootstrap 4' Version of 'shinydashboard'
-Version: 2.2.1
+Version: 2.3.0
 Authors@R: c(
   person("David", "Granjon", email = "[email protected]", role = c("aut", "cre")),
   person(family = "RinteRface", role = "cph"),

NAMESPACE

@@ -98,6 +98,7 @@ export(dashboardUser)
 export(dashboardUserItem)
 export(descriptionBlock)
 export(dropdownDivider)
+export(dropdownHeader)
 export(dropdownMenu)
 export(dropdownMenuOutput)
 export(getAdminLTEColors)
@@ -114,6 +115,8 @@ export(menuItemOutput)
 export(menuSubItem)
 export(messageItem)
 export(multiProgressBar)
+export(navbarMenu)
+export(navbarTab)
 export(notificationItem)
 export(pagination)
 export(paginationItem)
@@ -158,6 +161,7 @@ export(updateCard)
 export(updateCardSidebar)
 export(updateControlbar)
 export(updateControlbarMenu)
+export(updateNavbarTabs)
 export(updatePagination)
 export(updateSidebar)
 export(updateTabItems)

NEWS.md

@@ -1,3 +1,25 @@
+# bs4Dash 2.3.0
+
+## New feature
+New navbar navigation menu.
+- `navbarTab()`, `navbarMenu()` and `updateNavbarTabs()` to create navbar navigation. 
+This will close #108. 
+
+## Minor change
+- New `dropdownHeader()` function to display Bootstrap 4 dropdown headers. 
+- Adjust `dropdownDivider()` as it was invisible.
+- `tabItems()` has __.list__ parameter to pass `tabItem()` elements as list.
+- Fix #342: better title alignment in `tabBox()`. Increase padding for card with pills. Thanks @HugoGit39
+for reporting. 
+
+## Bug fixes
+- Fix #349: allow to pass list of `accordionItem()` with `.list` parameter in `accordion()`. Thanks @vladimirstroganov for reporting.
+- Fix #330: allow to use input elements (or any not `menuItem` element) in the sidebar.
+- Fix #343: Refine `help` parameter behavior in `dashboardPage()`. If NULL, no icon is shown. If FALSE, icon and toggle are shown but not checked. If TRUE the toggle is checked.
+
+## Internal
+- Change dark/light switch CSS class for consistency.
+
 # bs4Dash 2.2.1
 
 ## New features

R/cards.R

@@ -636,7 +636,7 @@ cardDropdownItem <- function(..., id = NULL, href = NULL, icon = NULL) {
 #'
 #' @export
 dropdownDivider <- function() {
-  shiny::tags$a(class = "divider")
+  shiny::div(class = "dropdown-divider")
 }
 
 
@@ -1180,7 +1180,7 @@ bs4TabCard <- function(..., id = NULL, selected = NULL, title = NULL, width = 6,
   # add card-tabs class
   boxTag$children[[1]]$attribs$class <- paste0(
     boxTag$children[[1]]$attribs$class,
-    if (solidHeader) {
+    if (solidHeader || type == "pills") {
       " card-tabs"
     } else {
       " card-outline-tabs"
@@ -1190,19 +1190,27 @@ bs4TabCard <- function(..., id = NULL, selected = NULL, title = NULL, width = 6,
   # change header class
   boxTag$children[[1]]$children[[1]]$attribs$class <- paste0(
     boxTag$children[[1]]$children[[1]]$attribs$class,
-    if (solidHeader) {
-      " p-0 pt-1"
-    } else {
-      " p-0 border-bottom-0"
+    if (type != "pills") {
+      if (solidHeader) {
+        " p-0 pt-1"
+      } else {
+        " p-0 border-bottom-0"
+      } 
     }
   )
 
 
   # Remove title and add it to tab list
   titleTag <- boxTag$children[[1]]$children[[1]]$children[[1]]
+  if (type == "tabs") {
+    titleTag$attribs$class <- paste(
+      titleTag$attribs$class,
+      "pt-1"
+    )
+  }
   boxTag$children[[1]]$children[[1]]$children[[1]] <- NULL
   titleNavTag <- shiny::tags$li(
-    class = "pt-2 px-3",
+    class = if (side == "left") "pt-2 px-3 ml-auto" else "pt-2 px-3",
     titleTag
   )
 
@@ -1224,11 +1232,16 @@ bs4TabCard <- function(..., id = NULL, selected = NULL, title = NULL, width = 6,
   }
 
   # Insert box tools at the end of the list
-  content$children[[1]] <- tagInsertChild(
-    content$children[[1]],
-    shiny::tags$li(class = "ml-auto", boxToolTag),
-    length(content$children[[1]])
-  )
+  if (
+      length(boxToolTag$children[[1]]) > 0 || 
+      length(boxToolTag$children[[2]]) > 0
+  ) {
+    content$children[[1]] <- tagInsertChild(
+      content$children[[1]],
+      shiny::tags$li(class = if (side == "left") "ml-0" else "ml-auto", boxToolTag),
+      length(content$children[[1]])
+    ) 
+  }
 
   # Insert tabs at different position in the header tag
   if (side == "right") {

R/dashboardBody.R

@@ -30,14 +30,16 @@ bs4DashBody <- function(...) {
 #'
 #' @param ... Items to put in the container. Each item should be a
 #'   \code{\link{tabItem}}.
+#' @param .list Pass items as list with \link{lapply} family functions.
 #'
 #' @rdname dashboardBody
 #'
 #' @export
-bs4TabItems <- function(...) {
-  lapply(list(...), tagAssert, class = "tab-pane")
+bs4TabItems <- function(..., .list = NULL) {
+  items <- c(list(...), .list)
+  lapply(items, tagAssert, class = "tab-pane")
 
-  shiny::tags$div(class = "tab-content", ...)
+  shiny::tags$div(class = "tab-content", items)
 }
 
 #' Boostrap 4 body item

R/dashboardHeader.R

@@ -5,7 +5,8 @@
 #'
 #' @rdname dashboardHeader
 #'
-#' @param ... Any UI element between left and right Ui.
+#' @param ... Any UI element between left and right Ui. Can include \link{navbarMenu} to host
+#' the navigation in the navbar.
 #' @param title Dashboard title (displayed top-left side). Alternatively, use \link{dashboardBrand}
 #' for more evolved title.
 #' @param titleWidth This argument is deprecated; bs4Dash (AdminLTE3) title width
@@ -129,9 +130,184 @@ bs4DashNavbar <- function(..., title = NULL, titleWidth = NULL, disable = FALSE,
   list(headerTag, title)
 }
 
+#' Navbar tab item
+#' 
+#' Similar to \link{menuItem} but for the
+#' \link{dashboardHeader}.
+#' 
+#' @param text Tab text.
+#' @param ... Slot for nested \link{navbarTab}. You can nest as many elements
+#' as you want.
+#' @param tabName Should correspond exactly to the tabName given in \link{tabItem}.
+#' @param icon An icon tag, created by shiny::icon. If NULL, don't display an icon.
+#' @param .list Use this slot if you had to programmatically pass \link{navbarTab}
+#' like with \link{lapply}.
+#' 
+#' @note You can nest \link{navbarTab} so it does like
+#' \link{menuSubItem}. This is to avoid to create too many functions.
+#' @export
+#' @rdname navbar-menu
+navbarTab <- function(text,  ..., tabName = NULL, icon = NULL, .list = NULL) {
+  items <- c(list(...), .list)
+  if (length(items) > 0) {
+    do.call(navbarDropdown, list(text, items))
+  } else {
+    shiny::tags$li(
+      class = "nav-item",
+      shiny::tags$a(
+        class = "nav-link",
+        id = paste0("tab-", tabName),
+        href = paste0("#shiny-tab-", tabName),
+        `data-toggle` = "tab",
+        `data-value` = tabName,
+        icon,
+        shiny::tags$p(text)
+      )
+    ) 
+  }
+}
 
+#' Build navbar dropdown for navigation
+#'
+#' This is different from \link{dropdownMenu}.
+#'
+#' @param text Dropdown menu title.
+#' @param ... Slot for nested items such as \link{navbarTab}.
+#'
+#' @keywords internal
+navbarDropdown <- function(text, ...) {
+  shiny::tags$li(
+    class = "nav-item dropdown",
+    shiny::tags$a(
+      href = "#",
+      `data-toggle` = "dropdown",
+      `aria-haspopup` = "true",
+      `aria-expanded` = "false",
+      class = "nav-link dropdown-toggle",
+      text
+    ),
+    shiny::tags$ul(
+      class = "dropdown-menu border-0 shadow",
+      style = "left: 0px; right: inherit;",
+      ...
+    )
+  )
+}
+
+#' Dropdown header helper
+#' 
+#' Display header text within dropdown menu
+#'
+#' @param text Text to display.
+#'
+#' @return A shiny tag.
+#' @export
+dropdownHeader <- function(text) {
+  shiny::tags$h6(class = "dropdown-header", text)
+}
 
+#' Navbar menu
+#'
+#' Like \link{sidebarMenu} but inside \link{dashboardHeader}.
+#'
+#' @param ... Slot for \link{navbarTab}.
+#' @param id Menu id. Useful to leverage \link{updateNavbarTabs} on the
+#' server.
+#' @rdname navbar-menu
+#' @export
+#' @examples 
+#' if (interactive()) {
+#'  library(shiny)
+#'  library(bs4Dash)
+#'  
+#'  tabs <- tabItems(.list = lapply(1:7, function(i) {
+#'   tabItem(tabName = sprintf("Tab%s", i), sprintf("Tab %s", i))
+#'  }))
+#'  
+#'  shinyApp(
+#'    ui = dashboardPage(
+#'      header = dashboardHeader(
+#'        navbarMenu(
+#'          id = "navmenu",
+#'          navbarTab(tabName = "Tab1", text = "Tab 1"),
+#'          navbarTab(tabName = "Tab2", text = "Tab 2"),
+#'          navbarTab(
+#'            text = "Menu",
+#'            dropdownHeader("Dropdown header"),
+#'            navbarTab(tabName = "Tab3", text = "Tab 3"),
+#'            dropdownDivider(),
+#'            navbarTab(
+#'              text = "Sub menu",
+#'              dropdownHeader("Another header"),
+#'              navbarTab(tabName = "Tab4", text = "Tab 4"),
+#'              dropdownHeader("Yet another header"),
+#'              navbarTab(tabName = "Tab5", text = "Tab 5"),
+#'              navbarTab(
+#'                text = "Sub sub menu",
+#'                navbarTab(tabName = "Tab6", text = "Tab 6"),
+#'                navbarTab(tabName = "Tab7", text = "Tab 7")
+#'              )
+#'            )
+#'          )
+#'        )
+#'      ),
+#'      body = dashboardBody(tabs),
+#'      controlbar = dashboardControlbar(
+#'        sliderInput(
+#'          inputId = "controller",
+#'          label = "Update the first tabset",
+#'          min = 1,
+#'          max = 4,
+#'          value = 1
+#'        )
+#'      ),
+#'      sidebar = dashboardSidebar(disable = TRUE)
+#'    ),
+#'    server = function(input, output, session) {
+#'      observeEvent(input$controller, {
+#'        updateNavbarTabs(
+#'          session,
+#'          inputId = "navmenu",
+#'          selected = paste0("Tab", input$controller)
+#'        )
+#'      },
+#'      ignoreInit = TRUE
+#'      )
+#'    }
+#'  )
+#' }
+navbarMenu <- function(..., id = NULL) {
+  if (is.null(id)) id <- paste0("tabs_", round(stats::runif(1, min = 0, max = 1e9)))
+
+  items <- list(...) 
+  items <- htmltools::tagQuery(items)$
+    find(".nav-item.dropdown")$
+    removeClass("nav-item dropdown")$
+    addClass("dropdown-submenu dropdown-hover")$
+    find("ul")$
+    removeAttrs("style")$
+    reset()$
+    selectedTags()
+
+  shiny::tags$ul(
+    class = "navbar-nav sidebar-menu", 
+    role = "menu",
+    items,
+    shiny::div(
+      id = id,
+      class = "sidebarMenuSelectedTabItem",
+      `data-value` = "null",
+
+    )
+  )
+}
 
+#' Update navbar menu from the server.
+#'
+#' @inheritParams updatebs4TabItems
+#' @rdname navbar-menu
+#' @export
+updateNavbarTabs <- updatebs4TabItems
 
 #' Alternative to simple text title
 #'

R/dashboardPage.R

@@ -19,8 +19,9 @@
 #' Expect a list.
 #' @param fullscreen Whether to allow fullscreen feature in the navbar. Default to FALSE.
 #' @param help Whether to enable/disable popovers and tooltips. This allows to seamlessly use
-#' \link{tooltip} and \link{popover} without having to individually toggle them. Default to FALSE.
-#' if TRUE, a help icon is display in the navigation bar.
+#' \link{tooltip} and \link{popover} without having to individually toggle them. Default to FALSE,
+#' the toggle is shown but not enabled. If TRUE, all tooltips and popovers are enabled.
+#' Set to NULL if you want to hide the help icon.
 #' @param dark Whether to display toggle to switch between dark and light mode in the \link{dashboardHeader}.
 #' Default to FALSE, app starts in light mode, with possibility to switch to dark. 
 #' If TRUE, the app starts in dark with possibility to switch back to light. If NULL,
@@ -179,7 +180,11 @@ bs4DashPage <- function(header, sidebar, body, controlbar = NULL, footer = NULL,
     # Body
     add_bs4Dash_deps(
       shiny::tags$body(
-        `data-help` = if (help) 1 else 0,
+        `data-help` = if (!is.null(help)) {
+          if (help) 2 else 1
+        } else {
+          0
+        },
         `data-fullscreen` = if (fullscreen) 1 else 0,
         `data-dark` = if (!is.null(dark)) {
           if (dark) {