1# ----------------------------------------------------------------------------------------
2# Base colors
3# ----------------------------------------------------------------------------------------
4
5bs_base_colors <- function(theme, bg = NULL, fg = NULL) {
6  assert_bs_theme(theme)
7  if (is.null(bg) && is.null(fg)) return(theme)
8  if (is.null(bg)) stop("Cannot specify bg without fg.")
9  if (is.null(fg)) stop("Cannot specify fg without bg.")
10
11  args <- validate_and_normalize_colors(list(bg = bg, fg = fg))
12  # In some cases, bg/fg really means $body-bg/$body-color, not $white/$black
13  use_body <- has_body_base_colors(theme)
14  if (use_body) {
15    args <- rename2(args, !!!get_base_color_map(theme))
16  }
17
18  switch_add_variables(
19    theme, args,
20    default = if (use_body) identity else bs4_base_colors,
21    three = if (use_body) identity else bs3_base_colors
22  )
23}
24
25switch_add_variables <- function(theme, args, ...) {
26  func <- switch_version(theme, ...)
27  vars <- do.call(func, list(args))
28  bs_add_variables(theme, !!!vars)
29}
30
31# Obtain a mapping from (to) fg/bg to (from) relevant Sass vars
32get_base_color_map <- function(theme, decode = TRUE) {
33  use_body <- has_body_base_colors(theme)
34  vars <- switch_version(
35    theme,
36    three = list("body-bg", if (use_body) "text-color" else "gray-base"),
37    default = if (use_body) list("body-bg", "body-color") else list("white", "black")
38  )
39  if (decode) {
40    setNames(vars, c("bg", "fg"))
41  } else {
42    setNames(c("bg", "fg"), vars)
43  }
44}
45
46# We've modified these "dark mode" themes to be more themable by cascading
47# defaults from $body-bg/$body-color instead of $white/$black
48has_body_base_colors <- function(theme) {
49  body_themes <- c("darkly", "cyborg", "superhero", "slate")
50  # TODO: do the same for BS3? I guess?
51  isTRUE(theme_bootswatch(theme) %in% body_themes)
52}
53
54bs4_base_colors <- function(args) {
55  white <- args$bg
56  black <- args$fg
57
58  grays <- grDevices::colorRamp(c(white, black), alpha = TRUE)(0:10/10)
59
60  if (any(grays[,4] != 255)) {
61    warning(call. = FALSE,
62      "bs_base_colors does not respect alpha in `white` and `black` arguments"
63    )
64  }
65
66  grays <- sprintf("#%02X%02X%02X",
67    round(grays[,1]),
68    round(grays[,2]),
69    round(grays[,3])
70  )
71
72  names(grays) <- c(
73    "white",
74    paste0("gray-", 1:9 * 100),
75    "black"
76  )
77
78  as.list(grays)
79}
80
81bs3_base_colors <- function(args) {
82  white <- args$bg
83  black <- args$fg
84
85  ramp <- grDevices::colorRamp(c(black, white))
86  gray <- function(level = 255) {
87    val <- round(ramp(level / 255))
88    sprintf("#%02X%02X%02X", val[1,1], val[1,2], val[1,3])
89  }
90
91  result_colors <- list(
92    "gray-base" = gray(0x00),
93    "gray-darker" = gray(0x22),
94    "gray-dark" = gray(0x33),
95    "gray" = gray(0x55),
96    "gray-light" = gray(0x77),
97    "gray-lighter" = gray(0xEE),
98
99    "gray-44" = gray(0x44),
100    "gray-88" = gray(0x88),
101    "gray-99" = gray(0x99),
102    "gray-cc" = gray(0xcc),
103    "gray-dd" = gray(0xdd),
104    "gray-e5" = gray(0xe5),
105    "gray-f5" = gray(0xf5),
106    "gray-f8" = gray(0xf8),
107    "gray-f9" = gray(0xf9),
108    "white" = gray(0xff),
109    "black" = gray(0x00)
110  )
111
112  # There's code in tools/bs3_theme_base_colors.R for generating this list.
113  color_mapping <- list(
114    `dropdown-caret-color` = "$gray-base", `tooltip-bg` = "$gray-base",
115    `modal-backdrop-bg` = "$gray-base", `close-color` = "$gray-base",
116    `navbar-inverse-bg` = "$gray-darker", `btn-default-color` = "$gray-dark",
117    `navbar-default-link-hover-color` = "$gray-dark", `navbar-inverse-toggle-hover-bg` = "$gray-dark",
118    `navbar-inverse-toggle-border-color` = "$gray-dark", `list-group-link-heading-color` = "$gray-dark",
119    `kbd-bg` = "$gray-dark", `navbar-inverse-link-disabled-color` = "$gray-44",
120    `navbar-default-link-active-color` = "$gray", `list-group-link-color` = "$gray",
121    `navbar-default-color` = "$gray-light", `navbar-default-link-color` = "$gray-light",
122    `navbar-default-toggle-icon-bar-bg` = "$gray-88", `input-color-placeholder` = "$gray-99",
123    `modal-content-fallback-border-color` = "$gray-99", `btn-default-border` = "$gray-cc",
124    `input-border` = "$gray-cc", `dropdown-fallback-border` = "$gray-cc",
125    `navbar-default-link-disabled-color` = "$gray-cc", `popover-fallback-border-color` = "$gray-cc",
126    `breadcrumb-color` = "$gray-cc", `pre-border-color` = "$gray-cc",
127    `table-border-color` = "$gray-dd", `navbar-default-toggle-hover-bg` = "$gray-dd",
128    `navbar-default-toggle-border-color` = "$gray-dd", `nav-tabs-border-color` = "$gray-dd",
129    `nav-tabs-active-link-hover-border-color` = "$gray-dd", `nav-tabs-justified-link-border-color` = "$gray-dd",
130    `pagination-border` = "$gray-dd", `pagination-hover-border` = "$gray-dd",
131    `pagination-disabled-border` = "$gray-dd", `list-group-border` = "$gray-dd",
132    `panel-inner-border` = "$gray-dd", `panel-default-border` = "$gray-dd",
133    `thumbnail-border` = "$gray-dd", `legend-border-color` = "$gray-e5",
134    `dropdown-divider-bg` = "$gray-e5", `modal-header-border-color` = "$gray-e5",
135    `table-bg-hover` = "$gray-f5", `dropdown-link-hover-bg` = "$gray-f5",
136    `progress-bg` = "$gray-f5", `list-group-hover-bg` = "$gray-f5",
137    `panel-footer-bg` = "$gray-f5", `panel-default-heading-bg` = "$gray-f5",
138    `well-bg` = "$gray-f5", `breadcrumb-bg` = "$gray-f5", `code-bg` = "$gray-f5",
139    `pre-bg` = "$gray-f5", `navbar-default-bg` = "$gray-f8",
140    `table-bg-accent` = "$gray-f9", `body-bg` = "$white", `btn-default-bg` = "$white",
141    `btn-primary-color` = "$white", `btn-success-color` = "$white",
142    `btn-info-color` = "$white", `btn-warning-color` = "$white",
143    `btn-danger-color` = "$white", `input-bg` = "$white", `dropdown-bg` = "$white",
144    `navbar-inverse-link-hover-color` = "$white", `navbar-inverse-brand-hover-color` = "$white",
145    `navbar-inverse-toggle-icon-bar-bg` = "$white", `pagination-bg` = "$white",
146    `pagination-active-color` = "$white", `pagination-disabled-bg` = "$white",
147    `tooltip-color` = "$white", `popover-bg` = "$white", `label-color` = "$white",
148    `label-link-hover-color` = "$white", `modal-content-bg` = "$white",
149    `progress-bar-color` = "$white", `list-group-bg` = "$white",
150    `panel-bg` = "$white", `panel-primary-text` = "$white", `badge-color` = "$white",
151    `badge-link-hover-color` = "$white", `badge-active-bg` = "$white",
152    `carousel-control-color` = "$white", `carousel-indicator-active-bg` = "$white",
153    `carousel-indicator-border-color` = "$white", `carousel-caption-color` = "$white",
154    `close-text-shadow` = "$white", `kbd-color` = "$white"
155  )
156
157  results <- c(result_colors, color_mapping)
158
159  results
160}
161
162# ----------------------------------------------------------------------------------------
163# Accent colors
164# ----------------------------------------------------------------------------------------
165
166bs_accent_colors <- function(theme, primary = NULL, secondary = NULL,
167                             success = NULL, info = NULL, warning = NULL, danger = NULL) {
168  assert_bs_theme(theme)
169
170  args <- validate_and_normalize_colors(
171    list(
172      primary = primary, secondary = secondary, success = success,
173      info = info, warning = warning, danger = danger
174    )
175  )
176
177  switch_add_variables(
178    theme, args, three = bs3_accent_colors, default = identity
179  )
180}
181
182
183bs3_accent_colors <- function(args) {
184  # Warns and filters out unsupported arguments
185  supported <- c("primary", "success", "info", "warning", "danger")
186
187  args <- retain_known_vars("Bootstrap 3", "accent color", supported, args)
188
189  # Bootstrap 3 uses brand-primary, brand-danger, etc. as var names
190  if (length(args) > 0) {
191    names(args) <- paste0("brand-", names(args))
192  }
193
194  args
195}
196
197# ----------------------------------------------------------------------------------------
198# Fonts
199# ----------------------------------------------------------------------------------------
200
201bs_fonts <- function(theme, base = NULL, code = NULL, heading = NULL) {
202  assert_bs_theme(theme)
203  args <- dropNulls(list(
204    base = base,
205    code = code,
206    heading = heading
207  ))
208  args <- lapply(args, as_font_collection)
209  switch_add_variables(theme, args, three = bs3_fonts, default = bs4_fonts)
210}
211
212as_font_collection <- function(x) {
213  if (sass::is_font_collection(x)) {
214    return(x)
215  }
216  do.call(sass::font_collection, as.list(x))
217}
218
219
220bs4_fonts <- function(args) {
221  name_map <- c(
222    base = "font-family-base",
223    code = "font-family-monospace",
224    heading = "headings-font-family",
225    # TODO: we don't have a input_font...should we?
226    input = "input-btn-font-family"
227  )
228
229  names(args) <- name_map[names(args)]
230  args
231}
232
233bs3_fonts <- function(args) {
234  name_map <- c(
235    base = "font-family-base",
236    code = "font-family-monospace",
237    heading = "headings-font-family"
238  )
239
240  args <- retain_known_vars("Bootstrap 3", "font", names(name_map), args)
241
242  names(args) <- name_map[names(args)]
243  args
244}
245
246#' Ensures all arguments are either NULL, or length 1 character vectors with
247#' valid CSS color strings; returned is a list with no NULLs and normalized
248#' color strings
249#' @param args A named list
250#' @noRd
251validate_and_normalize_colors <- function(args) {
252  args <- dropNulls(args)
253  if (length(args) == 0) return(args)
254
255  is_char <- vapply(args, is.character, logical(1))
256  vec_len <- vapply(args, length, integer(1))
257  bad <- !is_char | vec_len != 1
258  if (any(bad)) {
259    stop(call. = FALSE,
260      "Invalid HTML color strings for argument(s) ",
261      format_varnames(names(args)[bad]),
262      "; single-element character vectors are required")
263  }
264  args <- lapply(args, htmltools::parseCssColors, mustWork = FALSE)
265  bad <- vapply(args, rlang::is_na, logical(1))
266  if (any(bad)) {
267    stop(
268      "Invalid HTML color strings for argument(s) ",
269      format_varnames(names(args)[bad]), call. = FALSE
270    )
271  }
272  args
273}
274
275
276#' Remove unsupported arguments, with a nicely formatted warning
277#'
278#' @param caller_name String naming the calling function; used for error
279#'   messages
280#' @param arg_name A name for the group of variables (e.g., accent, font); used for error messages
281#' @param supported_vars Character vector of known names
282#' @param args List of args
283#' @return List with unsupported vars removed, possibly warning in the process
284#' @noRd
285retain_known_vars <- function(caller_name, arg_name = "", supported_vars, args) {
286  argnames <- names(args)
287  unknown_idx <- !argnames %in% supported_vars
288
289  if (any(unknown_idx)) {
290    warning(call. = FALSE,
291      caller_name, " doesn't support the following ",
292      arg_name, if (nzchar(arg_name)) " ",
293      "argument(s), they will be ignored: ",
294      format_varnames(argnames[unknown_idx])
295    )
296  }
297
298  args[!unknown_idx]
299}
300
301# Format a vector of variable names
302format_varnames <- function(varnames, quot = "`", delim = ", ") {
303  between <- paste0(quot, delim, quot)
304
305  paste0(
306    quot,
307    paste(collapse = between, varnames),
308    quot
309  )
310}
311