From 3677f423b00e733c77b9e619385626c1edb586f2 Mon Sep 17 00:00:00 2001
From: Carson <cpsievert1@gmail.com>
Date: Thu, 6 May 2021 09:48:22 -0500
Subject: [PATCH] Use bslib's new nav() api to implement tabPanel() and friends

---
 DESCRIPTION    |   4 +-
 R/bootstrap.R  | 393 ++++---------------------------------------------
 R/insert-tab.R |  78 +---------
 3 files changed, 37 insertions(+), 438 deletions(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index e64752b067..4b22983db9 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -91,7 +91,7 @@ Imports:
     withr,
     commonmark (>= 1.7),
     glue (>= 1.3.2),
-    bslib (>= 0.2.4.9003),
+    bslib (>= 0.2.5.9001),
     cachem,
     ellipsis,
     lifecycle (>= 0.2.0)
@@ -114,7 +114,7 @@ Suggests:
     sass
 Remotes:
     r-lib/rlang,
-    rstudio/bslib,
+    rstudio/bslib#314,
     rstudio/htmltools
 URL: https://shiny.rstudio.com/
 BugReports: https://github.com/rstudio/shiny/issues
diff --git a/R/bootstrap.R b/R/bootstrap.R
index 5b00d0a005..91ba35e4de 100644
--- a/R/bootstrap.R
+++ b/R/bootstrap.R
@@ -427,67 +427,18 @@ navbarPage <- function(title,
                        theme = NULL,
                        windowTitle = title,
                        lang = NULL) {
-
-  # alias title so we can avoid conflicts w/ title in withTags
-  pageTitle <- title
-
-  # navbar class based on options
-  # TODO: tagFunction() the navbar logic?
-  navbarClass <- "navbar navbar-default"
-  position <- match.arg(position)
-  if (!is.null(position))
-    navbarClass <- paste0(navbarClass, " navbar-", position)
-  if (inverse)
-    navbarClass <- paste(navbarClass, "navbar-inverse")
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  # build the tabset
-  tabset <- buildTabset(..., ulClass = "nav navbar-nav", id = id, selected = selected)
-
-  containerClass <- paste0("container", if (fluid) "-fluid")
-
-  # built the container div dynamically to support optional collapsibility
-  if (collapsible) {
-    navId <- paste0("navbar-collapse-", p_randomInt(1000, 10000))
-    containerDiv <- div(class=containerClass,
-      div(class="navbar-header",
-        tags$button(type="button", class="navbar-toggle collapsed",
-          `data-toggle`="collapse", `data-target`=paste0("#", navId),
-          span(class="sr-only", "Toggle navigation"),
-          span(class="icon-bar"),
-          span(class="icon-bar"),
-          span(class="icon-bar")
-        ),
-        span(class="navbar-brand", pageTitle)
-      ),
-      div(class="navbar-collapse collapse", id=navId, tabset$navList)
-    )
-  } else {
-    containerDiv <- div(class=containerClass,
-      div(class="navbar-header",
-        span(class="navbar-brand", pageTitle)
-      ),
-      tabset$navList
-    )
-  }
-
-  # build the main tab content div
-  contentDiv <- div(class=containerClass)
-  if (!is.null(header))
-    contentDiv <- tagAppendChild(contentDiv, div(class="row", header))
-  contentDiv <- tagAppendChild(contentDiv, tabset$content)
-  if (!is.null(footer))
-    contentDiv <- tagAppendChild(contentDiv, div(class="row", footer))
-
-  # build the page
   bootstrapPage(
     title = windowTitle,
     theme = theme,
     lang = lang,
-    tags$nav(class=navbarClass, role="navigation", containerDiv),
-    contentDiv
+    # Splice in the tagList() so internal structure doesn't change
+    !!!bslib::navs_bar(
+      ..., title = title, id = id, selected = selected,
+      position = match.arg(position),
+      header = header, footer = footer,
+      inverse = inverse, collapsible = collapsible,
+      fluid = fluid
+    )
   )
 }
 
@@ -498,19 +449,7 @@ navbarPage <- function(title,
 #' @rdname navbarPage
 #' @export
 navbarMenu <- function(title, ..., menuName = title, icon = NULL) {
-  icon <- prepTabIcon(icon)
-  structure(list(title = title,
-                 menuName = menuName,
-                 tabs = list2(...),
-                 # Here for legacy reasons
-                 # https://github.com/cran/miniUI/blob/74c87d3/R/layout.R#L369
-                 iconClass = tagGetAttribute(icon, "class"),
-                 icon = icon),
-            class = "shiny.navbarmenu")
-}
-
-isNavbarMenu <- function(x) {
-  inherits(x, "shiny.navbarmenu")
+  bslib::nav_menu(title, ..., value = menuName, icon = icon)
 }
 
 #' Create a well panel
@@ -645,30 +584,14 @@ helpText <- function(...) {
 #' @export
 #' @describeIn tabPanel Create a tab panel that can be included within a [tabsetPanel()] or a [navbarPage()].
 tabPanel <- function(title, ..., value = title, icon = NULL) {
-  icon <- prepTabIcon(icon)
-  pane <- div(
-    class = "tab-pane",
-    title = title,
-    `data-value` = value,
-    # Here for legacy reasons
-    # https://github.com/cran/miniUI/blob/74c87d/R/layout.R#L395
-    `data-icon-class` = tagGetAttribute(icon, "class"),
-    ...
-  )
-  attr(pane, "_shiny_icon") <- icon
-  pane
-}
-
-isTabPanel <- function(x) {
-  if (!inherits(x, "shiny.tag")) return(FALSE)
-  class <- tagGetAttribute(x, "class") %||% ""
-  "tab-pane" %in% strsplit(class, "\\s+")[[1]]
+  bslib::nav(title, ..., value = value, icon = icon)
 }
 
 #' @export
 #' @describeIn tabPanel Create a tab panel that drops the title argument.
 #'   This function should be used within `tabsetPanel(type = "hidden")`. See [tabsetPanel()] for example usage.
 tabPanelBody <- function(value, ..., icon = NULL) {
+  # TODO: does bslib need an equivalent?
   if (
     !is.character(value) ||
     length(value) != 1 ||
@@ -753,20 +676,17 @@ tabsetPanel <- function(...,
                         header = NULL,
                         footer = NULL) {
 
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  type <- match.arg(type)
-  tabset <- buildTabset(..., ulClass = paste0("nav nav-", type), id = id, selected = selected)
+  func <- switch(
+    match.arg(type),
+    tabs = bslib::navs_tab,
+    pills = bslib::navs_pill,
+    hidden = bslib::navs_hidden
+  )
 
-  tags$div(
-    class = "tabbable",
-    !!!dropNulls(list(
-      tabset$navList,
-      header,
-      tabset$content,
-      footer
-    ))
+  # bslib adds a class to make the content browsable() by default,
+  # but that's probably too big of a change for shiny
+  remove_first_class(
+    func(..., id = id, selected = selected, header = header, footer = footer)
   )
 }
 
@@ -822,275 +742,18 @@ navlistPanel <- function(...,
                          well = TRUE,
                          fluid = TRUE,
                          widths = c(4, 8)) {
-
-  if (!is.null(id))
-    selected <- restoreInput(id = id, default = selected)
-
-  tabset <- buildTabset(
-    ..., ulClass = "nav nav-pills nav-stacked",
-    textFilter = function(text) tags$li(class = "navbar-brand", text),
-    id = id, selected = selected
-  )
-
-  row <- if (fluid) fluidRow else fixedRow
-
-  row(
-    column(widths[[1]], class = if (well) "well", tabset$navList),
-    column(
-      widths[[2]],
-      !!!dropNulls(list(header, tabset$content, footer))
-    )
-  )
+  remove_first_class(bslib::navs_pill_list(
+    ..., id = id, selected = selected,
+    header = header, footer = footer,
+    well = well, fluid = fluid, widths = widths
+  ))
 }
 
-# Helpers to build tabsetPanels (& Co.) and their elements
-markTabAsSelected <- function(x) {
-  attr(x, "selected") <- TRUE
+remove_first_class <- function(x) {
+  class(x) <- class(x)[-1]
   x
 }
 
-isTabSelected <- function(x) {
-  isTRUE(attr(x, "selected", exact = TRUE))
-}
-
-containsSelectedTab <- function(tabs) {
-  any(vapply(tabs, isTabSelected, logical(1)))
-}
-
-findAndMarkSelectedTab <- function(tabs, selected, foundSelected) {
-  tabs <- lapply(tabs, function(x) {
-    if (foundSelected || is.character(x)) {
-      # Strings are not selectable items
-
-    } else if (isNavbarMenu(x)) {
-      # Recur for navbarMenus
-      res <- findAndMarkSelectedTab(x$tabs, selected, foundSelected)
-      x$tabs <- res$tabs
-      foundSelected <<- res$foundSelected
-
-    } else {
-      # Base case: regular tab item. If the `selected` argument is
-      # provided, check for a match in the existing tabs; else,
-      # mark first available item as selected
-      if (is.null(selected)) {
-        foundSelected <<- TRUE
-        x <- markTabAsSelected(x)
-      } else {
-        tabValue <- x$attribs$`data-value` %||% x$attribs$title
-        if (identical(selected, tabValue)) {
-          foundSelected <<- TRUE
-          x <- markTabAsSelected(x)
-        }
-      }
-    }
-    return(x)
-  })
-  return(list(tabs = tabs, foundSelected = foundSelected))
-}
-
-prepTabIcon <- function(x = NULL) {
-  if (is.null(x)) return(NULL)
-  if (!inherits(x, "shiny.tag")) {
-    stop(
-      "`icon` must be a `shiny.tag` object. ",
-      "Try passing `icon()` (or `tags$i()`) to the `icon` parameter.",
-      call. = FALSE
-    )
-  }
-
-  is_fa <- grepl("fa-", tagGetAttribute(x, "class") %||% "", fixed = TRUE)
-  if (!is_fa) {
-    return(x)
-  }
-
-  # for font-awesome we specify fixed-width
-  tagAppendAttributes(x, class = "fa-fw")
-}
-
-# Text filter for navbarMenu's (plain text) separators
-navbarMenuTextFilter <- function(text) {
-  if (grepl("^\\-+$", text)) tags$li(class = "divider")
-  else tags$li(class = "dropdown-header", text)
-}
-
-# This function is called internally by navbarPage, tabsetPanel
-# and navlistPanel
-buildTabset <- function(..., ulClass, textFilter = NULL, id = NULL,
-                        selected = NULL, foundSelected = FALSE) {
-
-  tabs <- dropNulls(list2(...))
-  res <- findAndMarkSelectedTab(tabs, selected, foundSelected)
-  tabs <- res$tabs
-  foundSelected <- res$foundSelected
-
-  # add input class if we have an id
-  if (!is.null(id)) ulClass <- paste(ulClass, "shiny-tab-input")
-
-  if (anyNamed(tabs)) {
-    nms <- names(tabs)
-    nms <- nms[nzchar(nms)]
-    stop("Tabs should all be unnamed arguments, but some are named: ",
-      paste(nms, collapse = ", "))
-  }
-
-  tabsetId <- p_randomInt(1000, 10000)
-  tabs <- lapply(seq_len(length(tabs)), buildTabItem,
-            tabsetId = tabsetId, foundSelected = foundSelected,
-            tabs = tabs, textFilter = textFilter)
-
-  tabNavList <- tags$ul(class = ulClass, id = id,
-                  `data-tabsetid` = tabsetId, !!!lapply(tabs, "[[", "liTag"))
-
-  tabContent <- tags$div(class = "tab-content",
-                  `data-tabsetid` = tabsetId, !!!lapply(tabs, "[[", "divTag"))
-
-  list(navList = tabNavList, content = tabContent)
-}
-
-# Builds tabPanel/navbarMenu items (this function used to be
-# declared inside the buildTabset() function and it's been
-# refactored for clarity and reusability). Called internally
-# by buildTabset.
-buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
-                         divTag = NULL, textFilter = NULL) {
-
-  divTag <- divTag %||% tabs[[index]]
-
-  # Handles navlistPanel() headers and dropdown dividers
-  if (is.character(divTag) && !is.null(textFilter)) {
-    return(list(liTag = textFilter(divTag), divTag = NULL))
-  }
-
-  if (isNavbarMenu(divTag)) {
-    # tabPanelMenu item: build the child tabset
-    tabset <- buildTabset(
-      !!!divTag$tabs, ulClass = "dropdown-menu",
-      textFilter = navbarMenuTextFilter,
-      foundSelected = foundSelected
-    )
-    return(buildDropdown(divTag, tabset))
-  }
-
-  if (isTabPanel(divTag)) {
-    return(buildNavItem(divTag, tabsetId, index))
-  }
-
-  # The behavior is undefined at this point, so construct a condition message
-  msg <- paste0(
-    "Expected a collection `tabPanel()`s",
-    if (is.null(textFilter)) " and `navbarMenu()`.",
-    if (!is.null(textFilter)) ", `navbarMenu()`, and/or character strings.",
-    " Consider using `header` or `footer` if you wish to place content above (or below) every panel's contents"
-  )
-
-  # Luckily this case has never worked, so it's safe to throw here
-  # https://github.com/rstudio/shiny/issues/3313
-  if (!inherits(divTag, "shiny.tag"))  {
-    stop(msg, call. = FALSE)
-  }
-
-  # Unfortunately, this 'off-label' use case creates an 'empty' nav and includes
-  # the divTag content on every tab. There shouldn't be any reason to be relying on
-  # this behavior since we now have pre/post arguments, so throw a warning, but still
-  # support the use case since we don't make breaking changes
-  warning(msg, call. = FALSE)
-
-  return(buildNavItem(divTag, tabsetId, index))
-}
-
-buildNavItem <- function(divTag, tabsetId, index) {
-  id <- paste("tab", tabsetId, index, sep = "-")
-  # Get title attribute directory (not via tagGetAttribute()) so that contents
-  # don't get passed to as.character().
-  # https://github.com/rstudio/shiny/issues/3352
-  title <- divTag$attribs[["title"]]
-  value <- divTag$attribs[["data-value"]]
-  active <- isTabSelected(divTag)
-  divTag <- tagAppendAttributes(divTag, class = if (active) "active")
-  divTag$attribs$id <- id
-  divTag$attribs$title <- NULL
-  list(
-    divTag = divTag,
-    liTag = tagAddRenderHook(
-      liTag(id, title, value, attr(divTag, "_shiny_icon")),
-      function(x) {
-        if (isTRUE(getCurrentThemeVersion() >= 4)) {
-          tagQuery(x)$
-            addClass("nav-item")$
-            find("a")$
-            addClass(c("nav-link", if (active) "active"))$
-            allTags()
-        } else {
-          tagAppendAttributes(x, class = if (active) "active")
-        }
-      }
-    )
-  )
-}
-
-liTag <- function(id, title, value, icon) {
-  tags$li(
-    tags$a(
-      href = paste0("#", id),
-      `data-toggle` = "tab",
-      `data-value` = value,
-       icon, title
-    )
-  )
-}
-
-buildDropdown <- function(divTag, tabset) {
-
-  navList <- tagAddRenderHook(
-    tabset$navList,
-    function(x) {
-      if (isTRUE(getCurrentThemeVersion() >= 4)) {
-        tagQuery(x)$
-          find(".nav-item")$
-          removeClass("nav-item")$
-          find(".nav-link")$
-          removeClass("nav-link")$
-          addClass("dropdown-item")$
-          allTags()
-      } else {
-        x
-      }
-    }
-  )
-
-  active <- containsSelectedTab(divTag$tabs)
-
-  dropdown <- tags$li(
-    class = "dropdown",
-    tags$a(
-      href = "#",
-      class = "dropdown-toggle",
-      `data-toggle` = "dropdown",
-      `data-value` = divTag$menuName,
-      divTag$icon,
-      divTag$title,
-      tags$b(class = "caret")
-    ),
-    navList,
-    .renderHook = function(x) {
-      if (isTRUE(getCurrentThemeVersion() >= 4)) {
-        tagQuery(x)$
-          addClass("nav-item")$
-          find(".dropdown-toggle")$
-          addClass("nav-link")$
-          allTags()
-      } else {
-        x
-      }
-    }
-  )
-
-  list(
-    divTag = tabset$content$children,
-    liTag = dropdown
-  )
-}
-
 #' Create a text output element
 #'
 #' Render a reactive output variable as text within an application page.
diff --git a/R/insert-tab.R b/R/insert-tab.R
index 49e8d38778..1a7563f7a1 100644
--- a/R/insert-tab.R
+++ b/R/insert-tab.R
@@ -115,32 +115,10 @@
 insertTab <- function(inputId, tab, target,
                       position = c("before", "after"), select = FALSE,
                       session = getDefaultReactiveDomain()) {
-  force(target)
-  force(select)
-  position <- match.arg(position)
-  inputId <- session$ns(inputId)
-
-  # Barbara -- August 2017
-  # Note: until now, the number of tabs in a tabsetPanel (or navbarPage
-  # or navlistPanel) was always fixed. So, an easy way to give an id to
-  # a tab was simply incrementing a counter. (Just like it was easy to
-  # give a random 4-digit number to identify the tabsetPanel). Since we
-  # can only know this in the client side, we'll just pass `id` and
-  # `tsid` (TabSetID) as dummy values that will be fixed in the JS code.
-  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
-    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
-
-  callback <- function() {
-    session$sendInsertTab(
-      inputId = inputId,
-      liTag = processDeps(item$liTag, session),
-      divTag = processDeps(item$divTag, session),
-      menuName = NULL,
-      target = target,
-      position = position,
-      select = select)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_insert(
+    inputId, tab, target,
+    match.arg(position), select, session
+  )
 }
 
 #' @param menuName This argument should only be used when you want to
@@ -159,63 +137,21 @@ insertTab <- function(inputId, tab, target,
 #' @export
 prependTab <- function(inputId, tab, select = FALSE, menuName = NULL,
                        session = getDefaultReactiveDomain()) {
-  force(select)
-  force(menuName)
-  inputId <- session$ns(inputId)
-
-  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
-    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
-
-  callback <- function() {
-    session$sendInsertTab(
-      inputId = inputId,
-      liTag = processDeps(item$liTag, session),
-      divTag = processDeps(item$divTag, session),
-      menuName = menuName,
-      target = NULL,
-      position = "after",
-      select = select)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_prepend(inputId, tab, select, menuName, session)
 }
 
 #' @rdname insertTab
 #' @export
 appendTab <- function(inputId, tab, select = FALSE, menuName = NULL,
                       session = getDefaultReactiveDomain()) {
-  force(select)
-  force(menuName)
-  inputId <- session$ns(inputId)
-
-  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
-    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
-
-  callback <- function() {
-    session$sendInsertTab(
-      inputId = inputId,
-      liTag = processDeps(item$liTag, session),
-      divTag = processDeps(item$divTag, session),
-      menuName = menuName,
-      target = NULL,
-      position = "before",
-      select = select)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_append(inputId, tab, select, menuName, session)
 }
 
 #' @rdname insertTab
 #' @export
 removeTab <- function(inputId, target,
                       session = getDefaultReactiveDomain()) {
-  force(target)
-  inputId <- session$ns(inputId)
-
-  callback <- function() {
-    session$sendRemoveTab(
-      inputId = inputId,
-      target = target)
-  }
-  session$onFlush(callback, once = TRUE)
+  bslib::nav_remove(inputId, target, session)
 }