diff --git a/DESCRIPTION b/DESCRIPTION index f041836..19b3f61 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,7 +28,8 @@ Imports: ggrepel, tidyr, dplyr, - ggalluvial + ggalluvial, + viridisLite Remotes: github::hrbrmstr/waffle Suggests: knitr, sf, tmap diff --git a/R/pal_agora.R b/R/pal_agora.R index 90f08a6..756e9d8 100644 --- a/R/pal_agora.R +++ b/R/pal_agora.R @@ -13,15 +13,9 @@ pal_agora <- function(palette = "main", reverse = FALSE, color_ramp_palette = FA palettes_agora <- list( - `main` = cols_agora("main_grey", "main_red", "main_lt_grey", "main_beige"), - `primary` = cols_agora("main_grey", "main_red"), - `secondary` = cols_agora("main_lt_grey", "main_beige"), - `two_dots` = cols_agora("two_dots_1", "two_dots_2"), - `two_dots_flashy` = cols_agora("two_dots_flashy_1", "two_dots_flashy_2"), - `red_main` = cols_agora("red_main_1", "red_main_2", "red_main_3", "red_main_4", "red_main_5"), - `red_alt` = cols_agora("red_alt_1", "red_alt_2", "red_alt_3", "red_alt_4", "red_alt_5"), - `iroise` = cols_agora("iroise_1", "iroise_2", "iroise_3", "iroise_4", "iroise_5"), - `discrete_6` = cols_agora("dk_grey", "red_main_1", "main_beige", "red_main_2", "lt_grey_2", "red_4") + `main` = cols_agora("main_bordeaux", "main_dk_beige", "main_lt_grey", "main_lt_beige"), + `primary` = cols_agora("main_bordeaux", "main_dk_beige"), + `secondary` = cols_agora( "main_lt_grey", "main_lt_beige") ) if (show_palettes) return(names(palettes_agora)) diff --git a/R/pal_fallback.R b/R/pal_fallback.R new file mode 100644 index 0000000..add80f5 --- /dev/null +++ b/R/pal_fallback.R @@ -0,0 +1,19 @@ +pal_fallback <- function(reverse = FALSE, + color_ramp_palette = FALSE, + discrete = FALSE, + n = 5, + ...){ + + pal <- if(discrete) { viridisLite::viridis(n) } else {viridisLite::magma(n)} + + if (reverse) pal <- rev(pal) + + if (color_ramp_palette) { + rlang::check_installed("grDevices", reason = "Package \"grDevices\" needed for `pal_fallback()` with 'color_ramp_palette' set to `TRUE` to work. Please install it.") + + pal <- grDevices::colorRampPalette(pal, ...) + } + + return(pal) + +} diff --git a/R/scale.R b/R/scale.R index 8dec956..1425f0b 100644 --- a/R/scale.R +++ b/R/scale.R @@ -1,6 +1,6 @@ #' Color scale constructor for REACH or AGORA colors #' -#' @param initiative Either "reach" or "agora. +#' @param initiative Either "reach" or "agora" or "default". #' @param palette Palette name from `pal_reach()` or `pal_agora()`. #' @param discrete Boolean indicating whether color aesthetic is discrete or not. #' @param reverse Boolean indicating whether the palette should be reversed. @@ -11,24 +11,85 @@ #' @return A color scale for ggplot #' #' @export -scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) { +scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) { if (initiative == "reach") { - pal <- pal_reach( - palette = palette, - reverse = reverse, - color_ramp_palette = TRUE, - show_palettes = FALSE + + pal <- pal_reach(palette) + + if (is.null(pal)) { + + pal <- pal_fallback( + reverse = reverse, + discrete = discrete, + color_ramp_palette = TRUE) + + rlang::warn( + c( + paste0("There is no palette '", palette, "' for the selected initiative. Fallback to pal_fallback()."), + "i" = paste0("Use `pal_reach(show_palettes = TRUE)` to see the list of available palettes.") + ) ) + + if (discrete) palette <- "viridis" else palette <- "magma" + + } else { + + pal <- pal_reach( + palette = palette, + reverse = reverse, + color_ramp_palette = TRUE, + show_palettes = FALSE + ) + + } + } else if (initiative == "agora") { - pal <- pal_agora( - palette = palette, + + pal <- pal_agora(palette) + + if (is.null(pal)) { + + pal <- pal_fallback( + reverse = reverse, + discrete = discrete, + color_ramp_palette = TRUE) + + rlang::warn( + c( + paste0("There is no palette '", palette, "' for the selected initiative. Fallback to pal_fallback()."), + "i" = paste0("Use `pal_reach(show_palettes = TRUE)` to see the list of available palettes.") + ) + ) + + if (discrete) palette <- "viridis" else palette <- "magma" + + } else { + + pal <- pal_agora( + palette = palette, + reverse = reverse, + color_ramp_palette = TRUE, + show_palettes = FALSE + ) + } + + } else if (initiative == "default") { + + pal <- pal_fallback( reverse = reverse, - color_ramp_palette = TRUE, - show_palettes = FALSE - ) + discrete = discrete, + color_ramp_palette = TRUE) + + if (discrete) palette <- "viridis" else palette <- "magma" + } else { - rlang::abort(c("Wrong initiative parameter input", "*" = paste0(initiative, "is not an option"), "i" = "Parameter 'initiative' should be one of 'reach' or 'agora'")) + rlang::abort( + c( + paste0("There is no initiative '", initiative, "."), + "i" = paste0("initiative should be either 'reach', 'agora' or 'default'") + ) + ) } if (discrete) { @@ -41,8 +102,10 @@ scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE draw.ulim = TRUE, draw.llim = TRUE, ticks.colour = "#F1F3F5", - reverse = reverse_guide), - ...) + reverse = reverse_guide + ), + ... + ) } else { ggplot2::scale_color_gradientn( colours = pal(256), @@ -53,7 +116,8 @@ scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE ticks.colour = "#F1F3F5", reverse = reverse_guide ), - ...) + ... + ) } } @@ -61,7 +125,7 @@ scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE #' Fill scale constructor for REACH or AGORA colors #' -#' @param initiative Either "reach" or "agora. +#' @param initiative Either "reach" or "agora" or "default". #' @param palette Palette name from `pal_reach()` or `pal_agora()`. #' @param discrete Boolean indicating whether color aesthetic is discrete or not. #' @param reverse Boolean indicating whether the palette should be reversed. @@ -72,29 +136,90 @@ scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE #' @return A fill scale for ggplot. #' #' @export -scale_fill <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) { +scale_fill <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) { if (initiative == "reach") { - pal <- pal_reach( - palette = palette, - reverse = reverse, - color_ramp_palette = TRUE, - show_palettes = FALSE - ) + + pal <- pal_reach(palette) + + if (is.null(pal)) { + + pal <- pal_fallback( + reverse = reverse, + discrete = discrete, + color_ramp_palette = TRUE) + + rlang::warn( + c( + paste0("There is no palette '", palette, "' for the selected initiative. Fallback to pal_fallback()."), + "i" = paste0("Use `pal_reach(show_palettes = TRUE)` to see the list of available palettes.") + ) + ) + + if (discrete) palette <- "viridis" else palette <- "magma" + + } else { + + pal <- pal_reach( + palette = palette, + reverse = reverse, + color_ramp_palette = TRUE, + show_palettes = FALSE + ) + + } + } else if (initiative == "agora") { - pal <- pal_agora( - palette = palette, + + pal <- pal_agora(palette) + + if (is.null(pal)) { + + pal <- pal_fallback( + reverse = reverse, + discrete = discrete, + color_ramp_palette = TRUE) + + rlang::warn( + c( + paste0("There is no palette '", palette, "' for the selected initiative. Fallback to pal_fallback()."), + "i" = paste0("Use `pal_reach(show_palettes = TRUE)` to see the list of available palettes.") + ) + ) + + if (discrete) palette <- "viridis" else palette <- "magma" + + } else { + + pal <- pal_agora( + palette = palette, + reverse = reverse, + color_ramp_palette = TRUE, + show_palettes = FALSE + ) + } + + } else if (initiative == "default") { + + pal <- pal_fallback( reverse = reverse, - color_ramp_palette = TRUE, - show_palettes = FALSE - ) + discrete = discrete, + color_ramp_palette = TRUE) + + if (discrete) palette <- "viridis" else palette <- "magma" + } else { - rlang::abort(c("Wrong initiative parameter input", "*" = paste0(initiative, "is not an option"), "i" = "Parameter 'initiative' should be one of 'reach' or 'agora'")) + rlang::abort( + c( + paste0("There is no initiative '", initiative, "."), + "i" = paste0("initiative should be either 'reach', 'agora' or 'default'") + ) + ) } if (discrete) { ggplot2::discrete_scale( - "fill", + "colour", paste0(initiative, "_", palette), palette = pal, guide = ggplot2::guide_legend( @@ -102,17 +227,21 @@ scale_fill <- function(initiative = "reach", palette = "main", discrete = TRUE, draw.ulim = TRUE, draw.llim = TRUE, ticks.colour = "#F1F3F5", - reverse = reverse_guide), - ...) + reverse = reverse_guide + ), + ... + ) } else { - ggplot2::scale_fill_gradientn( + ggplot2::scale_color_gradientn( colours = pal(256), guide = ggplot2::guide_colorbar( title.position = "top", draw.ulim = TRUE, draw.llim = TRUE, ticks.colour = "#F1F3F5", - reverse = reverse_guide), - ...) + reverse = reverse_guide + ), + ... + ) } } diff --git a/R/theme_reach.R b/R/theme_reach.R index 7084301..8273b95 100644 --- a/R/theme_reach.R +++ b/R/theme_reach.R @@ -1,5 +1,6 @@ #' @title ggplot2 theme with REACH color palettes #' +#' @param initiative Either "reach" or "default". #' @param palette Palette name from 'pal_reach()'. #' @param discrete Boolean indicating whether color aesthetic is discrete or not. #' @param reverse Boolean indicating whether the palette should be reversed. @@ -56,10 +57,11 @@ #' #' @export theme_reach <- function( + initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, - font_family = "Segoe UI", + font_family = "segoeui", title_size = 12, title_color = cols_reach("main_grey"), title_font_face = "bold", @@ -108,6 +110,14 @@ theme_reach <- function( # To do : # - add facet theming + if (!initiative %in% c("reach", "default")) + rlang::abort( + c( + paste0("There is no initiative '", initiative, " to be used with theme_reach()."), + "i" = paste0("initiative should be either 'reach' or 'default'") + ) + ) + # Basic simple theme # theme_reach <- ggplot2::theme_bw() @@ -264,28 +274,12 @@ theme_reach <- function( # Other parameters theme_reach <- theme_reach + ggplot2::theme(...) - - # Check if palette is an actual existing palette - pal <- pal_reach(palette) - - if(is.null(pal)) { - rlang::warn( - c( - paste0("There is no palette '", palette, "' for initiative 'reach'. Fallback to REACH main palette."), - "i" = paste0("Use `pal_reach(show_palettes = TRUE)` to see the list of availabale palettes.") - ) - ) - - palette <- "main" - - } - # Add reach color palettes by default # (reversed guide is defaulted to TRUE for natural reading) theme_reach <- list( theme_reach, - scale_color(palette = palette, discrete = discrete, reverse = reverse, reverse_guide = legend_reverse), - scale_fill(palette = palette, discrete = discrete, reverse = reverse, reverse_guide = legend_reverse) + scale_color(initiative = initiative, palette = palette, discrete = discrete, reverse = reverse, reverse_guide = legend_reverse), + scale_fill(initiative = initiative, palette = palette, discrete = discrete, reverse = reverse, reverse_guide = legend_reverse) )