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