Document (GitHub Actions)

This reverts commit b5b0ba1774.

NEWS.md

@@ -7,18 +7,7 @@ shiny 1.6.0.9000
 
 * The `format` and `locale` arguments to `sliderInput()` have been removed. They have been deprecated since 0.10.2.2 (released on 2014-12-08).
 
-### New features and improvements
-
-* All uses of `list(...)` have been replaced with `rlang::list2(...)`. This means that you can use trailing `,` without error and use rlang's `!!!` operator to "splice" a list of argument values into `...`. We think this'll be particularly useful for passing a list of `tabPanel()` to their consumers (i.e., `tabsetPanel()`, `navbarPage()`, etc). For example, `tabs <- list(tabPanel("A", "a"), tabPanel("B", "b")); navbarPage(!!!tabs)`. (#3315 and #3328)
-
-* Numerous improvements tabset panels (i.e., `tabPanel()`, `navbarMenu()`, `tabsetPanel()`, `navbarPage()`, etc) (#3315):
-  * Closed #3322: `tabsetPanel()` and `navlistPanel()` gain `header`/`footer` arguments (inspired by `navbarPage()`'s already existing `header`/`footer`), making it easier to include content that should appear on every tab.
-  * Closed #3313 and #1823: More informative error when non-`tabPanel()`/`shiny.tag` objects are supplied to `...`.
-  * Closed #3321: New informative warning when `shiny.tag` object(s) are supplied to `...`. In this case we will continue to create an "empty" nav item and include the content on every tab, but the warning will mention the (new) `header`/`footer` args, which is likely what the user wants.
-  * Closed #3320: The HTML markup that `tabPanel()` et. al generate (for Bootstrap nav) is now Bootstrap 4+ compliant when used with `theme = bslib::bs_theme()`.
-  * Closed #1928: `NULL` values are now dropped instead of producing an empty nav item.
-  
-### Other improvements
+### Minor new features and improvements
 
 * Shiny's core JavaScript code was converted to TypeScript. For the latest development information, please see the [README.md in `./srcts`](https://github.com/rstudio/shiny/tree/master/srcts). (#3296)
 

R/bootstrap-layout.R

@@ -396,7 +396,7 @@ mainPanel <- function(..., width = 8) {
 #' }
 #' @export
 verticalLayout <- function(..., fluid = TRUE) {
-  lapply(list2(...), function(row) {
+  lapply(list(...), function(row) {
     col <- column(12, row)
     if (fluid)
       fluidRow(col)
@@ -433,7 +433,7 @@ verticalLayout <- function(..., fluid = TRUE) {
 #' @export
 flowLayout <- function(..., cellArgs = list()) {
 
-  children <- list2(...)
+  children <- list(...)
   childIdx <- !nzchar(names(children) %||% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
@@ -516,7 +516,7 @@ inputPanel <- function(...) {
 #' @export
 splitLayout <- function(..., cellWidths = NULL, cellArgs = list()) {
 
-  children <- list2(...)
+  children <- list(...)
   childIdx <- !nzchar(names(children) %||% character(length(children)))
   attribs <- children[!childIdx]
   children <- children[childIdx]
@@ -614,7 +614,7 @@ fillCol <- function(..., flex = 1, width = "100%", height = "100%") {
 }
 
 flexfill <- function(..., direction, flex, width = width, height = height) {
-  children <- list2(...)
+  children <- list(...)
   attrs <- list()
 
   if (!is.null(names(children))) {

R/bootstrap.R

@@ -49,7 +49,7 @@ bootstrapPage <- function(..., title = NULL, responsive = deprecated(), theme =
       tags$head(tags$link(rel="stylesheet", type="text/css", href=theme))
     },
     # remainder of tags passed to the function
-    list2(...)
+    list(...)
   )
 
   # If theme is a bslib::bs_theme() object, bootstrapLib() needs to come first
@@ -91,10 +91,6 @@ getLang <- function(ui) {
 #' @export
 bootstrapLib <- function(theme = NULL) {
   tagFunction(function() {
-    if (isRunning()) {
-      setCurrentTheme(theme)
-    }
-
     # If we're not compiling Bootstrap Sass (from bslib), return the
     # static Bootstrap build.
     if (!is_bs_theme(theme)) {
@@ -116,6 +112,7 @@ bootstrapLib <- function(theme = NULL) {
     # Note also that since this is shinyOptions() (and not options()), the
     # option is automatically reset when the app (or session) exits
     if (isRunning()) {
+      setCurrentTheme(theme)
       registerThemeDependency(bs_theme_deps)
 
     } else {
@@ -710,6 +707,7 @@ tabPanelBody <- function(value, ..., icon = NULL) {
 #'   conjunction with [tabPanelBody()] and [updateTabsetPanel()] to control the
 #'   active tab via other input controls. (See example below)}
 #' }
+#' @param card whether to wrap the navigation controls and content into an 'output card'. This functionality currently requires a [bslib::bs_theme()] in the page layout with `version = 4` or higher.
 #' @param position This argument is deprecated; it has been discontinued in
 #'   Bootstrap 3.
 #' @inheritParams navbarPage
@@ -764,6 +762,7 @@ tabsetPanel <- function(...,
                         type = c("tabs", "pills", "hidden"),
                         header = NULL,
                         footer = NULL,
+                        card = FALSE,
                         position = deprecated()) {
   if (lifecycle::is_present(position)) {
     shinyDeprecated(
@@ -778,15 +777,34 @@ tabsetPanel <- function(...,
   type <- match.arg(type)
   tabset <- buildTabset(..., ulClass = paste0("nav nav-", type), id = id, selected = selected)
 
-  tags$div(
-    class = "tabbable",
-    !!!dropNulls(list(
-      tabset$navList,
-      header,
-      tabset$content,
-      footer
-    ))
-  )
+  nav <- tabset$navList
+  if (card) {
+    nav <- tags$div(
+      class = "card-header",
+      tagFunction(function() {
+        if (getCurrentVersion() >= 4) {
+          return(NULL)
+        }
+        stop(
+          "`tabsetPanel(card = TRUE)` requires Bootstrap 4 or higher. ",
+          "Please supply `bslib::bs_theme()` to the UI's page layout function ",
+          "(e.g., `fluidPage(theme = bslib::bs_theme())`).",
+          call. = FALSE
+        )
+      }),
+      tagAppendAttributes(
+        nav, class = paste0("card-header-", type)
+      )
+    )
+  }
+
+  tabs <- tags$div(class = "tabbable", class = if (card) "card", nav)
+  content <- dropNulls(list(header, tabset$content, footer))
+  if (card) {
+    tagAppendChild(tabs, tags$div(class = "card-body", !!!content))
+  } else {
+    tagAppendChildren(tabs, content)
+  }
 }
 
 #' Create a navigation list panel
@@ -1013,12 +1031,9 @@ buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
 
 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"]]
-  icon <- getIcon(iconClass = divTag$attribs[["data-icon-class"]])
+  title <- tagGetAttribute(divTag, "title")
+  value <- tagGetAttribute(divTag, "data-value")
+  icon <- getIcon(iconClass = tagGetAttribute(divTag, "data-icon-class"))
   active <- isTabSelected(divTag)
   divTag <- tagAppendAttributes(divTag, class = if (active) "active")
   divTag$attribs$id <- id

R/reactives.R

@@ -568,7 +568,7 @@ ReactiveValues <- R6Class(
 #' @seealso [isolate()] and [is.reactivevalues()].
 #' @export
 reactiveValues <- function(...) {
-  args <- list2(...)
+  args <- list(...)
   if ((length(args) > 0) && (is.null(names(args)) || any(names(args) == "")))
     rlang::abort("All arguments passed to reactiveValues() must be named.")
 
@@ -1915,7 +1915,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' @export
 reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...) {
   filePath <- coerceToFunc(filePath)
-  extraArgs <- list2(...)
+  extraArgs <- list(...)
 
   reactivePoll(
     intervalMillis, session,

R/shiny-options.R

@@ -178,7 +178,7 @@ getShinyOption <- function(name, default = NULL) {
 #' @aliases shiny-options
 #' @export
 shinyOptions <- function(...) {
-  newOpts <- list2(...)
+  newOpts <- list(...)
 
   if (length(newOpts) > 0) {
     # If we're within a session, modify at the session level.

R/utils.R

@@ -1176,7 +1176,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #'
 #' }
 validate <- function(..., errorClass = character(0)) {
-  results <- sapply(list2(...), function(x) {
+  results <- sapply(list(...), function(x) {
     # Detect NULL or NA
     if (is.null(x))
       return(NA_character_)

inst/www/shared/shiny.js

@@ -3127,9 +3127,9 @@
           }
         });
         function ensureTabsetHasVisibleTab($tabset) {
-          var inputBinding = $tabset.data("shiny-input-binding");
-          if (!inputBinding.getValue($tabset)) {
+          if ($tabset.find("li.active").not(".dropdown").length === 0) {
             var destTabValue = getFirstTab($tabset);
+            var inputBinding = $tabset.data("shiny-input-binding");
             var evt = jQuery.Event("shiny:updateinput");
             evt.binding = inputBinding;
             $tabset.trigger(evt);

man/tabsetPanel.Rd

@@ -11,6 +11,7 @@ tabsetPanel(
   type = c("tabs", "pills", "hidden"),
   header = NULL,
   footer = NULL,
+  card = FALSE,
   position = deprecated()
 )
 }
@@ -40,6 +41,8 @@ tabPanels.}
 \item{footer}{Tag or list of tags to display as a common footer below all
 tabPanels}
 
+\item{card}{whether to wrap the navigation controls and content into an 'output card'. This functionality currently requires a \code{\link[bslib:bs_theme]{bslib::bs_theme()}} in the page layout with \code{version = 4} or higher.}
+
 \item{position}{This argument is deprecated; it has been discontinued in
 Bootstrap 3.}
 }

srcts/src/main.ts

@@ -1480,16 +1480,13 @@ function main(): void {
 
     // If the given tabset has no active tabs, select the first one
     function ensureTabsetHasVisibleTab($tabset) {
-      const inputBinding = $tabset.data("shiny-input-binding");
-
-      // Use the getValue() method to avoid duplicating the CSS selector
-      // for querying the DOM for the currently active tab
-      if (!inputBinding.getValue($tabset)) {
+      if ($tabset.find("li.active").not(".dropdown").length === 0) {
         // Note: destTabValue may be null. We still want to proceed
         // through the below logic and setValue so that the input
         // value for the tabset gets updated (i.e. input$tabsetId
         // should be null if there are no tabs).
         const destTabValue = getFirstTab($tabset);
+        const inputBinding = $tabset.data("shiny-input-binding");
         const evt = jQuery.Event("shiny:updateinput");
 
         evt.binding = inputBinding;

tests/testthat/_snaps/tabPanel.md

@@ -138,6 +138,43 @@
         <div class="content-footer"></div>
       </div>
 
+---
+
+    Code
+      bslib_tags(x)
+    Output
+      <div class="tabbable card">
+        <div class="card-header">
+          <ul class="nav nav-tabs card-header-tabs" data-tabsetid="4785">
+            <li class="nav-item">
+              <a class="nav-link active" data-toggle="tab" data-value="A" href="#tab-4785-1">A</a>
+            </li>
+            <li class="nav-item">
+              <a class="nav-link" href="#tab-4785-2" data-toggle="tab" data-value="B">
+                <i class=" fab fa-github fa-fw" role="presentation" aria-label=" icon"></i>
+                B
+              </a>
+            </li>
+            <li class="dropdown nav-item">
+              <a class="dropdown-toggle nav-link" data-toggle="dropdown" data-value="Menu" href="#">
+                Menu
+                <b class="caret"></b>
+              </a>
+              <ul class="dropdown-menu" data-tabsetid="1502">
+                <a class="dropdown-item" href="#tab-1502-1" data-toggle="tab" data-value="C">C</a>
+              </ul>
+            </li>
+          </ul>
+        </div>
+        <div class="card-body">
+          <div class="tab-content" data-tabsetid="4785">
+            <div class="tab-pane active" data-value="A" id="tab-4785-1">a</div>
+            <div class="tab-pane" data-value="B" data-icon-class="fab fa-github" id="tab-4785-2">b</div>
+            <div class="tab-pane" data-value="C" id="tab-1502-1">c</div>
+          </div>
+        </div>
+      </div>
+
 # navbarPage() markup is correct
 
     Code

tests/testthat/test-tabPanel.R

@@ -54,6 +54,8 @@ test_that("tabsetPanel() markup is correct", {
   # BS4
   expect_snapshot_bslib(default)
   expect_snapshot_bslib(pills)
+  card <- tabset_panel(!!!panels, card = TRUE)
+  expect_snapshot_bslib(card)
 })
 
 test_that("navbarPage() markup is correct", {
@@ -96,19 +98,3 @@ test_that("tabPanelBody validates it's input", {
   expect_error(tabPanelBody(""), "single, non-empty string")
   expect_error(tabPanelBody(letters[1:2]), "single, non-empty string")
 })
-
-
-# https://github.com/rstudio/shiny/issues/3352
-test_that("tabItem titles can contain tag objects", {
-  title <- tagList(tags$i("Hello"), "world")
-  x <- tabsetPanel(tabPanel(title, "tab content"))
-  x <- renderTags(x)
-
-  # Result should contain (with different whitespace):
-  #   "<a ....> <i>Hello</i> world"
-  # As opposed to:
-  #   "<a ....>&lt;i&gt;Hello&lt;/i&gt; world
-  expect_true(
-    grepl("<a [^>]+>\\s*<i>Hello</i>\\s+world", x$html)
-  )
-})