gnoblet/visualizeR
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'gen-dev' into 15-add-waffle-plots

Browse source
This commit is contained in:
Guillaume NOBLET 2023-05-25 10:56:56 +02:00 • committed by GitHub
commit f6958ff234
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
5 changed files with 202 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
DESCRIPTION
View file

@ -28,7 +28,8 @@ Imports:
ggrepel,
tidyr,
dplyr,
ggalluvial
ggalluvial,
viridisLite
Remotes:
github::hrbrmstr/waffle
Suggests: knitr, sf, tmap

12
R/pal_agora.R
View file

@ -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))

19
R/pal_fallback.R Normal file
View file

@ -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)
}

155
R/scale.R
View file

@ -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.
@ -14,21 +14,82 @@
scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) {
if (initiative == "reach") {
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)
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,
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.
@ -75,26 +139,87 @@ scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE
scale_fill <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) {
if (initiative == "reach") {
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)
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,
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
),
...
)
}
}

32
R/theme_reach.R
View file

@ -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)
)