1#' Navigation containers
2#'
3#' Render a collection of [nav()] items into a container.
4#'
5#' @param ... a collection of [nav()] items.
6#' @param id a character string used for dynamically updating the container (see [nav_select()]).
7#' @param selected a character string matching the `value` of a particular [nav()] item to selected by default.
8#' @param header UI element(s) ([tags]) to display _above_ the nav content.
9#' @param footer UI element(s) ([tags]) to display _below_ the nav content.
10#' @export
11#' @seealso [nav()], [nav_select()].
12#' @rdname navs
13#' @examples
14#'
15#' library(shiny)
16#'
17#' nav_items <- function(prefix) {
18#'   list(
19#'     nav("a", paste(prefix, ": tab a content")),
20#'     nav("b", paste(prefix, ": tab b content")),
21#'     nav_item(
22#'       tags$a(icon("github"), "Shiny", href = "https://github.com/rstudio/shiny", target = "_blank")
23#'     ),
24#'     nav_spacer(),
25#'     nav_menu(
26#'       "Other links", align = "right",
27#'       nav("c", paste(prefix, ": tab c content")),
28#'       nav_item(
29#'         tags$a(icon("r-project"), "RStudio", href = "https://rstudio.com", target = "_blank")
30#'       )
31#'     )
32#'   )
33#' }
34#'
35#' if (interactive()) {
36#'   shinyApp(
37#'     page_navbar(
38#'       title = "page_navbar()",
39#'       bg = "#0062cc",
40#'       !!!nav_items("page_navbar()"),
41#'       footer = div(
42#'         style = "width:80%; margin: 0 auto",
43#'         h4("navs_tab()"),
44#'         navs_tab(!!!nav_items("navs_tab()")),
45#'         h4("navs_pill()"),
46#'         navs_pill(!!!nav_items("navs_pill()")),
47#'         h4("navs_tab_card()"),
48#'         navs_tab_card(!!!nav_items("navs_tab_card()")),
49#'         h4("navs_pill_card()"),
50#'         navs_pill_card(!!!nav_items("navs_pill_card()")),
51#'         h4("navs_pill_list()"),
52#'         navs_pill_list(!!!nav_items("navs_pill_list()"))
53#'       )
54#'     ),
55#'     function(...) { }
56#'   )
57#' }
58navs_tab <- function(..., id = NULL, selected = NULL,
59                     header = NULL, footer = NULL) {
60  tabs <- tabsetPanel_(
61    ..., type = "tabs", id = id, selected = selected,
62    header = header, footer = footer
63  )
64  as_fragment(tabs)
65}
66
67#' @export
68#' @rdname navs
69navs_pill <- function(..., id = NULL, selected = NULL,
70                      header = NULL, footer = NULL) {
71  pills <- tabsetPanel_(
72    ..., type = "pills", id = id, selected = selected,
73    header = header, footer = footer
74  )
75  as_fragment(pills)
76}
77
78#' @export
79#' @inheritParams shiny::navlistPanel
80#' @rdname navs
81navs_pill_list <- function(..., id = NULL, selected = NULL,
82                           header = NULL, footer = NULL,
83                           well = TRUE, fluid = TRUE,
84                           widths = c(4, 8)) {
85  pill_list <- navlistPanel_(
86    ..., id = id, selected = selected,
87    header = header, footer = footer,
88    well = well, fluid = fluid,
89    widths = widths
90  )
91  as_fragment(pill_list)
92}
93
94#' @export
95#' @rdname navs
96navs_hidden <- function(..., id = NULL, selected = NULL,
97                        header = NULL, footer = NULL) {
98  hidden <- tabsetPanel_(
99    ..., type = "hidden", id = id, selected = selected,
100    header = header, footer = footer
101  )
102  as_fragment(hidden)
103}
104
105
106#' @inheritParams shiny::navbarPage
107#' @param bg a CSS color to use for the navbar's background color.
108#' @param inverse Either `TRUE` for a light text color or `FALSE` for a dark
109#'   text color. If `"auto"` (the default), the best contrast to `bg` is chosen.
110#' @export
111#' @rdname navs
112navs_bar <- function(..., title = NULL, id = NULL, selected = NULL,
113                     # TODO: add sticky-top as well?
114                     position = c("static-top", "fixed-top", "fixed-bottom"),
115                     header = NULL, footer = NULL,
116                     bg = NULL, inverse = "auto",
117                     collapsible = TRUE, fluid = TRUE) {
118
119  if (identical(inverse, "auto")) {
120    inverse <- TRUE
121    if (!is.null(bg)) {
122      bg <- htmltools::parseCssColors(bg)
123      bg_contrast <- bs_get_contrast(bs_theme("navbar-bg" = bg), "navbar-bg")
124      inverse <- col2rgb(bg_contrast)[1,] > 127.5
125    }
126  }
127
128  navbar <- navbarPage_(
129    title = title, ..., id = id, selected = selected,
130    position = match.arg(position),
131    header = header, footer = footer, collapsible = collapsible,
132    inverse = inverse, fluid = fluid
133  )
134
135  if (!is.null(bg)) {
136    # navbarPage_() returns a tagList() of the nav and content
137    navbar[[1]] <- tagAppendAttributes(
138      navbar[[1]], style = css(background_color = paste(bg, "!important"))
139    )
140  }
141
142  as_fragment(navbar, page = page)
143}
144
145
146
147# -----------------------------------------------------------------------
148# 'Internal' tabset logic that was pulled directly from shiny/R/bootstrap.R
149#  (with minor modifications)
150# -----------------------------------------------------------------------
151
152navbarPage_ <- function(title,
153                       ...,
154                       id = NULL,
155                       selected = NULL,
156                       position = c("static-top", "fixed-top", "fixed-bottom"),
157                       header = NULL,
158                       footer = NULL,
159                       inverse = FALSE,
160                       collapsible = FALSE,
161                       fluid = TRUE,
162                       theme = NULL,
163                       windowTitle = title,
164                       lang = NULL) {
165
166  # alias title so we can avoid conflicts w/ title in withTags
167  pageTitle <- title
168
169  # navbar class based on options
170  navbarClass <- "navbar navbar-default"
171  position <- match.arg(position)
172  if (!is.null(position))
173    navbarClass <- paste0(navbarClass, " navbar-", position)
174  if (inverse)
175    navbarClass <- paste(navbarClass, "navbar-inverse")
176
177  if (!is.null(id))
178    selected <- shiny::restoreInput(id = id, default = selected)
179
180  # build the tabset
181  tabset <- buildTabset(..., ulClass = "nav navbar-nav", id = id, selected = selected)
182
183  containerClass <- paste0("container", if (fluid) "-fluid")
184
185  # built the container div dynamically to support optional collapsibility
186  if (collapsible) {
187    navId <- paste0("navbar-collapse-", p_randomInt(1000, 10000))
188    containerDiv <- div(
189      class = containerClass,
190      div(
191        class = "navbar-header",
192        tags$button(
193          type = "button",
194          class = "navbar-toggle collapsed",
195          `data-toggle` = "collapse",
196          `data-target` = paste0("#", navId),
197          # data-bs-* is for BS5+
198          `data-bs-toggle` = "collapse",
199          `data-bs-target` = paste0("#", navId),
200          span(class="sr-only", "Toggle navigation"),
201          span(class = "icon-bar"),
202          span(class = "icon-bar"),
203          span(class = "icon-bar")
204        ),
205        span(class = "navbar-brand", pageTitle)
206      ),
207      div(
208        class = "navbar-collapse collapse",
209        id = navId, tabset$navList
210      )
211    )
212  } else {
213    containerDiv <- div(
214      class = containerClass,
215      div(
216        class = "navbar-header",
217        span(class = "navbar-brand", pageTitle)
218      ),
219      tabset$navList
220    )
221  }
222
223  # Bootstrap 3 explicitly supported "dropup menus" via .navbar-fixed-bottom,
224  # but BS4+ requires .dropup on menus with .navbar.fixed-bottom
225  if (position == "fixed-bottom") {
226    containerDiv <- tagQuery(containerDiv)$
227      find(".dropdown-menu")$
228      parent()$
229      addClass("dropup")$
230      allTags()
231  }
232
233  # build the main tab content div
234  contentDiv <- div(class = containerClass)
235  if (!is.null(header))
236    contentDiv <- tagAppendChild(contentDiv, div(class = "row", header))
237  contentDiv <- tagAppendChild(contentDiv, tabset$content)
238  if (!is.null(footer))
239    contentDiv <- tagAppendChild(contentDiv, div(class = "row", footer))
240
241  # *Don't* wrap in bootstrapPage() (shiny::navbarPage()) does that part
242  tagList(
243    tags$nav(class = navbarClass, role = "navigation", containerDiv),
244    contentDiv
245  )
246}
247
248navbarMenu_ <- function(title, ..., menuName = title, icon = NULL, align) {
249  icon <- prepTabIcon(icon)
250  structure(
251    list(
252      title = title,
253      menuName = menuName,
254      tabs = list2(...),
255      # Here for legacy reasons
256      # https://github.com/cran/miniUI/blob/74c87d3/R/layout.R#L369
257      iconClass = tagGetAttribute(icon, "class"),
258      icon = icon,
259      align = align
260    ),
261    class = "shiny.navbarmenu"
262  )
263}
264
265isNavbarMenu <- function(x) {
266  inherits(x, "shiny.navbarmenu")
267}
268
269tabPanel_ <- function(title, ..., value = title, icon = NULL) {
270  icon <- prepTabIcon(icon)
271  pane <- div(
272    class = "tab-pane",
273    title = title,
274    `data-value` = value,
275    # Here for legacy reasons
276    # https://github.com/cran/miniUI/blob/74c87d/R/layout.R#L395
277    `data-icon-class` = tagGetAttribute(icon, "class"),
278    ...
279  )
280  attr(pane, "_shiny_icon") <- icon
281  pane
282}
283
284isTabPanel <- function(x) {
285  if (!inherits(x, "shiny.tag")) return(FALSE)
286  class <- tagGetAttribute(x, "class") %||% ""
287  "tab-pane" %in% strsplit(class, "\\s+")[[1]]
288}
289
290tabPanelBody_ <- function(value, ..., icon = NULL) {
291  if (
292    !is.character(value) ||
293    length(value) != 1 ||
294    any(is.na(value)) ||
295    nchar(value) == 0
296  ) {
297    stop("`value` must be a single, non-empty string value")
298  }
299  tabPanel_(title = NULL, ..., value = value, icon = icon)
300}
301
302tabsetPanel_ <- function(...,
303                        id = NULL,
304                        selected = NULL,
305                        type = c("tabs", "pills", "hidden"),
306                        header = NULL,
307                        footer = NULL) {
308
309  if (!is.null(id))
310    selected <- shiny::restoreInput(id = id, default = selected)
311
312  type <- match.arg(type)
313  tabset <- buildTabset(..., ulClass = paste0("nav nav-", type), id = id, selected = selected)
314
315  tags$div(
316    class = "tabbable",
317    !!!dropNulls(list(
318      tabset$navList,
319      header,
320      tabset$content,
321      footer
322    ))
323  )
324}
325
326navlistPanel_ <- function(...,
327                         id = NULL,
328                         selected = NULL,
329                         header = NULL,
330                         footer = NULL,
331                         well = TRUE,
332                         fluid = TRUE,
333                         widths = c(4, 8)) {
334
335  if (!is.null(id))
336    selected <- shiny::restoreInput(id = id, default = selected)
337
338  tabset <- buildTabset(
339    ..., ulClass = "nav nav-pills nav-stacked",
340    textFilter = function(text) tags$li(class = "navbar-brand", text),
341    id = id, selected = selected
342  )
343
344  row <- if (fluid) shiny::fluidRow else shiny::fixedRow
345
346  row(
347    shiny::column(widths[[1]], class = if (well) "well", tabset$navList),
348    shiny::column(
349      widths[[2]],
350      !!!dropNulls(list(header, tabset$content, footer))
351    )
352  )
353}
354
355
356# Helpers to build tabsetPanels (& Co.) and their elements
357markTabAsSelected <- function(x) {
358  attr(x, "selected") <- TRUE
359  x
360}
361
362isTabSelected <- function(x) {
363  isTRUE(attr(x, "selected", exact = TRUE))
364}
365
366containsSelectedTab <- function(tabs) {
367  any(vapply(tabs, isTabSelected, logical(1)))
368}
369
370findAndMarkSelectedTab <- function(tabs, selected, foundSelected) {
371  tabs <- lapply(tabs, function(x) {
372    if (foundSelected || is.character(x)) {
373      # Strings are not selectable items
374
375    } else if (isNavbarMenu(x)) {
376      # Recur for navbarMenus
377      res <- findAndMarkSelectedTab(x$tabs, selected, foundSelected)
378      x$tabs <- res$tabs
379      foundSelected <<- res$foundSelected
380
381    } else if (isTabPanel(x)) {
382      # Base case: regular tab item. If the `selected` argument is
383      # provided, check for a match in the existing tabs; else,
384      # mark first available item as selected
385      if (is.null(selected)) {
386        foundSelected <<- TRUE
387        x <- markTabAsSelected(x)
388      } else {
389        tabValue <- x$attribs$`data-value` %||% x$attribs$title
390        if (identical(selected, tabValue)) {
391          foundSelected <<- TRUE
392          x <- markTabAsSelected(x)
393        }
394      }
395    }
396    return(x)
397  })
398  return(list(tabs = tabs, foundSelected = foundSelected))
399}
400
401prepTabIcon <- function(x = NULL) {
402  if (is.null(x)) return(NULL)
403  if (!inherits(x, "shiny.tag")) {
404    stop(
405      "`icon` must be a `shiny.tag` object. ",
406      "Try passing `icon()` (or `tags$i()`) to the `icon` parameter.",
407      call. = FALSE
408    )
409  }
410
411  is_fa <- grepl("fa-", tagGetAttribute(x, "class") %||% "", fixed = TRUE)
412  if (!is_fa) {
413    return(x)
414  }
415
416  # for font-awesome we specify fixed-width
417  tagAppendAttributes(x, class = "fa-fw")
418}
419
420# Text filter for navbarMenu's (plain text) separators
421navbarMenuTextFilter <- function(text) {
422  if (grepl("^\\-+$", text)) tags$li(class = "divider")
423  else tags$li(class = "dropdown-header", text)
424}
425
426# This function is called internally by navbarPage, tabsetPanel
427# and navlistPanel
428buildTabset <- function(..., ulClass, textFilter = NULL, id = NULL,
429                        selected = NULL, foundSelected = FALSE) {
430
431  tabs <- dropNulls(list2(...))
432  res <- findAndMarkSelectedTab(tabs, selected, foundSelected)
433  tabs <- res$tabs
434  foundSelected <- res$foundSelected
435
436  # add input class if we have an id
437  if (!is.null(id)) ulClass <- paste(ulClass, "shiny-tab-input")
438
439  if (anyNamed(tabs)) {
440    nms <- names(tabs)
441    nms <- nms[nzchar(nms)]
442    stop("Tabs should all be unnamed arguments, but some are named: ",
443         paste(nms, collapse = ", "))
444  }
445
446  tabsetId <- p_randomInt(1000, 10000)
447  tabs <- lapply(seq_len(length(tabs)), buildTabItem,
448                 tabsetId = tabsetId, foundSelected = foundSelected,
449                 tabs = tabs, textFilter = textFilter)
450
451  tabNavList <- tags$ul(class = ulClass, id = id,
452                        `data-tabsetid` = tabsetId, !!!lapply(tabs, "[[", "liTag"))
453
454  tabContent <- tags$div(class = "tab-content",
455                         `data-tabsetid` = tabsetId, !!!lapply(tabs, "[[", "divTag"))
456
457  list(navList = tabNavList, content = tabContent)
458}
459
460# Builds tabPanel/navbarMenu items (this function used to be
461# declared inside the buildTabset() function and it's been
462# refactored for clarity and reusability). Called internally
463# by buildTabset.
464buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
465                         divTag = NULL, textFilter = NULL) {
466
467  divTag <- divTag %||% tabs[[index]]
468
469  # Handles navlistPanel() headers and dropdown dividers
470  if (is.character(divTag) && !is.null(textFilter)) {
471    return(list(liTag = textFilter(divTag), divTag = NULL))
472  }
473
474  if (isNavbarMenu(divTag)) {
475    # tabPanelMenu item: build the child tabset
476    ulClass <- "dropdown-menu"
477    if (identical(divTag$align, "right")) {
478      ulClass <- paste(ulClass, "dropdown-menu-right")
479    }
480    tabset <- buildTabset(
481      !!!divTag$tabs, ulClass = ulClass,
482      textFilter = navbarMenuTextFilter,
483      foundSelected = foundSelected
484    )
485    return(buildDropdown(divTag, tabset))
486  }
487
488  if (isTabPanel(divTag)) {
489    return(buildNavItem(divTag, tabsetId, index))
490  }
491
492  if (is_nav_item(divTag) || is_nav_spacer(divTag)) {
493    return(
494      list(liTag = divTag, divTag = NULL)
495    )
496  }
497
498  # The behavior is undefined at this point, so construct a condition message
499  msg <- paste0(
500    "Navigation containers expect a collection of `bslib::nav()`/`shiny::tabPanel()`s ",
501    "and/or `bslib::nav_menu()`/`shiny::navbarMenu()`s. ",
502    "Consider using `header` or `footer` if you wish to place content above ",
503    "(or below) every panel's contents."
504  )
505
506  # Luckily this case has never worked, so it's safe to throw here
507  # https://github.com/rstudio/shiny/issues/3313
508  if (!inherits(divTag, "shiny.tag"))  {
509    stop(msg, call. = FALSE)
510  }
511
512  # Unfortunately, this 'off-label' use case creates an 'empty' nav and includes
513  # the divTag content on every tab. There shouldn't be any reason to be relying on
514  # this behavior since we now have pre/post arguments, so throw a warning, but still
515  # support the use case since we don't make breaking changes
516  warning(msg, call. = FALSE)
517
518  return(buildNavItem(divTag, tabsetId, index))
519}
520
521buildNavItem <- function(divTag, tabsetId, index) {
522  id <- paste("tab", tabsetId, index, sep = "-")
523  # Get title attribute directory (not via tagGetAttribute()) so that contents
524  # don't get passed to as.character().
525  # https://github.com/rstudio/shiny/issues/3352
526  title <- divTag$attribs[["title"]]
527  value <- divTag$attribs[["data-value"]]
528  active <- isTabSelected(divTag)
529  divTag <- tagAppendAttributes(divTag, class = if (active) "active")
530  divTag$attribs$id <- id
531  divTag$attribs$title <- NULL
532  list(
533    divTag = divTag,
534    liTag = tagAddRenderHook(
535      liTag(id, title, value, attr(divTag, "_shiny_icon")),
536      function(x) {
537        if (isTRUE(getCurrentThemeVersion() >= 4)) {
538          tagQuery(x)$
539            addClass("nav-item")$
540            find("a")$
541            addClass(c("nav-link", if (active) "active"))$
542            allTags()
543        } else {
544          tagAppendAttributes(x, class = if (active) "active")
545        }
546      }
547    )
548  )
549}
550
551liTag <- function(id, title, value, icon) {
552  tags$li(
553    tags$a(
554      href = paste0("#", id),
555      `data-toggle` = "tab",
556      # data-bs-* is for BS5+
557      `data-bs-toggle` = "tab",
558      `data-value` = value,
559      icon, title
560    )
561  )
562}
563
564buildDropdown <- function(divTag, tabset) {
565
566  navList <- tagAddRenderHook(
567    tabset$navList,
568    function(x) {
569      if (isTRUE(getCurrentThemeVersion() >= 4)) {
570        tagQuery(x)$
571          find(".nav-item")$
572          removeClass("nav-item")$
573          find(".nav-link")$
574          removeClass("nav-link")$
575          addClass("dropdown-item")$
576          allTags()
577      } else {
578        x
579      }
580    }
581  )
582
583  active <- containsSelectedTab(divTag$tabs)
584
585  dropdown <- tags$li(
586    class = "dropdown",
587    class = if (active) "active",
588    tags$a(
589      href = "#",
590      class = "dropdown-toggle",
591      `data-toggle` = "dropdown",
592      # data-bs-* is for BS5+
593      `data-bs-toggle` = "dropdown",
594      `data-value` = divTag$menuName,
595      divTag$icon,
596      divTag$title,
597      tags$b(class = "caret")
598    ),
599    navList,
600    .renderHook = function(x) {
601      if (isTRUE(getCurrentThemeVersion() >= 4)) {
602        tagQuery(x)$
603          addClass("nav-item")$
604          find(".dropdown-toggle")$
605          addClass("nav-link")$
606          allTags()
607      } else {
608        x
609      }
610    }
611  )
612
613  list(
614    divTag = tabset$content$children,
615    liTag = dropdown
616  )
617}
618