| #' if (requireNamespace("scales", quietly = TRUE)) { | #' if (requireNamespace("scales", quietly = TRUE)) { | ||||
| #' scales::show_col(c(blue_light, blue, blue_dark)) | #' scales::show_col(c(blue_light, blue, blue_dark)) | ||||
| #' } | #' } | ||||
| #' | |||||
| #' @return A character string with the lightened or darkened color in | #' @return A character string with the lightened or darkened color in | ||||
| #' hexadecimal format. | #' hexadecimal format. | ||||
| #' @name lighten_darken_color | #' @name lighten_darken_color | ||||
| #' if (requireNamespace("scales", quietly = TRUE)) { | #' if (requireNamespace("scales", quietly = TRUE)) { | ||||
| #' scales::show_col(c(blue, blue_transparent)) | #' scales::show_col(c(blue, blue_transparent)) | ||||
| #' } | #' } | ||||
| #' | |||||
| #' @return A character string with added opacity level as hexadecimal characters. | #' @return A character string with added opacity level as hexadecimal characters. | ||||
| #' @export | #' @export | ||||
| apply_alpha <- function(color_hex, opacity = 0.5) { | apply_alpha <- function(color_hex, opacity = 0.5) { | ||||
| #' if (requireNamespace("scales", quietly = TRUE)) { | #' if (requireNamespace("scales", quietly = TRUE)) { | ||||
| #' scales::show_col(c(light_green, contrast_green, dark_purple, contrast_purple)) | #' scales::show_col(c(light_green, contrast_green, dark_purple, contrast_purple)) | ||||
| #' } | #' } | ||||
| #' | |||||
| #' @return The `black` color or `white` color according to which color provides | #' @return The `black` color or `white` color according to which color provides | ||||
| #' the greates contrast with the input color. | #' the greates contrast with the input color. | ||||
| #' | #' |
| "boxplot" = list(color = text_color), | "boxplot" = list(color = text_color), | ||||
| "contour" = list(color = text_color), | "contour" = list(color = text_color), | ||||
| "density" = list(color = text_color, | "density" = list(color = text_color, | ||||
| fill = text_color, | |||||
| alpha = 0.1), | |||||
| fill = text_color, | |||||
| alpha = 0.1), | |||||
| "dotplot" = list(color = accent_color), | "dotplot" = list(color = accent_color), | ||||
| "errorbarh" = list(color = text_color), | "errorbarh" = list(color = text_color), | ||||
| "crossbar" = list(color = text_color), | "crossbar" = list(color = text_color), | ||||
| "step" = list(color = text_color), | "step" = list(color = text_color), | ||||
| "point" = list(color = accent_color), | "point" = list(color = accent_color), | ||||
| "polygon" = list(color = accent_color, | "polygon" = list(color = accent_color, | ||||
| fill = accent_color), | |||||
| fill = accent_color), | |||||
| "quantile" = list(color = text_color), | "quantile" = list(color = text_color), | ||||
| "rug" = list(color = blend(0.5)), | "rug" = list(color = blend(0.5)), | ||||
| "segment" = list(color = text_color), | "segment" = list(color = text_color), | ||||
| "smooth" = list(fill = blend(0.75), | "smooth" = list(fill = blend(0.75), | ||||
| color = accent_secondary_color), | |||||
| color = accent_secondary_color), | |||||
| "spoke" = list(color = text_color), | "spoke" = list(color = text_color), | ||||
| "label" = list(color = text_color, | "label" = list(color = text_color, | ||||
| family= text_font %||% get_theme_font("text")), | |||||
| family= text_font %||% get_theme_font("text")), | |||||
| "text" = list(color = text_color, | "text" = list(color = text_color, | ||||
| family= text_font %||% get_theme_font("text")), | |||||
| family= text_font %||% get_theme_font("text")), | |||||
| "rect" = list(fill = text_color), | "rect" = list(fill = text_color), | ||||
| "tile" = list(fill = text_color), | "tile" = list(fill = text_color), | ||||
| "violin" = list(fill = text_color), | "violin" = list(fill = text_color), | ||||
| #' # Fill color matches teal text | #' # Fill color matches teal text | ||||
| #' scale_xaringan_color_discrete(direction = -1) | #' scale_xaringan_color_discrete(direction = -1) | ||||
| #' } | #' } | ||||
| #' | |||||
| #' @name scale_xaringan | #' @name scale_xaringan | ||||
| NULL | NULL | ||||
| #' theme_xaringan_get_value("background_color") | #' theme_xaringan_get_value("background_color") | ||||
| #' theme_xaringan_get_value("header_color") | #' theme_xaringan_get_value("header_color") | ||||
| #' theme_xaringan_get_value("text_bold_color") | #' theme_xaringan_get_value("text_bold_color") | ||||
| #' | |||||
| #' @return The value of the xaringanthemer style parameter. | #' @return The value of the xaringanthemer style parameter. | ||||
| #' @export | #' @export | ||||
| theme_xaringan_get_value <- function(setting, css_file = NULL) { | theme_xaringan_get_value <- function(setting, css_file = NULL) { |
| list2fonts <- function(fonts) { | list2fonts <- function(fonts) { | ||||
| if ( | if ( | ||||
| length(setdiff(names(google_font('fam')), names(fonts))) == 0 && | length(setdiff(names(google_font('fam')), names(fonts))) == 0 && | ||||
| !inherits(fonts, "google_font") | |||||
| !inherits(fonts, "google_font") | |||||
| ) { | ) { | ||||
| # concatenating a string and a google_font() provides a wacky list | # concatenating a string and a google_font() provides a wacky list | ||||
| stop( | stop( |
| force(code_font_family) | force(code_font_family) | ||||
| force(code_font_url) | force(code_font_url) | ||||
| force(code_font_family_fallback) | force(code_font_family_fallback) | ||||
| # the defaults are google fonts | # the defaults are google fonts | ||||
| is_default <- function(type, suffix) { | is_default <- function(type, suffix) { | ||||
| # check if font arg value is from xaringanthemer_font_default | # check if font arg value is from xaringanthemer_font_default | ||||
| r_set_font_is_google <- glue::glue("{var}_font_is_google <- {var_is_google}") | r_set_font_is_google <- glue::glue("{var}_font_is_google <- {var_is_google}") | ||||
| eval(parse(text = r_set_font_is_google)) | eval(parse(text = r_set_font_is_google)) | ||||
| } | } | ||||
| # Make sure font names are wrapped in quotes if they have spaces | # Make sure font names are wrapped in quotes if they have spaces | ||||
| f_args <- names(formals(sys.function())) | f_args <- names(formals(sys.function())) | ||||
| for (var in f_args[grepl("font_family$", f_args)]) { | for (var in f_args[grepl("font_family$", f_args)]) { | ||||
| eval(parse(text = paste0(var, "<-quote_elements_w_spaces(", var, ")"))) | eval(parse(text = paste0(var, "<-quote_elements_w_spaces(", var, ")"))) | ||||
| } | } | ||||
| } | } | ||||
| # Warn if base_font_size isn't absolute | # Warn if base_font_size isn't absolute | ||||
| css_abs_units <- c("cm", "mm", "Q", "in", "pc", "pt", "px") | css_abs_units <- c("cm", "mm", "Q", "in", "pc", "pt", "px") | ||||
| if (!grepl(paste(tolower(css_abs_units), collapse = "|"), tolower(base_font_size))) { | if (!grepl(paste(tolower(css_abs_units), collapse = "|"), tolower(base_font_size))) { | ||||
| immediate. = TRUE | immediate. = TRUE | ||||
| ) | ) | ||||
| } | } | ||||
| # If certain colors aren't in hexadecimal it may cause problems with theme_xaringan() | # If certain colors aren't in hexadecimal it may cause problems with theme_xaringan() | ||||
| # TODO: at some point I'd rather be able to process CSS colors or variables | # TODO: at some point I'd rather be able to process CSS colors or variables | ||||
| colors_used_by_theme_xaringan <- list( | colors_used_by_theme_xaringan <- list( | ||||
| ) | ) | ||||
| colors_used_by_theme_xaringan <- purrr::discard(colors_used_by_theme_xaringan, is.null) | colors_used_by_theme_xaringan <- purrr::discard(colors_used_by_theme_xaringan, is.null) | ||||
| colors_are_hex <- purrr::map_lgl(colors_used_by_theme_xaringan, check_color_is_hex, throw = NULL) | colors_are_hex <- purrr::map_lgl(colors_used_by_theme_xaringan, check_color_is_hex, throw = NULL) | ||||
| if (any(!colors_are_hex)) { | if (any(!colors_are_hex)) { | ||||
| colors_better_as_hex <- names(colors_used_by_theme_xaringan)[!colors_are_hex] | colors_better_as_hex <- names(colors_used_by_theme_xaringan)[!colors_are_hex] | ||||
| colors_better_as_hex <- paste(colors_better_as_hex, collapse = ", ") | colors_better_as_hex <- paste(colors_better_as_hex, collapse = ", ") | ||||
| warning( | warning( | ||||
| glue::glue("Colors that will be used by `theme_xaringan()` need to be in ", | glue::glue("Colors that will be used by `theme_xaringan()` need to be in ", | ||||
| "hexadecimal format: {colors_better_as_hex}"), | |||||
| "hexadecimal format: {colors_better_as_hex}"), | |||||
| immediate. = TRUE, | immediate. = TRUE, | ||||
| call. = FALSE | call. = FALSE | ||||
| ) | ) | ||||
| } | } | ||||
| # Use font_..._google args to overwrite font args | # Use font_..._google args to overwrite font args | ||||
| for (var in f_args[grepl("font_google$", f_args)]) { | for (var in f_args[grepl("font_google$", f_args)]) { | ||||
| gf <- eval(parse(text = var)) | gf <- eval(parse(text = var)) | ||||
| } | } | ||||
| eval(parse(text = paste0(group, "_font_is_google <- 1"))) | eval(parse(text = paste0(group, "_font_is_google <- 1"))) | ||||
| } | } | ||||
| extra_font_imports <- if (is.null(extra_fonts)) "" else list2fonts(extra_fonts) | extra_font_imports <- if (is.null(extra_fonts)) "" else list2fonts(extra_fonts) | ||||
| extra_font_imports <- paste(extra_font_imports, collapse = "\n") | extra_font_imports <- paste(extra_font_imports, collapse = "\n") | ||||
| # convert NA arguments to NULL | # convert NA arguments to NULL | ||||
| for (var in f_args) { | for (var in f_args) { | ||||
| val <- eval(parse(text = var)) | val <- eval(parse(text = var)) | ||||
| is_na <- length(val) == 0 | is_na <- length(val) == 0 | ||||
| if (is_na) assign(var, NULL, envir = sys.frame(sys.nframe())) | if (is_na) assign(var, NULL, envir = sys.frame(sys.nframe())) | ||||
| } | } | ||||
| # prepare variables for template | # prepare variables for template | ||||
| body_font_family <- paste(c(text_font_family, text_font_family_fallback, text_font_base), collapse = ", ") | body_font_family <- paste(c(text_font_family, text_font_family_fallback, text_font_base), collapse = ", ") | ||||
| background_size_fallback <- if (is.null(background_position)) "cover" else "100%" | background_size_fallback <- if (is.null(background_position)) "cover" else "100%" | ||||
| title_slide_background_image %??% "cover" | title_slide_background_image %??% "cover" | ||||
| ) | ) | ||||
| table_row_even_background_color <- table_row_even_background_color %||% background_color | table_row_even_background_color <- table_row_even_background_color %||% background_color | ||||
| # stash theme settings in package env | # stash theme settings in package env | ||||
| lapply(f_args, function(n) assign(n, get(n), envir = xaringanthemer_env)) | lapply(f_args, function(n) assign(n, get(n), envir = xaringanthemer_env)) | ||||
| for (font_is_google in paste0(c("text", "code", "header"), "_font_is_google")) { | for (font_is_google in paste0(c("text", "code", "header"), "_font_is_google")) { | ||||
| envir = xaringanthemer_env | envir = xaringanthemer_env | ||||
| ) | ) | ||||
| } | } | ||||
| xaringanthemer_version <- utils::packageVersion("xaringanthemer") | xaringanthemer_version <- utils::packageVersion("xaringanthemer") | ||||
| # prepare header background object | # prepare header background object | ||||
| needs_leading_dot <- !grepl("^\\.", header_background_ignore_classes) | needs_leading_dot <- !grepl("^\\.", header_background_ignore_classes) | ||||
| header_background_ignore_classes[needs_leading_dot] <- paste0( | header_background_ignore_classes[needs_leading_dot] <- paste0( | ||||
| content_padding_top = header_background_content_padding_top, | content_padding_top = header_background_content_padding_top, | ||||
| ignore = header_background_ignore_classes | ignore = header_background_ignore_classes | ||||
| ) | ) | ||||
| colors <- prepare_colors(colors) | colors <- prepare_colors(colors) | ||||
| tf <- system.file("resources", "template.css", package = "xaringanthemer") | tf <- system.file("resources", "template.css", package = "xaringanthemer") | ||||
| template <- readLines(tf, warn = FALSE) | template <- readLines(tf, warn = FALSE) | ||||
| template <- paste(template, collapse = "\n") | template <- paste(template, collapse = "\n") |
| is_mult <- grepl(",|and|or", css_name) | is_mult <- grepl(",|and|or", css_name) | ||||
| is_class <- grepl("^\\.", css_name) | is_class <- grepl("^\\.", css_name) | ||||
| ifelse(is_class, | ifelse(is_class, | ||||
| ifelse(is_mult, "classes", "class"), | |||||
| ifelse(is_mult, "elements", "element") | |||||
| ifelse(is_mult, "classes", "class"), | |||||
| ifelse(is_mult, "elements", "element") | |||||
| ) | ) | ||||
| } | } | ||||
| "boxplot" = list(color = "grey20", fill = "white"), | "boxplot" = list(color = "grey20", fill = "white"), | ||||
| "contour" = list(color = "#3366FF"), | "contour" = list(color = "#3366FF"), | ||||
| "density" = list(color = "black", | "density" = list(color = "black", | ||||
| fill = NA, | |||||
| alpha = NA), | |||||
| fill = NA, | |||||
| alpha = NA), | |||||
| "dotplot" = list(color = "black"), | "dotplot" = list(color = "black"), | ||||
| "errorbarh" = list(color = "black"), | "errorbarh" = list(color = "black"), | ||||
| "crossbar" = list(color = "black"), | "crossbar" = list(color = "black"), | ||||
| "step" = list(color = "black"), | "step" = list(color = "black"), | ||||
| "point" = list(color = "black"), | "point" = list(color = "black"), | ||||
| "polygon" = list(color = NA, | "polygon" = list(color = NA, | ||||
| fill = "grey20"), | |||||
| fill = "grey20"), | |||||
| "quantile" = list(color = "#3366FF"), | "quantile" = list(color = "#3366FF"), | ||||
| "rug" = list(color = "black"), | "rug" = list(color = "black"), | ||||
| "segment" = list(color = "black"), | "segment" = list(color = "black"), | ||||
| "smooth" = list(fill = "grey60", | "smooth" = list(fill = "grey60", | ||||
| color = "#3366FF"), | |||||
| color = "#3366FF"), | |||||
| "spoke" = list(color = "black"), | "spoke" = list(color = "black"), | ||||
| "label" = list(color = "black", | "label" = list(color = "black", | ||||
| family = ""), | |||||
| family = ""), | |||||
| "text" = list(color = "black", | "text" = list(color = "black", | ||||
| family = ""), | |||||
| family = ""), | |||||
| "rect" = list(fill = "grey35"), | "rect" = list(fill = "grey35"), | ||||
| "tile" = list(fill = "grey20"), | "tile" = list(fill = "grey20"), | ||||
| "violin" = list(fill = "white", color = "grey20") | "violin" = list(fill = "white", color = "grey20") |
| expect_warning(prepare_colors(c("light/blue" = "#88f")), "light/blue") | expect_warning(prepare_colors(c("light/blue" = "#88f")), "light/blue") | ||||
| expect_warning(prepare_colors(c("-lightblue" = "#88f")), "-lightblue") | expect_warning(prepare_colors(c("-lightblue" = "#88f")), "-lightblue") | ||||
| expect_warning(prepare_colors(c("_lightblue" = "#88f")), "_lightblue") | expect_warning(prepare_colors(c("_lightblue" = "#88f")), "_lightblue") | ||||
| colors <- c("light_blue" = "#88f", "light-blue" = "#88f") | colors <- c("light_blue" = "#88f", "light-blue" = "#88f") | ||||
| expect_silent( | expect_silent( | ||||
| expect_equal( | expect_equal( |
| }) | }) | ||||
| expect_equal(theme_vars$text_font_family, | expect_equal(theme_vars$text_font_family, | ||||
| quote_elements_w_spaces(xaringanthemer_font_default("text_font_family"))) | |||||
| quote_elements_w_spaces(xaringanthemer_font_default("text_font_family"))) | |||||
| expect_true(theme_vars$text_font_is_google) | expect_true(theme_vars$text_font_is_google) | ||||
| expect_equal(theme_vars$header_font_family, | expect_equal(theme_vars$header_font_family, | ||||
| quote_elements_w_spaces(xaringanthemer_font_default("header_font_family"))) | |||||
| quote_elements_w_spaces(xaringanthemer_font_default("header_font_family"))) | |||||
| expect_true(theme_vars$header_font_is_google) | expect_true(theme_vars$header_font_is_google) | ||||
| }) | }) | ||||