Add sidebars

DESCRIPTION

@@ -71,6 +71,7 @@ Collate:
     'precompiled.R'
     'print.R'
     'shiny-devmode.R'
+    'sidebar.R'
     'staticimports.R'
     'utils-shiny.R'
     'utils-tags.R'

NAMESPACE

@@ -56,14 +56,17 @@ export(card_body_fill)
 export(card_footer)
 export(card_header)
 export(card_image)
+export(card_sidebar)
 export(card_title)
+export(container)
 export(font_collection)
 export(font_face)
 export(font_google)
 export(font_link)
 export(is.card_item)
 export(is_bs_theme)
 export(layout_column_wrap)
+export(layout_sidebar)
 export(nav)
 export(nav_append)
 export(nav_content)
@@ -92,6 +95,9 @@ export(precompiled_css_path)
 export(run_with_themer)
 export(showcase_left_center)
 export(showcase_top_right)
+export(sidebar)
+export(sidebar_close)
+export(sidebar_open)
 export(theme_bootswatch)
 export(theme_version)
 export(value_box)

R/bs-theme.R

@@ -276,8 +276,10 @@ bootstrap_bundle <- function(version) {
       !!!rule_bundles(c(
         system_file("components", "accordion.scss", package = "bslib"),
         system_file("components", "card.scss", package = "bslib"),
-        system_file("components", "value_box.scss", package = "bslib"),
-        system_file("components", "layout_column_wrap.scss", package = "bslib")
+        system_file("components", "fill.scss", package = "bslib"),
+        system_file("components", "layout_column_wrap.scss", package = "bslib"),
+        system_file("components", "sidebar.scss", package = "bslib"),
+        system_file("components", "value_box.scss", package = "bslib")
       ))
     ),
     four = sass_bundle(

R/card.R

@@ -210,6 +210,18 @@ card_footer <- function(..., class = NULL) {
   )
 }
 
+#' @describeIn card_body A [card_body_fill()] with a [layout_sidebar()] inside
+#'   of it. All arguments to this function are passed along to
+#'   [layout_sidebar()].
+#' @inheritParams layout_sidebar
+#' @export
+card_sidebar <- function(sidebar = sidebar(), ..., border = FALSE) {
+  card_body_fill(
+    class = "p-0",
+    layout_sidebar(sidebar = sidebar, ..., border = border)
+  )
+}
+
 #' @describeIn card_body Include static (i.e., pre-generated) images.
 #' @param file a file path pointing an image. The image will be base64 encoded
 #' and provided to the `src` attribute of the `<img>`. Alternatively, you may

R/navs-legacy.R

