Add sidebar(), layout_sidebar(), card_sidebar(), and container()

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

@@ -277,7 +277,8 @@ bootstrap_bundle <- function(version) {
         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", "layout_column_wrap.scss", package = "bslib"),
+        system_file("components", "sidebar.scss", package = "bslib")
       ))
     ),
     four = sass_bundle(

R/card.R

@@ -210,6 +210,17 @@ 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()].
+#' @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/page.R

@@ -88,6 +88,33 @@ page_navbar <- function(..., title = NULL, id = NULL, selected = NULL,
   )
 }
 
+#' 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,155 @@
+#' 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(background_color = bg),
+      ...
+    ),
+    collapse_tag = tags$a(
+      class = "collapse-toggle",
+      role = "button",
+      "aria-expanded" = "true",
+      "aria-controls" = id
+    ),
+    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 = "var(--bs-body-bg)", 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(background_color = 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, style = css(position = "fixed", inset = 0))
+    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()].
+#' @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"
+  )
+}

_pkgdown.yml

@@ -98,6 +98,7 @@ reference:
   description: |
     Useful layout templates
   contents:
+    - layout_sidebar
     - layout_column_wrap
 - title: Page layouts
   contents:

inst/components/card.scss

@@ -15,6 +15,10 @@
         margin-bottom: 0;
       }
     }
+    .bslib-sidebar-layout {
+      border-top-left-radius: 0;
+      border-top-right-radius: 0;
+    }
   }
 
   .card-body {