refactor(theme-preset): Streamline S3 classes, store theme info in sass variables

NAMESPACE

@@ -1,7 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method(bs_preset_bundle,bs_preset)
-S3method(bs_preset_bundle,default)
 S3method(is_fill_item,default)
 S3method(is_fill_item,htmlwidget)
 S3method(is_fillable_container,default)

R/bs-theme-preset-bootswatch.R

@@ -15,11 +15,8 @@ bootswatch_themes <- function(version = version_default(), full_path = FALSE) {
 #' @export
 theme_bootswatch <- function(theme) {
   if (!is_bs_theme(theme)) return(NULL)
-
-  swatch <- grep("^bs_bootswatch_", class(theme), value = TRUE)
-  if (!length(swatch)) return(NULL)
-
-  sub("^bs_bootswatch_", "", swatch)
+  info <- theme_preset_info(theme)
+  if (identical("bootswatch", info$type)) info$name else NULL
 }
 
 #' Obtain a theme's Bootstrap version
@@ -31,7 +28,12 @@ theme_version <- function(theme) {
   if (!is_bs_theme(theme)) return(NULL)
 
   version <- grep("^bs_version_", class(theme), value = TRUE)
-  sub("^bs_version_", "", version)
+  if (length(version) == 1) {
+    return(sub("^bs_version_", "", version))
+  }
+
+  # If no version class, or more than one class, we consult the sass bundle
+  theme_preset_info(theme)$version
 }
 
 
@@ -86,6 +88,8 @@ bootswatch_bundle <- function(bootswatch, version) {
     bootswatch = sass_layer(
       file_attachments = attachments,
       defaults = list(
+        "bslib-preset-type" = "bootswatch",
+        "bslib-preset-name" = bootswatch,
         # Use local fonts (this path is relative to the bootstrap HTML dependency dir)
         '$web-font-path: "font.css" !default;',
         bootswatch_sass_file(bootswatch, "variables", version),

R/bs-theme-preset-builtin.R

@@ -29,6 +29,8 @@ builtin_bundle <- function(name = "shiny", version = version_default()) {
     "builtin" = sass_layer(
       file_attachments = attachments,
       defaults = list(
+        "bslib-preset-type" = "builtin",
+        "bslib-preset-name" = name,
         '$web-font-path: "font.css" !default;',
         sass_file(path_variables)
       ),

R/bs-theme-preset.R

@@ -13,8 +13,8 @@ resolve_bs_preset <- function(
   preset_name <- preset %||% bootswatch
 
   if (preset_name %in% c("default", "bootstrap")) {
-    # "default" means no preset bundle, just bare default Bootstrap
-    return(new_bs_preset("default", version))
+    # "bootstrap" means no preset bundle, just bare default Bootstrap
+    return(new_bs_preset("bootstrap", version))
   }
 
   builtin_themes <- builtin_themes(version)
@@ -33,47 +33,50 @@ resolve_bs_preset <- function(
 }
 
 new_bs_preset <- function(name, version, type = NULL) {
-  subclass <- if (!is.null(type)) paste0("bs_preset_", type)
-
-  preset_class <- if (!is.null(type)) {
-    name_safe <- gsub("[^[:alnum:]]", "_", name)
-    paste("bs", type, name_safe, sep = "_")
-  }
-
   preset <- list(
-    version = version,
-    name = name,
-    type = type,
-    class = preset_class
+    version = version, # bootstrap version
+    name = name,       # preset name
+    type = type,       # preset type (e.g. "builtin", "bootswatch")
+    theme_class = if (!is.null(type)) theme_preset_class()
   )
 
-  structure(dropNulls(preset), class = c(subclass, "bs_preset"))
-}
-
-# The `bs_preset_bundle()` function is the main entry point for creating a
-# SASS bundle for a theme preset. This currently dispatches to create a
-# bundle for a built-in theme or for a Bootswatch theme.
-bs_preset_bundle <- function(preset, ...) {
-  UseMethod("bs_preset_bundle", preset)
+  structure(dropNulls(preset), class = "bs_preset")
 }
 
-#' @export
-bs_preset_bundle.default <- function(preset, ...) {
-  # Sub-classes are used to create a bundle for a specific type of preset; this
-  # default case is used for "bare" Bootstrap, or an empty preset bundle.
-  NULL
-}
+# The `bs_preset_bundle()` function is the main entry point for creating a SASS
+# bundle for a theme preset. This calls out to the appropriate functions to
+# create a bundle for a built-in theme or for a Bootswatch theme.
+bs_preset_bundle <- function(preset) {
+  if (!inherits(preset, "bs_preset")) return(NULL)
+  if (is.null(preset$type)) return(NULL)
 
-#' @export
-bs_preset_bundle.bs_preset <- function(preset, ...) {
   switch(
-    preset$type %||% "",
-    builtin = builtin_bundle(preset$name, version = preset$version),
+    preset$type,
     bootswatch = bootswatch_bundle(preset$name, version = preset$version),
-    NextMethod()
+    builtin = builtin_bundle(preset$name, version = preset$version),
+    stop("Unknown preset type: ", preset$type)
   )
 }
 
+theme_preset_info <- function(theme) {
+  if (!is_bs_theme(theme)) return(NULL)
+
+  info <- bs_get_variables(theme, c("bslib-preset-type", "bslib-preset-name", "bootstrap-version"))
+
+  name <- info[["bslib-preset-name"]]
+  type <- info[["bslib-preset-type"]]
+
+  new_bs_preset(
+    name = if (!is.na(name)) name else "bootstrap",
+    version = info[["bootstrap-version"]],
+    type = if (!is.na(type)) type
+  )
+}
+
+theme_preset_class <- function() {
+  "bs_theme_with_preset"
+}
+
 assert_preset_scalar_string <- function(var, .frame = rlang::caller_env()) {
   var_name <- deparse(substitute(var))
 

R/bs-theme.R

@@ -63,12 +63,12 @@
 #'   over the `bootswatch` argument and only one `theme` or `bootswatch` can be
 #'   provided. When provided to `bs_theme_update()`, any previous preset theme
 #'   is first removed before the new theme preset is applied. You can use
-#'   `theme = "default"` to remove any preset theme and to revert to a base
+#'   `theme = "bootstrap"` to remove any preset theme and to revert to a base
 #'   Bootstrap theme.
 #' @param bootswatch The name of a bootswatch theme (see [bootswatch_themes()]
 #'   for possible values). When provided to `bs_theme_update()`, any previous
 #'   Bootswatch theme is first removed before the new one is applied (use
-#'   `bootswatch = "default"` to effectively remove the Bootswatch theme).
+#'   `bootswatch = "bootstrap"` to effectively remove the Bootswatch theme).
 #' @param ... arguments passed along to [bs_add_variables()].
 #' @param bg A color string for the background.
 #' @param fg A color string for the foreground.
@@ -128,11 +128,15 @@ bs_theme <- function(version = version_default(), preset = NULL, ...,
   preset <- resolve_bs_preset(preset, bootswatch, version = version)
 
   bundle <- bs_bundle(
-    bs_theme_init(version, subclass = preset$class),
+    bs_theme_init(version),
     bootstrap_bundle(version),
     bs_preset_bundle(preset)
   )
 
+  if (!is.null(preset$theme_class)) {
+    bundle <- add_class(bundle, preset$theme_class)
+  }
+
   bs_theme_update(
     bundle, ...,
     bg = bg, fg = fg,
@@ -159,23 +163,22 @@ bs_theme_update <- function(theme, ..., preset = NULL, bg = NULL, fg = NULL,
                             font_scale = NULL, bootswatch = NULL) {
   assert_bs_theme(theme)
 
-  theme_has_preset <- any(grepl("^bs_(builtin|bootswatch)_", class(theme)))
-
   preset <- resolve_bs_preset(preset, bootswatch, version = theme_version(theme))
 
   if (!is.null(preset)) {
-    if (theme_has_preset) {
-      old_preset_class <- grep("^bs_(builtin|bootswatch)_", class(theme), value = TRUE)
-      old_preset_type <- sub("^bs_(builtin|bootswatch)_.+", "\\1", old_preset_class)
+    theme_has_preset <- inherits(theme, theme_preset_class())
 
+    if (theme_has_preset) {
       # remove the old preset
-      theme <- bs_remove(theme, old_preset_type)
-      class(theme) <- setdiff(class(theme), old_preset_class)
+      theme <- bs_remove(theme, theme_preset_info(theme)$type)
+      class(theme) <- setdiff(class(theme), theme_preset_class())
     }
 
-    # Add the new preset (both no-op when preset$name is "default")
-    theme <- add_class(theme, preset$class)
-    theme <- bs_bundle(theme, bs_preset_bundle(preset))
+    # Add in the new preset unless vanilla bootstrap was requested
+    if (!identical(preset$name, "bootstrap")) {
+      theme <- add_class(theme, preset$theme_class)
+      theme <- bs_bundle(theme, bs_preset_bundle(preset))
+    }
   }
 
   # See R/bs-theme-update.R for the implementation of these
@@ -229,15 +232,23 @@ is_bs_theme <- function(x) {
 
 # Start an empty bundle with special classes that
 # theme_version() & theme_bootswatch() search for
-bs_theme_init <- function(version, subclass = NULL) {
-  add_class(
-    sass_layer(defaults = list("bootstrap-version" = version)),
-    c(
-      subclass,
-      paste0("bs_version_", version),
-      "bs_theme"
+bs_theme_init <- function(version) {
+  init_layer <- sass_layer(
+      defaults = list(
+        "bootstrap-version" = version,
+        "bslib-preset-name" = "null !default",
+        "bslib-preset-type" = "null !default"
+      ),
+      rules = c(
+        ":root {",
+        "--bslib-bootstrap-version: #{$bootstrap-version};",
+        "--bslib-preset-name: #{$bslib-preset-name};",
+        "--bslib-preset-type: #{$bslib-preset-type};",
+        "}"
+      )
     )
-  )
+
+  add_class(init_layer, c(paste0("bs_version_", version), "bs_theme"))
 }
 
 assert_bs_theme <- function(theme) {

tests/testthat/_snaps/bs-theme-preset.md

@@ -1,4 +1,4 @@
-# new_theme_preset(): throws an error if both `name` and `bootswatch` are provided
+# resolve_bs_preset(): throws an error if both `name` and `bootswatch` are provided
 
     Code
       resolve_bs_preset(preset = "name", bootswatch = "bootswatch")
@@ -9,7 +9,7 @@
       * `preset = "bootswatch"`
       * `bootswatch = "bootswatch"`
 
-# new_theme_preset(): throws an error if `name` or `bootswatch` are not scalar strings
+# resolve_bs_preset(): throws an error if `name` or `bootswatch` are not scalar strings
 
     Code
       resolve_bs_preset(preset = c("a", "b"))
@@ -27,7 +27,7 @@
       x Bad: `bootswatch = c("flatly", "darkly")`
       v Good: `bootswatch = "flatly"`
 
-# new_theme_preset(): throws an error if `name` or `bootswatch` don't match existing presets
+# resolve_bs_preset(): throws an error if `name` or `bootswatch` don't match existing presets
 
     Code
       resolve_bs_preset(preset = "not_a_preset", version = 4)

tests/testthat/test-bs-theme-preset-bootswatch.R

@@ -0,0 +1,21 @@
+test_that("theme_version() works for current versions", {
+  bs_versions <- versions()
+
+  for (bs_v in bs_versions) {
+    expect_equal(theme_version(bs_theme(!!bs_v)), !!bs_v)
+  }
+})
+
+test_that("theme_version() uses class first, then sass bundle", {
+  theme <- theme_unclassed <- bs_theme(version = 5)
+  class(theme_unclassed) <- setdiff(class(theme), "bs_version_5")
+  theme_99 <- add_class(theme_unclassed, "bs_version_99")
+
+  # These should use the class information
+  expect_equal(theme_version(theme), "5")
+  expect_equal(theme_version(theme_99), "99")
+
+  # These should consult the sass bundle
+  expect_equal(theme_version(add_class(theme, "bs_version_99")), "5")
+  expect_equal(theme_version(theme_unclassed), "5")
+})