@@ -110,6 +110,7 @@ navs_hidden <- function(..., id = NULL, selected = NULL,
 #' @export
 #' @rdname navs
 navs_bar <- function(..., title = NULL, id = NULL, selected = NULL,
+                     sidebar = NULL, fill = FALSE,
                      # TODO: add sticky-top as well?
                      position = c("static-top", "fixed-top", "fixed-bottom"),
                      header = NULL, footer = NULL,
@@ -127,6 +128,7 @@ navs_bar <- function(..., title = NULL, id = NULL, selected = NULL,
 
   navbar <- navbarPage_(
     title = title, ..., id = id, selected = selected,
+    sidebar = sidebar, fill = fill,
     position = match.arg(position),
     header = header, footer = footer, collapsible = collapsible,
     inverse = inverse, fluid = fluid
@@ -153,6 +155,8 @@ navbarPage_ <- function(title,
                        ...,
                        id = NULL,
                        selected = NULL,
+                       sidebar = NULL,
+                       fill = FALSE,
                        position = c("static-top", "fixed-top", "fixed-bottom"),
                        header = NULL,
                        footer = NULL,
@@ -238,6 +242,43 @@ navbarPage_ <- function(title,
   if (!is.null(footer))
     contentDiv <- tagAppendChild(contentDiv, div(class = "row", footer))
 
+  # Cascade fill roles down to each relevant .tab-pane 
+  # (note for this to work properly, the page-level container must be a fill container
+  #  with height: 100%, or similar)
+  if (!isFALSE(fill)) {
+    contentDiv <- bindFillRole(contentDiv, container = TRUE, item = TRUE)
+    contentDiv <- bindFillRole(contentDiv, container = TRUE, item = TRUE, .cssSelector = ".tab-content")
+    contentDiv <- tagQuery(contentDiv)$
+      find(".tab-pane")$
+      each(function(x, i) {
+        fill <- isTRUE(fill) || isTRUE(fill == tagGetAttribute(x, "data-value"))
+        tagAppendAttributes(
+          bindFillRole(x, container = fill, item = fill),
+          style = css("--bslib-navbar-margin" = 0)
+        )
+      })$
+      allTags()
+  }
+
+  # Wrap the contents of each .tab-pane with layout_sidebar(sidebar, contents)
+  if (!is.null(sidebar)) {
+    tab_panes <- tagQuery(contentDiv)$find(".tab-pane")
+    fills <- vapply(tab_panes$selectedTags(), function(x) {
+      isTRUE(fill) || isTRUE(fill == tagGetAttribute(x, "data-value"))
+    }, logical(1))
+    content_div <- tab_panes$
+      children("*")$
+      each(function(x, i) { 
+        # each() only allows modification of x, but we can work around that w/ tagAddRenderHook()
+        fill_i <- fills[i]
+        tagAddRenderHook(x, function(y) layout_sidebar(sidebar, y, full_bleed = TRUE, fill = fill_i))
+      })$
+      allTags()
+
+    # Tagify contents now so the return structure can be modified downstream
+    contentDiv <- tagify(content_div)
+  }
+
   # *Don't* wrap in bootstrapPage() (shiny::navbarPage()) does that part
   tagList(
     tags$nav(class = navbarClass, role = "navigation", containerDiv),

R/page.R

@@ -43,20 +43,43 @@ page_fixed <- function(..., title = NULL, theme = bs_theme(), lang = NULL) {
 #' @export
 page_fill <- function(..., padding = 0, title = NULL,
                       theme = bs_theme(), lang = NULL) {
-  as_page(
-    shiny::fillPage(..., padding = padding, title = title, theme = theme, lang = lang)
+
+  padding_css <- paste(
+    sapply(padding, validateCssUnit, USE.NAMES = FALSE),
+    collapse = " "
+  )
+
+  styles <- tags$style(
+    type = "text/css",
+    "html, body { width: 100%; height: 100%; }",
+     sprintf("body { padding: %s; margin: 0; }", padding_css)
+  )
+
+  page(
+    title = title,
+    theme = theme,
+    lang = lang,
+    tags$head(styles),
+    # TODO: is there a good reason why bootstrapPage() doesn't return a <body> already?
+    bindFillRole(tags$body(...), container = TRUE)
   )
 }
 
 #' @rdname page
 #' @inheritParams navs_bar
 #' @inheritParams bs_page
 #' @seealso [shiny::navbarPage()]
+#' @param sidebar A [sidebar()] component to display on every [nav()] page.
+#' @param fill Whether or not to allow 'fill items' (i.e., UI elements marked with
+#'   `htmltools::bindFillRole(x, item = TRUE)`) to fit the viewport. If `TRUE`,
+#'   all [nav()] pages are filled. A character vector, matching the `value` of
+#'   [nav()]s to be filled, may also be provided.
 #' @param window_title the browser window title. The default value, `NA`, means
 #'   to use any character strings that appear in `title` (if none are found, the
 #'   host URL of the page is displayed by default).
 #' @export
 page_navbar <- function(..., title = NULL, id = NULL, selected = NULL,
+                        sidebar = NULL, fill = FALSE,
                         position = c("static-top", "fixed-top", "fixed-bottom"),
                         header = NULL, footer = NULL,
                         bg = NULL, inverse = "auto",
@@ -75,19 +98,53 @@ page_navbar <- function(..., title = NULL, id = NULL, selected = NULL,
     }
   }
 
-  page(
+  if (!is.null(sidebar) && !inherits(sidebar, "sidebar")) {
+    abort("`sidebar` argument must contain a `bslib::sidebar()` component.")
+  }
+
+  page_func <- if (!isFALSE(fill)) page_fill else page
+
+  page_func(
     title = window_title,
     theme = theme,
     lang = lang,
     navs_bar(
       ..., title = title, id = id, selected = selected,
+      sidebar = sidebar, fill = fill,
       position = match.arg(position), header = header,
       footer = footer, bg = bg, inverse = inverse,
       collapsible = collapsible, fluid = fluid
     )
   )
 }
 
+#' Contain, pad, and align content
+#'
+#' @param ... A collection of [htmltools::tag()] children.
+#' @param size A size (i.e., max-width policy) for the container.
+#' @param bg A background color.
+#' @param class Additional CSS classes for the container.
+#'
+#' @references <https://getbootstrap.com/docs/5.3/layout/containers/>
+#'
+#' @export
+container <- function(..., size = c("sm", "md", "lg", "xl", "xxl", "fluid"), bg = NULL, class = NULL) {
+
+  size <- match.arg(size)
+
+  res <- div(
+    class = paste0("container-", size),
+    class = class,
+    # TODO: parseCssColors(), once it supports var() and !important
+    style = css(background_color = bg),
+    ...
+  )
+
+  as_fragment(
+    tag_require(res, version = 5, caller = "container()")
+  )
+}
+
 #> unlist(find_characters(div(h1("foo"), h2("bar"))))
 #> [1] "foo" "bar"
 find_characters <- function(x) {

R/sidebar.R

@@ -0,0 +1,159 @@
+#' Create various sidebar-based layouts
+#'
+#' @param ... A collection of [htmltools::tag()] children to place in the main
+#'   content area.
+#' @param width A valid [CSS unit][htmltools::validateCssUnit] used for the
+#'   width of the sidebar.
+#' @param collapsible Whether or not the sidebar should be collapsible.
+#' @param id A character string. Required if wanting to re-actively read (or
+#'   update) the `collapsible` state in a Shiny app.
+#' @param bg A background color.
+#' @param class Additional CSS classes for the top-level HTML element.
+#'
+#' @export
+#' @seealso [card_sidebar()], [container()], [page_navbar()]
+sidebar <- function(..., width = 250, collapsible = TRUE, id = NULL, bg = NULL, class = NULL) {
+
+  # For accessiblity reasons, always provide id (when collapsible),
+  # but only create input binding when id is provided
+  if (is.null(id) && collapsible) {
+    id <- paste0("bslib-sidebar-", p_randomInt(1000, 10000))
+  } else {
+    class <- c("bslib-sidebar-input", class)
+  }
+
+  res <- list2(
+    tag = tags$form(
+      id = id,
+      role = "complementary",
+      class = c("sidebar", class),
+      # TODO: parseCssColors(), once it supports var() and !important
+      style = css("--bslib-sidebar-bg" = bg),
+      ...
+    ),
+    collapse_tag = tags$a(
+      class = "collapse-toggle",
+      role = "button",
+      "aria-expanded" = "true",
+      "aria-controls" = id,
+      title = "Toggle sidebar"
+    ),
+    width = validateCssUnit(width)
+  )
+
+  class(res) <- c("sidebar", class(res))
+  res
+}
+
+
+#' @describeIn sidebar A 'low-level' sidebar layout
+#'
+#' @param sidebar A [sidebar()] object.
+#' @param full_bleed whether or not to clip the layout container the entire viewport.
+#' @param fill whether or not the `main` content area should be considered a
+#'   fill (i.e., flexbox) container.
+#' @param border whether or not to add a border.
+#' @param border_radius whether or not to add a border radius.
+#'
+#' @export
+layout_sidebar <- function(sidebar = sidebar(), ..., full_bleed = FALSE, fill = FALSE, bg = NULL, border = !full_bleed, border_radius = !full_bleed, class = NULL) {
+
+  if (!inherits(sidebar, "sidebar")) {
+    abort("`sidebar` argument must contain a `bslib::sidebar()` component.")
+  }
+
+  main <- div(
+    role = "main",
+    class = "main",
+    # TODO: parseCssColors(), once it supports var() and !important
+    style = css("--bslib-sidebar-main-bg" = bg),
+    ...
+  )
+
+  border_css <- if (border) {
+    "var(--bs-border-width) var(--bs-border-style) var(--bs-border-color)"
+  } else {
+    "none"
+  }
+
+  border_radius_css <- if (border_radius) "var(--bs-border-radius)" else "initial"
+
+  res <- div(
+    class = c("bslib-sidebar-layout", class),
+    style = css(
+      "--bslib-sidebar-width" = sidebar$width,
+      "--bslib-sidebar-border" = border_css,
+      "--bslib-sidebar-border-radius" = border_radius_css
+    ),
+    sidebar$tag,
+    sidebar$collapse_tag,
+    bindFillRole(main, container = fill),
+    sidebar_dependency()
+  )
+
+  if (full_bleed) {
+    res <- tagAppendAttributes(res, class = "full-bleed")
+    res <- tagAppendChild(res, adjust_full_bleed_inset())
+  }
+
+  res <- bindFillRole(res, item = TRUE)
+
+  as_fragment(
+    tag_require(res, version = 5, caller = "layout_sidebar()")
+  )
+}
+
+
+#' @describeIn sidebar Close a (`collapsible`) [sidebar()].
+#' @param session a shiny session object (the default should almost always be
+#'   used).
+#' @export
+sidebar_open <- function(id, session = get_current_session()) {
+  callback <- function() {
+    session$sendInputMessage(id, list(method = "open"))
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @describeIn sidebar Close a (`collapsible`) [sidebar()].
+#' @export
+sidebar_close <- function(id, session = get_current_session()) {
+  callback <- function() {
+    session$sendInputMessage(id, list(method = "close"))
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+
+adjust_full_bleed_inset <- function() {
+  tags$script("data-bslib-sidebar-full-bleed-inset" = NA, HTML(
+    "
+    var thisScript = document.querySelector('script[data-bslib-sidebar-full-bleed-inset]');
+    thisScript.removeAttribute('data-bslib-sidebar-full-bleed-inset');
+
+    var navbar = $('.navbar:visible');
+    // TODO: actually handle the multiple navbar case.
+    if (navbar.length > 1) {
+      console.warning('More than one navbar is visible. Will only adjust full_bleed layout for the first navbar.')
+      navbar = navbar.first();
+    }
+    if (navbar.length == 1) {
+      var height = navbar.outerHeight() + 'px';
+      var $el = $(thisScript.parentElement);
+      navbar.hasClass('navbar-fixed-bottom') ?
+        $el.css('bottom', height) :
+        $el.css('top', height);
+    }
+    "
+  ))
+}
+
+sidebar_dependency <- function() {
+  htmlDependency(
+    name = "bslib-sidebar",
+    version = get_package_version("bslib"),
+    package = "bslib",
+    src = "components",
+    script = "sidebar.min.js"
+  )
+}