Wrap up bslib integration (#308)

* Allow gaugeSectors() to updated on redraw (and also add bslib integration) * Make value boxes dynamically themeable * wip bslib integration * R CMD check fixes * document * remove linebreaks in sassValue() * valueBox() now correctly considers muted contrast * Roll-back the navbar_bg argument and instead set a different default for bslib's new navbar-bg based on primary Also, make sure the modified theme passes through shiny::bootstrapLib * Adjust for navbar height in JavaScript rather than CSS * Remove setCurrentTheme() hack and instead require rmarkdown patch * Update news * Generate pre-compiled flexdashboard.css from scss file * Cleanup * update rmarkdown version * also require dev version of bslib since that's needed for navbar-bg * Add a proper waiting mechanism to get the timing right for the navbar adjustment * No need for debounce() * Fix news typo * Better timing of dynamic navbar height adjustments * roxygenize
rstudio · Feb 22, 2021 · afd403d · afd403d
1 parent d8f6984
commit afd403d
Show file tree

Hide file tree

Showing 14 changed files with 961 additions and 160 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -32,7 +32,8 @@ URL: http://rmarkdown.rstudio.com/flexdashboard
 BugReports: https://github.com/rstudio/flexdashboard/issues
 Encoding: UTF-8
 Depends: R (>= 3.0.2)
-Imports: 
+Imports:
+  grDevices, 
   tools,
   utils, 
   jsonlite, 
@@ -43,9 +44,12 @@ Imports:
   shiny (>= 0.13), 
   scales,
   sass, 
-  bslib
+  bslib (>= 0.2.4.9002)
 Suggests: testthat
 LazyData: TRUE
 License: MIT + file LICENSE
 RoxygenNote: 7.1.1
 Config/testthat/edition: 3
+Remotes: 
+  rstudio/bslib,
+  rstudio/rmarkdown#2049
diff --git a/NAMESPACE b/NAMESPACE
@@ -12,6 +12,7 @@ import(bslib)
 import(htmltools)
 import(rmarkdown)
 import(sass)
+importFrom(grDevices,col2rgb)
 importFrom(jsonlite,toJSON)
 importFrom(tools,file_path_sans_ext)
 importFrom(utils,packageVersion)
diff --git a/NEWS.md b/NEWS.md
@@ -1,9 +1,51 @@
 flexdashboard 0.5.2.9000
 ===========
 
+This release adds integration with the new [`{bslib}` package](https://rstudio.github.io/bslib/index.html), making the customization of main colors and fonts much easier via `flex_dashboard`'s `theme` parameter. For example, here's a custom dark mode with custom Google Fonts:
+
+````yaml
+---
+output:
+  flexdashboard::flex_dashboard:
+    theme:
+      bg: "#101010"
+      fg: "#FDF7F7"
+      primary: "#ED79F9"
+      base_font: !expr bslib::font_google("Prompt")
+      code_font: !expr bslib::font_google("JetBrains Mono")
+---
+````
+
+Furthermore, all of `{flexdashboard}` now also works sensible with `{bslib}`'s real-time theming widget (`bs_themer()`). To use it, add a `runtime: shiny` to the top of the yaml matter and call `bslib::bs_themer()` in a server context. Also, if your dashboard contains static plots, you can add `thematic::thematic_shiny(font = "auto")` to theme plots in real-time too (just make sure the plots are generated through `renderPlot()`).
+
+````yaml
+---
+output:
+  flexdashboard::flex_dashboard:
+    theme:
+      version: 4
+---
+
+```{r, include = FALSE}
+bslib::bs_themer()
+thematic::thematic_shiny(font = "auto")
+```
+
+## Row
+
+### My plot
+
+```{r}
+renderPlot(plot(1:10))
+```
+````
+
+By default, using this `{bslib}` integration will also upgrade your dashboard from Bootstrap 3 to 4. If you run into any issues with custom widgets rendering not quite right, note that you can add `version: 3` to the `theme` in order to use Bootstrap 3 instead of 4. To learn more about `{bslib}`[See here](https://github.com/rstudio/bslib#basic-theming-options) to learn more about the theming options that `{bslib}` provides.
+
 ### Possibly breaking changes
 
 * The `smart` argument was removed from `flexdashboard::flex_dashboard` since it was removed in rmarkdown 2.2 (relatedly, we now require rmarkdown 2.2 or higher). (#301)
+* The `window.FlexDashboard.themeColor` JavaScript object property is no longer available. Resolving of theming accent colors should now be done server-side via `{bslib}`'s [dynamic theming tools](https://rstudio.github.io/bslib/articles/theming.html#custom-components-1). (#305) 
 
 ### Improvements & fixes
 

diff --git a/R/bslib.R b/R/bslib.R
@@ -1,8 +1,5 @@
 resolve_theme <- function(theme) {
   if (is.list(theme)) {
-    if (!is_available("rmarkdown", "2.6.6")) {
-      stop("Providing a list to `theme` requires the rmarkdown verion 2.6.6 or higher.", call. = FALSE)
-    }
     return(as_bs_theme(theme))
   }
   if (identical(theme, "default")) {

diff --git a/R/dependencies.R b/R/dependencies.R
@@ -12,6 +12,8 @@ flexdashboard_dependency <- function(name) {
   system.file("www", name, package = "flexdashboard")
 }
 
+# Might have an issue with jQuery 3?
+# https://github.com/jmosbech/StickyTableHeaders/pull/157
 html_dependency_stickytableheaders <- function() {
   htmlDependency(
     "stickytableheaders",

diff --git a/R/flex_dashboard.R b/R/flex_dashboard.R
@@ -297,54 +297,22 @@ flex_dashboard <- function(fig_width = 6.0,
     add_graphic("logo", logo)
     add_graphic("favicon", favicon)
 
-    # include flexdashboard.css and flexdashboard.js (but not in devel
-    # mode, in that case relative filesystem references to
-    # them are included in the template along with live reload)
+    # Include flexdashboard.js unless we're in devel mode.
+    # In that case, relative filesystem references to
+    # them are included in the template, along with live reload
     if (devel) {
       args <- c(args, pandoc_variable_arg("devel", "1"))
-      dashboardCss <- NULL
-      dashboardScript <- NULL
     } else {
-      if (fill_page) {
-        fillPageCss <- readLines(resource("fillpage.css"))
-      } else {
-        fillPageCss <- NULL
-      }
-
-      theme <- ifelse(identical(theme, "default"), "bootstrap", theme)
-      dashboardCss <- c(
-        '<style type="text/css">',
-        readLines(resource("flexdashboard.css")),
-        readLines(resource(paste0("theme-", theme, ".css"))),
-        fillPageCss,
-        '</style>'
-      )
-
-      dashboardScript <- c(
-        '<script type="text/javascript">',
-        readLines(resource("flexdashboard.js")),
-        '</script>'
-      )
+      dashboardScriptFile <- tempfile(fileext = ".html")
+      dashboardScript <- c('<script type="text/javascript">', readLines(resource("flexdashboard.js")), '</script>')
+      writeLines(dashboardScript, dashboardScriptFile)
+      includes$before_body <- c(includes$before_body, dashboardScriptFile)
     }
 
     # if there is no fig_mobile height and width then pass the default
     if (is.null(fig_mobile))
       fig_mobile <- default_fig_mobile
 
-    # css
-    if (!is.null(dashboardCss)) {
-      dashboardCssFile <- tempfile(fileext = "html")
-      writeLines(dashboardCss, dashboardCssFile)
-      args <- c(args, pandoc_include_args(in_header = dashboardCssFile))
-    }
-
-    # script
-    if (!is.null(dashboardScript)) {
-      dashboardScriptFile <- tempfile(fileext = ".html")
-      writeLines(dashboardScript, dashboardScriptFile)
-      includes$before_body <- c(includes$before_body, dashboardScriptFile)
-    }
-
     # dashboard init script
     dashboardInitScript <- c(
        '<script type="text/javascript">',
@@ -359,6 +327,18 @@ flex_dashboard <- function(fig_width = 6.0,
        paste0('    defaultFigHeightMobile: ', figSizePixels(fig_mobile[[2]]), ','),
        paste0('    resize_reload: ', ifelse(resize_reload,'true','false')),
        '  });',
+       '  var navbar = $(".navbar").first();',
+       '  var body = $("body").first();',
+       '  var sidebar = $(".section.sidebar").first();',
+       '  function addNavbarPadding() {',
+       '    var navHeight = navbar.outerHeight();',
+       '    body.css("padding-top", (navHeight + 8) + "px");',
+       '    sidebar.css("top", navHeight + "px");',
+       '  }',
+       '  setTimeout(addNavbarPadding, 50);',
+       '  $(document).on("shiny:idle", function() {',
+       '    setTimeout(addNavbarPadding, 50);',
+       '  });',
        '});',
        '</script>'
     )
@@ -420,6 +400,33 @@ flex_dashboard <- function(fig_width = 6.0,
                                       html_dependency_prism()))
   }
 
+  if (fill_page) {
+    extra_dependencies <- append(extra_dependencies, html_dependencies_fillpage())
+  }
+
+  if (is_bs_theme(theme)) {
+    if (!is_available("rmarkdown", "2.7.1")) {
+      stop("Using a {bslib} theme requires rmarkdown v2.7.1 or higher")
+    }
+
+    # Attach the dynamic CSS dependency to the theme so that the dependency
+    # is restyled if and when `session$setCurrentTheme()` gets called
+    flexdb_css <- bslib::bs_dependency_defer(html_dependencies_flexdb)
+    theme <- bslib::bs_bundle(theme, sass::sass_layer(html_deps = flexdb_css))
+
+    # If $navbar-bg wasn't specified by user, default it to $primary
+    # (instead of $dark, since the template has .navbar-inverse)
+    navbar_bg <- bslib::bs_get_variables(theme, "navbar-bg")
+    if (is.na(navbar_bg)) {
+      theme <- bslib::bs_add_variables(
+        theme, primary = getSassAccentColors(theme, "primary"),
+        "navbar-bg" = "$primary"
+      )
+    }
+  } else {
+    extra_dependencies <- append(extra_dependencies, html_dependencies_flexdb(theme))
+  }
+
   # return format
   output_format(
     knitr = knitr_options,
@@ -616,6 +623,45 @@ storyboard_dependencies <- function(source = NULL) {
 }
 
 
+html_dependencies_fillpage <- function() {
+  list(htmlDependency(
+    name = "flexdashboard-fillpage",
+    version = packageVersion("flexdashboard"),
+    src = "rmarkdown/templates/flex_dashboard/resources",
+    package = "flexdashboard",
+    stylesheet = "fillpage.css"
+  ))
+}
+
+html_dependencies_flexdb <- function(theme) {
+  name <- "flexdashboard-css"
+  version <- packageVersion("flexdashboard")
+
+  if (is.character(theme)) {
+    dep <- htmlDependency(
+      name = name, version = version,
+      src = "rmarkdown/templates/flex_dashboard/resources",
+      package = "flexdashboard",
+      stylesheet = c(
+        "flexdashboard.css",
+        paste0("theme-", theme, ".css")
+      )
+    )
+    return(list(dep))
+  }
+
+  if (bslib::is_bs_theme(theme)) {
+    dep <- bslib::bs_dependency(
+      sass::sass_file(resource("flexdashboard.scss")),
+      theme = theme, name = name, version = version,
+      cache_key_extra = version
+    )
+    return(list(dep))
+  }
+
+  stop("Didn't recognize a theme object with class: ", class(theme))
+}
+
 # function for resolving resources
 resource <- function(name) {
   system.file("rmarkdown/templates/flex_dashboard/resources", name,

diff --git a/R/gauge.R b/R/gauge.R
@@ -133,11 +133,11 @@ resolveAccentColors <- function(colors, theme) {
   if (!length(colors)) return(colors)
 
   idx <- vapply(colors, is_accent_color, logical(1))
-  if (is.character(theme)) {
-    colors[idx] <- themeColors[[theme]][colors[idx]]
-  } else if (bslib::is_bs_theme(theme)) {
+  if (bslib::is_bs_theme(theme)) {
     accentMap <- getSassAccentColors(theme, unique(colors[idx]))
     colors[idx] <- accentMap[colors[idx]]
+  } else if (is.character(theme)) {
+    colors[idx] <- themeColors[[theme]][colors[idx]]
   }
   as.character(colors)
 }
@@ -146,10 +146,9 @@ getSassAccentColors <- function(theme, accents = accent_colors()) {
   if ("3" %in% bslib::theme_version(theme)) {
     accents <- paste0("brand-", accents)
   }
-  setNames(
-    bslib::bs_get_variables(theme, accents),
-    sub("^brand-", "", accents)
-  )
+  vals <- bslib::bs_get_variables(theme, accents)
+  names(vals) <- sub("^brand-", "", accents)
+  vals
 }
 
 

diff --git a/R/package.R b/R/package.R
@@ -21,6 +21,7 @@
 #' @importFrom jsonlite toJSON
 #' @importFrom tools file_path_sans_ext
 #' @importFrom utils packageVersion
+#' @importFrom grDevices col2rgb
 #'
 #' @docType package
 #' @name flexdashboard

diff --git a/R/valuebox.R b/R/valuebox.R
@@ -111,11 +111,8 @@ valueBoxDynamicAccentCSS <- function(theme) {
 getColorContrast <- function(color) {
   sass_func <- system.file("sass-utils", "color-contrast.scss", package = "bslib")
   sassValue(
-    sprintf("color-contrast(%s)", color),
-    defaults = list(
-      "color-contrast-dark" = "#1a1a1a",  # TODO: better way to get a muted contrast?
-      sass::sass_file(sass_func)
-    )
+    sprintf("color-contrast(%s, #1a1a1a)", color),
+    defaults = sass::sass_file(sass_func)
   )
 }
 
@@ -125,7 +122,9 @@ sassValue <- function(expr, defaults = "") {
     list(defaults, sprintf("foo{bar:%s}", expr)),
     options = sass::sass_options(output_style = "compressed")
   )
-  sub("}", "", sub("foo{bar:", "", out, fixed = TRUE), fixed = TRUE)
+  out <- sub("foo{bar:", "", out, fixed = TRUE)
+  out <- sub("}", "", out, fixed = TRUE)
+  gsub("\n", "", out, fixed = TRUE)
 }
 
 

diff --git a/inst/rmarkdown/templates/flex_dashboard/resources/default.html b/inst/rmarkdown/templates/flex_dashboard/resources/default.html
@@ -99,11 +99,9 @@
 </div>
 
 <script>
-
-$$(document).ready(function () {
-
+$$(document).ready(function() {
   // add bootstrap table styles to pandoc tables
-  $$('tr.header').parent('thead').parent('table').addClass('table table-condensed');
+  $$('tr.header').parent('thead').parent('table').addClass('table table-condensed table-sm');
 
   // initialize mathjax
 $if(mathjax-url)$