1#' @include utils.R
2NULL
3
4#' Preview the currently set theme
5#'
6#' Launches an example shiny app via `run_with_themer()` and
7#' `bs_theme_dependencies()`. Useful for getting a quick preview of the current
8#' theme setting as well as an interactive GUI for tweaking some of the main
9#' theme settings.
10#'
11#' The app that this launches is subject to change.
12#'
13#' @inheritParams bs_theme_update
14#' @param ... passed along to [shiny::runApp()].
15#' @param with_themer whether or not to run the app with [run_with_themer()].
16#' @return nothing, this function is called for its side-effects (launching an
17#'   application).
18#' @seealso [run_with_themer()]
19#' @examples
20#' theme <- bs_theme(bg = "#6c757d", fg = "white", primary = "orange")
21#' if (interactive()) bs_theme_preview(theme)
22#' @export
23bs_theme_preview <- function(theme = bs_theme(), ..., with_themer = TRUE) {
24  assert_bs_theme(theme)
25  old_theme <- bs_global_get()
26  on.exit(bs_global_set(old_theme), add = TRUE)
27  bs_global_set(theme)
28  # TODO: add more this demo and also an option for launching different demos
29  app <- system_file("themer-demo", package = "bslib")
30  if (with_themer) {
31    run_with_themer(app, ...)
32  } else {
33    shiny::runApp(app, ...)
34  }
35}
36
37colorpicker_deps <- function() {
38  htmltools::htmlDependency(
39    "bootstrap-colorpicker",
40    "3.1.2",
41    lib_file("bs-colorpicker"),
42    stylesheet = "css/bootstrap-colorpicker.min.css",
43    script = "js/bootstrap-colorpicker.js"
44  )
45}
46
47opts_metadata <- function(theme) {
48  opts <- jsonlite::fromJSON(
49    system_file("themer/options.json", package = "bslib"),
50    simplifyDataFrame = FALSE
51  )
52  themes <- bootswatch_themes(theme_version(theme))
53  opts[[1]]$bootswatch$choices <- c("default", themes)
54  opts
55}
56
57bs_themer_ui <- function(opts, vals, theme) {
58
59  make_control <- function(id, opts) {
60    value <- vals[[id]]
61    lbl <- HTML(opts$label)
62    desc <- HTML(opts$desc)
63    text_input <- function(input_class = NULL, type = "text", ...) {
64      div(
65        class = "form-row form-group",
66        tags$label(lbl),
67        tags$input(
68          type = type, value = value, "data-id" = id,
69          class = "form-control form-control-sm bs-theme-value",
70          class = input_class, ...
71        ),
72        if (!is.null(desc)) div(class = "form-text small", desc)
73      )
74    }
75    switch(
76      opts$type,
77      color = text_input(input_class = "bs-theme-value-color text-monospace"),
78      str = text_input(input_class = "bs-theme-value-str"),
79      length = text_input(input_class = "bs-theme-value-length"),
80      number = text_input(input_class = "bs-theme-value-str", type = "number", step = opts$step),
81      bool = tagList(
82        div(
83          class = "form-check",
84          tags$input(
85            type = "checkbox", checked = if (value) NA else NULL,
86            class = "bs-theme-value bs-theme-value-bool form-check-input",
87            id = paste0(".bsthemer-", id), "data-id" = id
88          ),
89          tags$label("for" = paste0(".bsthemer-", id), class = "form-check-label", lbl)
90        ),
91        if (!is.null(desc)) div(class = "form-text small", desc)
92      ),
93      select = div(
94        class = "form-row form-group",
95        tags$label(class = "control-label", lbl),
96        tags$select(
97          class = "form-control", "data-id" = id,
98          class = "bs-theme-value bs-theme-value-select",
99          lapply(opts$choices, function(x) {
100            tags$option(
101              value = x, selected = if (identical(x, value)) NA else NULL,
102              tools::toTitleCase(x)
103            )
104          })
105        ),
106        if (!is.null(desc)) div(class = "form-text small", desc)
107      ),
108      stop("unknown type")
109    )
110  }
111
112  version <- theme_version(theme)
113  accordion <- lapply(seq_along(opts), function(i) {
114    opt_name <- names(opts)[[i]]
115    elId <- paste0("bsthemerCollapse", i)
116    btn <- tags$button(
117      class = if (version >= 5) "accordion-button" else "btn btn-link px-3 py-2 w-100 text-left border-0",
118      class = if (i != 1) "collapsed",
119      "data-toggle" = "collapse",
120      "data-target" = paste0("#", elId),
121      # data-bs-* is for BS5+
122      "data-bs-toggle" = "collapse",
123      "data-bs-target" = paste0("#", elId),
124      "aria-expanded" = "true", "aria-controls" = elId,
125      opt_name
126    )
127    controls <- lapply(seq_along(opts[[i]]), function(j) {
128      make_control(names(opts[[i]])[[j]], opts[[i]][[j]])
129    })
130    div(
131      class = if (version >= 5) "accordion-item",
132      div(
133        class = if (version >= 5) "accordion-header" else "card-header p-0 border-0",
134        btn
135      ),
136      div(
137        id = elId, class = if (i == 1) "show" else "collapse",
138        "data-parent" = "#bsthemerAccordion",
139        # data-bs-* is for BS5+
140        "data-bs-parent" = "#bsthemerAccordion",
141        class = if (version >= 5) "accordion-collapse",
142        div(
143          class = if (version >= 5) "accordion-body" else "card-body",
144          controls
145        )
146      )
147    )
148  })
149
150  withTags(tagList(
151    colorpicker_deps(),
152    htmlDependency(
153      "bs_themer", version = packageVersion("bslib"),
154      src = "themer", script = c("themer.js"),
155      package = "bslib", all_files = FALSE
156    ),
157
158    div(id = "bsthemerContainer",
159      class = "card shadow",
160      style = css(
161        # The bootstrap-colorpicker plugin sets a z-index of 1060 on
162        # it's inputs, so the container needs a smaller index, than that
163        # https://github.com/rstudio/bslib/blob/e4da71f3/inst/lib/bs-colorpicker/css/bootstrap-colorpicker.css#L38
164        #
165        # It's also important that this z-index is higher than 1030 so it's
166        # overlaid on-top of fixed/sticky navbars
167        # https://github.com/rstudio/bslib/blob/e4da71f3/inst/lib/bs/scss/_variables.scss#L697-L701
168        z_index = 1059, width = "18rem", max_height = "80vh",
169        position = "fixed", top = "1rem", right = "1rem", height = "auto"
170      ),
171
172      div(id = "bsthemerHeader",
173        class = "move-grabber", "data-target" = "#bsthemerContainer",
174        class = "card-header font-weight-bold bg-dark text-light px-3 py-2",
175        "Theme customizer",
176        tags$div(id = "bsthemerToggle", class = "float-right",
177          "data-toggle" = "collapse",
178          "data-target" = "#bsthemerAccordion",
179          # data-bs-* is for BS5+
180          "data-bs-toggle" = "collapse",
181          "data-bs-target" = "#bsthemerAccordion",
182          style = css(cursor = "pointer"),
183          tags$span(),
184          bs_dependency_defer(themer_css_dependency)
185        )
186      ),
187
188      div(
189        id = "bsthemerAccordion", class = "collapse show",
190        class = if (version >= 5) "accordion",
191        style = css(overflow_y = "auto"),
192        accordion
193      )
194    )
195  ))
196}
197
198themer_css_dependency <- function(theme) {
199  version <- utils::packageVersion("bslib")
200  bs_dependency(
201    input = sass_file(system_file("themer/themer.scss", package = "bslib")),
202    theme = theme,
203    name = "bs-themer-css",
204    version = version,
205    cache_key_extra = version
206  )
207}
208
209#' Theme customization UI
210#'
211#' A 'real-time' theme customization UI that you can use to easily make common
212#' tweaks to Bootstrap variables and immediately see how they would affect your
213#' app's appearance. There are two ways you can launch the theming UI. For most
214#' Shiny apps, just use `run_with_themer()` in place of [shiny::runApp()]; they
215#' should take the same arguments and work the same way. Alternatively, you can
216#' call the `bs_themer()` function from inside your server function (or in an R
217#' Markdown app that is using `runtime: shiny`, you can call this from any code
218#' chunk). Note that this function is only intended to be used for development!
219#'
220#' To help you utilize the changes you see in the preview, this utility prints
221#' [bs_theme()] code to the R console.
222#'
223#' @param appDir The application to run. This can be a file or directory path,
224#'   or a [shiny::shinyApp()] object. See [shiny::runApp()] for details.
225#' @param ... Additional parameters to pass through to [shiny::runApp()].
226#' @param gfonts whether or not to detect Google Fonts and wrap them in
227#'   [font_google()] (so that their font files are automatically imported).
228#' @param gfonts_update whether or not to update the internal database of
229#'   Google Fonts.
230#'
231#' @section Limitations:
232#'
233#'   * Doesn't work with Bootstrap 3.
234#'   * Doesn't work with IE11.
235#'   * Only works inside Shiny apps and `runtime: shiny` R Markdown documents.
236#'     * Can't be used with static R Markdown documents.
237#'     * Can be used to some extent with `runtime: shiny_prerendered`, but only UI
238#'       rendered through a `context="server"` may update in real-time.
239#'   * Doesn't work with '3rd party' custom widgets that don't make use of
240#'     [bs_dependency_defer()] or [bs_current_theme()].
241#'
242#' @return nothing. These functions are called for their side-effects.
243#'
244#' @examples
245#' library(shiny)
246#'
247#' ui <- fluidPage(
248#'   theme = bs_theme(bg = "black", fg = "white"),
249#'   h1("Heading 1"),
250#'   h2("Heading 2"),
251#'   p(
252#'     "Paragraph text;",
253#'     tags$a(href = "https://www.rstudio.com", "a link")
254#'   ),
255#'   p(
256#'     actionButton("cancel", "Cancel"),
257#'     actionButton("continue", "Continue", class = "btn-primary")
258#'   ),
259#'   tabsetPanel(
260#'     tabPanel("First tab",
261#'       "The contents of the first tab"
262#'     ),
263#'     tabPanel("Second tab",
264#'       "The contents of the second tab"
265#'     )
266#'   )
267#' )
268#'
269#' if (interactive()) {
270#'   run_with_themer(shinyApp(ui, function(input, output) {}))
271#' }
272#'
273#' @export
274run_with_themer <- function(appDir = getwd(), ..., gfonts = TRUE, gfonts_update = FALSE) {
275  shiny::runApp(
276    as_themer_app(appDir, gfonts = gfonts, gfonts_update = gfonts_update),
277    ...
278  )
279}
280
281as_themer_app <- function(appDir, gfonts = TRUE, gfonts_update = FALSE) {
282  obj <- shiny::as.shiny.appobj(appDir)
283  origServerFuncSource <- obj[["serverFuncSource"]]
284  obj[["serverFuncSource"]] <- function() {
285    origServerFunc <- origServerFuncSource()
286    function(input, output, session, ...) {
287      bs_themer(gfonts, gfonts_update)
288      if (!"session" %in% names(formals(origServerFunc))) {
289        origServerFunc(input, output, ...)
290      } else {
291        origServerFunc(input, output, session, ...)
292      }
293    }
294  }
295  obj
296}
297
298#' @rdname run_with_themer
299#' @export
300bs_themer <- function(gfonts = TRUE, gfonts_update = FALSE) {
301  session <- shiny::getDefaultReactiveDomain()
302  if (is.null(session)) {
303    stop(call. = FALSE, "`bslib::bs_themer()` must be called from within a ",
304         "Shiny server function")
305  }
306  if (!identical("ok", session$ns("ok"))) {
307    stop(call. = FALSE, "`bslib::bs_themer()` must be called from within a ",
308         "top-level Shiny server function, not a Shiny module server function")
309  }
310  if (!is_available("shiny", "1.6.0")) {
311    stop(call. = FALSE, "`bslib::bs_themer()` requires shiny v1.6.0 or higher")
312  }
313  theme <- get_current_theme()
314  if (!is_bs_theme(theme)) {
315    stop(call. = FALSE, "`bslib::bs_themer()` requires `shiny::bootstrapLib()` to be present ",
316         "in the app's UI. Consider providing `bslib::bs_theme()` to the theme argument of the ",
317         "relevant page layout function (or, more generally, adding `bootstrapLib(bs_theme())` to the UI.")
318  }
319  bootswatch <- theme_bootswatch(theme)
320  switch_version(
321    theme, three = stop("Interactive theming for Bootstrap 3 isn't supported")
322  )
323  if (isTRUE(session$userData[["bs_themer_init"]])) {
324    # bs_themer() was called multiple times for the same session
325    return()
326  } else {
327    session$userData[["bs_themer_init"]] <- TRUE
328  }
329
330  gfont_info <- if (isTRUE(gfonts)) get_gfont_info(gfonts_update)
331
332  # Insert the theming control panel with values informed by the theme settings
333  themer_opts <- opts_metadata(theme)
334  themer_vars <- unlist(unname(lapply(themer_opts, names)))
335  sass_vars <- setdiff(themer_vars, "bootswatch")
336  themer_vals <- as.list(get_themer_vals(theme, sass_vars))
337  themer_vals$bootswatch <- bootswatch
338  shiny::insertUI("body", where = "beforeEnd", ui = bs_themer_ui(themer_opts, themer_vals, theme))
339
340  input <- session$input
341
342  # We emit different 'code' for runtime:shiny in Rmd
343  isRmd <- is_shiny_runtime()
344
345  # When the bootswatch theme changes, update the themer's state to reflect
346  # the new variable defaults. Note that we also update the "input theme",
347  # and effectively throw out any other theming changes made (i.e., start from a new theme)
348  # since it'd be messy to figure out whether changes are "real" or just a
349  # consequence of a new bootswatch value
350  shiny::observeEvent(input$bs_theme_bootswatch, {
351    theme <<- set_current_theme(
352      theme, list(bootswatch = input$bs_theme_bootswatch),
353      session, rmd = isRmd
354    )
355    vals <- as.list(bs_get_variables(theme, sass_vars))
356    session$sendCustomMessage("bs-themer-bootswatch", list(values = vals))
357  })
358
359  # Fires when anything other then the Bootswatch theme changes
360  shiny::observeEvent(input$bs_theme_vars, {
361    vals <- jsonlite::parse_json(input$bs_theme_vars)
362
363    # Validate that `vals` is a simple list, containing atomic elements,
364    # that are all named
365    if (!identical(class(vals), "list") ||
366        !all(vapply(vals, is.atomic, logical(1))) ||
367        is.null(names(vals)) ||
368        !isTRUE(all(nzchar(names(vals), keepNA = TRUE)))) {
369      warning(call. = FALSE,
370        "bs_themer() encountered malformed input; ignoring"
371      )
372      return()
373    }
374
375    # Makes remaining logic simpler to reason about
376    if (length(vals) == 0) {
377      return()
378    }
379
380    # Remember, theme at this point has been updated to reflect the current Bootswatch theme,
381    # so re-query Sass values from the (possibly updated) theme, then filter down to meaningful
382    # differences
383    theme_vals <- get_themer_vals(theme, names(vals[sass_vars]))
384    changed_vals <- as.list(diff_css_values(vals[sass_vars], theme_vals))
385
386    if (!identical(bootswatch, input$bs_theme_bootswatch)) {
387      changed_vals$bootswatch <- input$bs_theme_bootswatch
388    }
389
390    # If _either_ fg/bg has changed, bs_theme() must to be called with *both* fg and bg populated.
391    if (any(c("bg", "fg") %in% names(changed_vals))) {
392      changed_vals[["bg"]] <- changed_vals[["bg"]] %||% vals[["bg"]]
393      changed_vals[["fg"]] <- changed_vals[["fg"]] %||% vals[["fg"]]
394    }
395
396    # Change variables names to their 'high-level' equivalents
397    changed_vals <- rename2(
398      changed_vals,
399      "font-family-base" = "base_font", "font-family-monospace" = "code_font",
400      "headings-font-family" = "heading_font",
401      "font-size-base" = "font_scale"
402    )
403
404    if (length(changed_vals$font_scale)) {
405      changed_vals$font_scale <- as.numeric(changed_vals$font_scale)
406    }
407
408    if (isTRUE(gfonts)) {
409      for (var in c("base_font", "code_font", "heading_font")) {
410        changed_vals[[var]] <- insert_font_google_call(changed_vals[[var]], gfont_info)
411      }
412    }
413
414    set_current_theme(theme, changed_vals, session, rmd = isRmd)
415  })
416}
417
418
419get_themer_vals <- function(theme, vars) {
420  vals <- bs_get_variables(theme, vars)
421  if (!grepl("rem$", vals[["font-size-base"]])) {
422    stop("font-size-base must have a CSS unit length type of rem", call. = FALSE)
423  }
424  vals[["font-size-base"]] <- sub("rem$", "", vals[["font-size-base"]])
425  vals
426}
427
428set_current_theme <- function(theme, changed_vals, session, rmd = FALSE) {
429  shiny::insertUI("body", ui = spinner_overlay(), immediate = TRUE, session = session)
430  on.exit(shiny::removeUI("body > #spinner_overlay"), add = TRUE)
431
432  # Construct the code/yaml to display to the user
433  if (isTRUE(rmd)) {
434    display_vals <- lapply(changed_vals, function(x) {
435      if (is.numeric(x)) {
436        return(x)
437      }
438      if (rlang::is_call(x)) {
439        str <- paste0(deparse(x, width.cutoff = 500L), collapse = "")
440        return(paste("!expr", str))
441      }
442      # To avoid yaml parse errors with values that contain # or ",
443      # first escape ", then in quote the value
444      paste0('"', gsub('"', '\\"', x, fixed = TRUE), '"')
445    })
446    message("\n####  Update your Rmd output format's theme:  ####")
447    cat(paste0(
448      "    theme:\n",
449      paste0(
450        collapse = "\n", "      ", names(display_vals), ": ", display_vals
451      ),
452      "\n"
453    ))
454  } else {
455    message("\n####  Update your bs_theme() R code with:  #####")
456    print(rlang::expr(bs_theme_update(theme, !!!changed_vals)))
457  }
458
459  # Color contrast warnings are more annoying then they are useful inside the theming widget
460  opts <- options(bslib.color_contrast_warnings = FALSE)
461  on.exit(options(opts), add = TRUE)
462
463  # the actual code that we evaluate should not have quoted expressions
464  changed_vals[] <- lapply(changed_vals, eval_val)
465  code <- rlang::expr(bs_theme_update(theme, !!!changed_vals))
466  theme <- rlang::eval_tidy(code)
467  # Prevent Sass compilation errors from crashing the app and relay a message to user.
468  # Errors can happen if the users enters values that lead to unexpected Sass
469  # expressions (e.g., "$foo: * !default")
470  shiny::removeNotification("sass-compilation-error", session = session)
471  tryCatch(
472    session$setCurrentTheme(theme),
473    error = function(e) {
474      shiny::showNotification(
475        "Sass -> CSS compilation failed, likely due to invalid user input.
476         Other theming changes won't take effect until the invalid input is fixed.",
477        duration = NULL,
478        id = "sass-compilation-error",
479        type = "error",
480        session = session
481      )
482    }
483  )
484  invisible(theme)
485}
486
487spinner_overlay <- function() {
488  tagList(
489    tags$style(
490      "@supports ((-webkit-backdrop-filter:blur(4px)) or (backdrop-filter:blur(4px))) {
491        #spinner_overlay{ -webkit-backdrop-filter:blur(4px); backdrop-filter:blur(4px); background-color:rgba(255,255,255,.05);}
492      }"
493    ),
494    div(
495      id = "spinner_overlay",
496      style = "position:absolute; top:0; left:0; min-height:100vh; width:100%; background-color:rgba(255,255,255,.8); z-index:100000",
497      class = "d-flex flex-column justify-content-center align-items-center",
498      div(
499        class = "spinner-border",
500        style = "width:5rem; height:5rem; color: rgba(0,0,0,0.8);",
501        role = "status",
502        span(class = "sr-only visually-hidden", "Refreshing stylesheets...")
503      ),
504      span(class = "lead mt-1", style = "color: rgba(0,0,0,0.8);", "Refreshing stylesheets...")
505    )
506  )
507}
508
509eval_val <- function(x) {
510  if (is.call(x)) return(eval(x))
511  if (!is.list(x)) return(x)
512  lapply(x, eval_val)
513}
514
515insert_font_google_call <- function(val, gfont_info) {
516  # val should be a non-empty character string
517  if (!is_string(val)) return(NULL)
518  if (!nzchar(val)) return(NULL)
519  fams <- strsplit(as.character(val), ",")[[1]]
520  fams <- vapply(
521    fams, function(x) gsub("^\\s*['\"]?", "", gsub("['\"]?\\s*$", "", x)),
522    character(1), USE.NAMES = FALSE
523  )
524  fams <- fams[nzchar(fams)]
525  is_a_gfont <- tolower(fams) %in% tolower(gfont_info$family)
526  if (length(fams) == 1) {
527    return(if (is_a_gfont) call("font_google", fams) else fams)
528  }
529  fams <- as.list(fams)
530  for (i in which(is_a_gfont)) {
531    fams[[i]] <- call("font_google", fams[[i]])
532  }
533  rlang::expr(font_collection(!!!unname(fams)))
534}
535
536
537get_gfont_info <- function(update = FALSE) {
538  if (isTRUE(update)) {
539    jsonlite::fromJSON(gfont_api_url())$items
540  } else {
541    # See tools/update_gfont_info.R
542    gfont_info
543  }
544}
545
546# same as thematic:::gfont_api_url
547gfont_api_url <- function() {
548  paste0("https://www.googleapis.com/webfonts/v1/webfonts?key=", gfont_key())
549}
550# same as thematic:::gfont_key
551# As mentioned in the developer API, this key is safe to be public facing
552# https://developers.google.com/fonts/docs/developer_api
553gfont_key <- function() {
554  Sys.getenv("GFONT_KEY", paste0("AIzaSyDP", "KvElVqQ-", "26f7tjxyg", "IGpIajf", "tS_zmas"))
555}
556
557#' Retrieve Sass variable values from the current theme
558#'
559#' Useful for retriving a variable from the current theme and using
560#' the value to inform another R function.
561#'
562#' @inheritParams bs_theme_update
563#' @param varnames a character string referencing a Sass variable
564#' in the current theme.
565#' @return a character string containing a CSS/Sass value.
566#' If the variable(s) are not defined, their value is `NA`.
567#'
568#' @export
569#' @examples
570#' vars <- c("body-bg", "body-color", "primary", "border-radius")
571#' bs_get_variables(bs_theme(), varnames = vars)
572#' bs_get_variables(bs_theme(bootswatch = "darkly"), varnames = vars)
573#'
574bs_get_variables <- function(theme, varnames) {
575  if (length(varnames) == 0) {
576    return(stats::setNames(character(0), character(0)))
577  }
578
579  # Our bg/fg are not actual Sass variables and can mean different things depending
580  # on the bootswatch theme/version
581  base_color_idx <- varnames %in% c("fg", "bg")
582  if (any(base_color_idx)) {
583    varnames[base_color_idx] <- rename2(
584      varnames[base_color_idx], !!!get_base_color_map(theme)
585    )
586  }
587
588  assert_bs_theme(theme)
589
590  # Support both `bs_get_variables("$foo")` and `bs_get_variables("foo")`
591  # (note that `sass::sass("$$foo:1;")` is illegal; so this seems safe)
592  varnames <- sub("^\\$", "", varnames)
593
594  # It's possible that some varnames refer to variables that aren't defined.
595  # This would normally cause a crash. We define last-ditch defaults here,
596  # with a magic constant that we can swap out for NA before returning to
597  # the user.
598  na_sentinel <- "NA_SENTINEL_CONSTANT_4902F4E"
599  sassvars <- paste0(
600    "$", varnames, ": ", na_sentinel, " !default;",
601    collapse = "\n"
602  )
603
604  # Declare a block with a meaningless but identifiable selector (.__rstudio_bslib_get_variables)
605  # and add properties for each variable that is desired.
606  cssvars <- paste0(
607    "--", varnames, ": #{inspect($", varnames, ")};",
608    collapse = "\n"
609  )
610  cssvars <- sprintf(":root.__rstudio_bslib_get_variables {\n %s \n}", cssvars)
611
612  css <- sass_partial(
613    cssvars,
614    # Add declarations to the current theme
615    bs_bundle(theme, sass_layer(mixins = sassvars)),
616  )
617
618  # Search the output for the block of properties we just generated, using the
619  # ".__rstudio_bslib_get_variables" selector. The capture group will include all of the
620  # properties we care about in a single string (the propstr variable below).
621  matches <- regexec("(:root)?\\.__rstudio_bslib_get_variables(:root)?\\s*\\{\\s*\\n(.*?)\\n\\s*\\}", css)
622  propstr <- regmatches(css, matches)[[1]][4]
623  if (is.na(propstr)) {
624    stop("bs_global_get_variables failed; expected selector was not found")
625  }
626  # Split the propstr by newline, so we can perform vectorized regex operations
627  # on all of the variables at once.
628  proplines <- strsplit(propstr, "\n")[[1]]
629
630  # Parse each line for the name and value.
631  matches2 <- regmatches(proplines, regexec("\\s*--([^:]+):\\s*(.*);$", proplines))
632  names <- vapply(matches2, function(x) x[2], character(1))
633  values <- vapply(matches2, function(x) x[3], character(1))
634
635  if (any(is.na(names))) {
636    stop("bs_global_get_variables failed; generated output was in an unexpected format")
637  }
638  if (!identical(varnames, names)) {
639    stop("bs_global_get_variables failed; expected properties were not found")
640  }
641
642  # Any variables that had to fall back to our defaults, we'll replace with NA
643  values[values == na_sentinel] <- NA_character_
644
645
646  if (any(base_color_idx)) {
647    varnames[base_color_idx] <- rename2(
648      varnames[base_color_idx], !!!get_base_color_map(theme, decode = FALSE)
649    )
650  }
651
652  # Return as a named character vector
653  stats::setNames(values, varnames)
654}
655
656
657diff_css_values <- function(a, b) {
658  stopifnot(all(!is.na(a)))
659  stopifnot(identical(names(a), names(b)))
660  stopifnot(is.list(a))
661  if(!is.character(b))browser()
662
663  a_char <- vapply(a, function(x) {
664    if (is.null(x) || isTRUE(is.na(x))) {
665      "null"
666    } else if (is.logical(x)) {
667      tolower(as.character(x))
668    } else if (is.character(x)) {
669      x
670    } else {
671      as.character(x)
672    }
673  }, character(1))
674
675  b <- ifelse(is.na(b), "null", b)
676
677  # Normalize colors; ignore things that don't seem to be colors. This is
678  # necessary so we don't consider "black", "#000", "#000000", "rgb(0,0,0,1)",
679  # etc. to be distinct values.
680  #
681  # Note: This won't work with values that are colors AND other things, like
682  # "solid #000 3px"; it needs the value to be solely a color to be normalized.
683
684  a_char_colors <- htmltools::parseCssColors(a_char, mustWork = FALSE)
685  a_char <- ifelse(!is.na(a_char_colors), a_char_colors, a_char)
686
687  b_colors <- htmltools::parseCssColors(b, mustWork = FALSE)
688  b <- ifelse(!is.na(b_colors), b_colors, b)
689
690  idx <- ifelse(is.na(b), TRUE, a_char != b)
691  a[idx]
692}
693
694#' @rdname bs_get_variables
695#' @inheritParams bs_get_variables
696#' @export
697#' @examples
698#'
699#' bs_get_contrast(bs_theme(), c("primary", "dark", "light"))
700#'
701#' library(htmltools)
702#' div(
703#'   class = "bg-primary",
704#'   style = css(
705#'     color = bs_get_contrast(bs_theme(), "primary")
706#'   )
707#' )
708#'
709bs_get_contrast <- function(theme, varnames) {
710  stopifnot(is.character(varnames))
711  stopifnot(length(varnames) > 0)
712
713  varnames <- sub("^\\$", "", varnames)
714  prop_string <- paste0(
715    paste0(varnames, ": color-contrast($", varnames, ");"),
716    collapse = "\n"
717  )
718  css <- sass::sass_partial(
719    paste0("bs_get_contrast {", prop_string, "}"),
720    theme, cache_key_extra = packageVersion("bslib"),
721    # Don't listen to global Sass options so we can be sure
722    # that stuff like source maps won't be included
723    options = sass::sass_options(source_map_embed = FALSE)
724  )
725  css <- gsub("\n", "", gsub("\\s*", "", css))
726  css <- sub("bs_get_contrast{", "", css, fixed = TRUE)
727  css <- sub("\\}$", "", css)
728  props <- strsplit(strsplit(css, ";")[[1]], ":")
729  setNames(
730    vapply(props, function(x) htmltools::parseCssColors(sub(";$", "", x[2])), character(1)),
731    vapply(props, `[[`, character(1), 1)
732  )
733}
734