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

start revamp work

Browse source
This commit is contained in:
gnoblet 2025-01-03 18:09:59 +01:00
parent 515a94fbb5
commit a9b8b5f708
76 changed files with 4640 additions and 3472 deletions
Download patch file Download diff file Expand all files Collapse all files

104
R/alluvial.R
View file

@ -1,104 +0,0 @@
#' @title Simple alluvial chart
#'
#' @param df A data frame.
#' @param from A character column of upstream stratum.
#' @param to A character column of downstream stratum.
#' @param value A numeric column of values.
#' @param group The grouping column to fill the alluvium with.
#' @param alpha Fill transparency. Default to 0.5.
#' @param from_levels Order by given from levels?
#' @param value_title The value/y scale title. Default to NULL.
#' @param group_title The group title. Default to NULL.
#' @param title Plot title. Default to NULL.
#' @param subtitle Plot subtitle. Default to NULL.
#' @param caption Plot caption. Default to NULL.
#' @param rect_color Stratum rectangles' fill color.
#' @param rect_border_color Stratum rectangles' border color.
#' @param rect_text_color Stratum rectangles' text color.
#' @param theme Whatever theme. Default to theme_reach().
#'
#' @return A donut chart to be used parsimoniously
#'
#' @export
alluvial <- function(
df,
from,
to,
value,
group = NULL,
alpha = 0.5,
from_levels = NULL,
value_title = NULL,
group_title = NULL,
title = NULL,
subtitle = NULL,
caption = NULL,
rect_color = cols_reach("white"),
rect_border_color = cols_reach("main_grey"),
rect_text_color = cols_reach("main_grey"),
theme = theme_reach(axis_y = FALSE,
legend_position = "none")
){
if(!is.null(from_levels)) df <- dplyr::mutate(df, "{{from}}" := factor({{ from }}, levels = from_levels))
# General mapping
g <- ggplot2::ggplot(
data = df,
mapping = ggplot2::aes(
y = {{ value }},
axis1 = {{ from }},
axis3 = {{ to }}
)
)
# Add alluvium
g <- g +
ggalluvial::geom_alluvium(
ggplot2::aes(
fill = {{ group }},
color = {{ group }}
),
alpha = alpha)
# Add stratum
g <- g +
ggalluvial::geom_stratum(
fill = rect_color,
color = rect_border_color
)
# Add stratum text
stratum <- ggalluvial::StatStratum
g <- g +
ggplot2::geom_text(
stat = stratum,
ggplot2::aes(label = ggplot2::after_stat(!!rlang::sym("stratum"))),
color = cols_reach("main_grey")
)
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
y = value_title,
title = title,
subtitle = subtitle,
caption = caption,
fill = group_title,
color = group_title
)
# Remove x-axis
g <- g + ggplot2::theme(
axis.line.x = ggplot2::element_blank(),
axis.ticks.x = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank(),
axis.title.x = ggplot2::element_blank()
)
g <- g + theme
return(g)
}

268
R/bar.R
View file

@ -1,11 +1,11 @@
#' @title Simple bar chart
#' Simple bar chart
#'
#' @param df A data frame.
#' @param x A numeric column.
#' @param y A character column or coercible as a character column.
#' @param group Some grouping categorical column, e.g. administrative areas or population groups.
#' @param x A quoted numeric column.
#' @param y A quoted character column or coercible as a character column.
#' @param group Some quoted grouping categorical column, e.g. administrative areas or population groups.
#' @param add_color Add a color to bars (if no grouping).
#' @param flip TRUE or FALSE. Default to TRUE or horizontal bar plot.
#' @param percent TRUE or FALSE. Should the x-labels (and text labels if present) be displayed as percentages? Default to TRUE.
#' @param wrap Should x-labels be wrapped? Number of characters.
#' @param position Should the chart be stacked? Default to "dodge". Can take "dodge" and "stack".
#' @param alpha Fill transparency.
@ -15,46 +15,96 @@
#' @param title Plot title. Default to NULL.
#' @param subtitle Plot subtitle. Default to NULL.
#' @param caption Plot caption. Default to NULL.
#' @param add_text TRUE or FALSE. Add the value as text.
#' @param width Bar width.
#' @param add_text TRUE or FALSE. Add values as text.
#' @param add_text_size Text size.
#' @param add_text_color Text color.
#' @param add_text_font_face Text font_face.
#' @param add_text_threshold_display Minimum value to add the text label.
#' @param add_text_suffix If percent is FALSE, should we add a suffix to the text label?
#' @param theme Whatever theme. Default to theme_reach().
#' @param add_text_expand_limit Default to adding 10% on top of the bar.
#' @param add_text_round Round the text label.
#' @param theme_fun Whatever theme function. For no custom theme, use theme_fun = NULL.
#' @param scale_impact Use the package custom scales for fill and color.
#'
#' @return A bar chart
#' @inheritParams scale_color_impact_discrete
#'
#' @importFrom rlang `%||%`
#'
#' @export
bar <- function(df, x, y, group = NULL, flip = TRUE, percent = TRUE, wrap = NULL, position = "dodge", alpha = 1, x_title = NULL, y_title = NULL, group_title = NULL, title = NULL, subtitle = NULL, caption = NULL, add_text = FALSE, add_text_suffix = "", theme = theme_reach()){
bar <- function(
df,
x,
y,
group = "",
add_color = color("dark_grey"),
flip = TRUE,
wrap = NULL,
position = "dodge",
alpha = 1,
x_title = NULL,
y_title = NULL,
group_title = NULL,
title = NULL,
subtitle = NULL,
caption = NULL,
width = 0.5,
add_text = TRUE,
add_text_size = 5,
add_text_color = color("dark_grey"),
add_text_font_face = "plain",
add_text_threshold_display = 0.05,
add_text_suffix = "%",
add_text_expand_limit = 1.2,
add_text_round = 1){
# To do :
# - automate bar width and text size, or at least give the flexibility and still center text
# - add facet possibility
# Check if numeric and character
if (class(df[[y]]) %notin% c("integer", "numeric")) rlang::abort(paste0(y, " must be numeric."))
if (!any(class(df[[x]]) %in% c("character", "factor"))) rlang::abort(paste0(x, " must be character or factor"))
# Prepare group, x and y names
# if (is.null(x_title)) x_title <- rlang::as_name(rlang::enquo(x))
# if (is.null(y_title)) y_title <- rlang::as_name(rlang::enquo(y))
# if (is.null(group_title)) group_title <- rlang::as_name(rlang::enquo(group))
# Check if position is stack or dodge
if (position %notin% c("stack", "dodge")) rlang::abort("Position should be either 'stack' or 'dodge'.")
if(group != "") {
# Mapping
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(x = {{ x }}, y = {{ y }}, fill = {{ group }}, color = {{ group }}
)
)
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
x = x_title,
y = y_title,
color = group_title,
fill = group_title
df,
mapping = ggplot2::aes(
x = !!rlang::sym(x),
y = !!rlang::sym(y),
fill = !!rlang::sym(group),
color = !!rlang::sym(group)
)
)
width <- 0.5
dodge_width <- 0.5
} else {
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(
x = !!rlang::sym(x),
y = !!rlang::sym(y)
)
)
}
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
x = y_title,
y = x_title,
color = group_title,
fill = group_title
)
width <- width
dodge_width <- width
# Should the graph use position_fill?
if(group != "") {
# Should the graph use position_fill?
if (position == "stack"){
g <- g + ggplot2::geom_col(
alpha = alpha,
@ -75,67 +125,97 @@ bar <- function(df, x, y, group = NULL, flip = TRUE, percent = TRUE, wrap = NULL
width = width
)
}
#
# Labels to percent and expand scale
if (percent) {
g <- g + ggplot2::scale_y_continuous(
labels = scales::label_percent(
accuracy = 1,
decimal.mark = ",",
suffix = " %"),
expand = c(0.01, 0.1)
} else {
if (position == "stack"){
g <- g + ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_stack(),
fill = add_color,
color = add_color
)
} else if (position == "dodge"){
g <- g + ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_dodge2(
width = dodge_width,
preserve = "single"),
fill = add_color,
color = add_color
)
} else {
g <- g + ggplot2::scale_y_continuous(expand = c(0.01, 0.1))
g <- g + ggplot2::geom_col(
alpha = alpha,
width = width,
fill = add_color,
color = add_color
)
}
if (!is.null(wrap)) {
g <- g + ggplot2::scale_x_discrete(labels = scales::label_wrap(wrap))
}
# Because a text legend should always be horizontal, especially for an horizontal bar graph
if (flip){
g <- g + ggplot2::coord_flip()
}
# Add text to bars
if (flip) hjust_flip <- 1.5 else hjust_flip <- 0.5
if (flip) vjust_flip <- 0.5 else vjust_flip <- 1.5
if (add_text & position != "dodge") {
rlang::abort("Adding text labels and positions different than dodges as not been implemented yet")
}
# Add text labels
if (add_text) {
if (percent) {
g <- g + ggplot2::geom_text(
ggplot2::aes(
label = scales::label_percent(
accuracy = 1,
decimal.mark = ",",
suffix = " %")({{ y }}),
group = {{ group }}),
hjust = hjust_flip,
vjust = vjust_flip,
color = "white",
fontface = "bold",
position = ggplot2::position_dodge(width = dodge_width))
} else {
g <- g + ggplot2::geom_text(
ggplot2::aes(
label = paste0(round({{ y }}), add_text_suffix),
group = {{ group }}),
hjust = hjust_flip,
vjust = vjust_flip,
color = "white",
fontface = "bold",
position = ggplot2::position_dodge(width = dodge_width))
}
}
# Add theme
g <- g + theme
return(g)
}
# Expand scale
g <- g + ggplot2::scale_y_continuous(expand = c(0, 0))
if (!is.null(wrap)) {
g <- g + ggplot2::scale_x_discrete(labels = scales::label_wrap(wrap))
}
# Because a text legend should always be horizontal, especially for an horizontal bar graph
if (flip) g <- g + ggplot2::coord_flip()
# Add text to bars
if (flip) hjust_flip <- -0.5 else hjust_flip <- 0.5
if (flip) vjust_flip <- 0.5 else vjust_flip <- -0.5
# Add text labels
if (add_text & position == "dodge") {
df <- dplyr::mutate(df, "y_threshold" := ifelse(!!rlang::sym(y) >= add_text_threshold_display, !!rlang::sym(y), NA ))
# Expand limits
g <- g + ggplot2::geom_blank(
data = df,
ggplot2::aes(x = !!rlang::sym(x), y = !!rlang::sym(y) * add_text_expand_limit, group = !!rlang::sym(group))
)
g <- g + ggplot2::geom_text(
data = df,
ggplot2::aes(
label = ifelse(is.na(!!rlang::sym("y_threshold")), NA, paste0(round(!!rlang::sym("y_threshold"), add_text_round), add_text_suffix)),
group = !!rlang::sym(group)),
hjust = hjust_flip,
vjust = vjust_flip,
color = add_text_color,
fontface = add_text_font_face,
size = add_text_size,
position = ggplot2::position_dodge2(width = dodge_width)
)
} else if (add_text & position == "stack") {
df <- dplyr::mutate(df, "y_threshold" := ifelse(!!rlang::sym(y) >= add_text_threshold_display, !!rlang::sym(y), NA ))
g <- g + ggplot2::geom_text(
data = df,
ggplot2::aes(
label = ifelse(is.na(!!rlang::sym("y_threshold")), NA, paste0(round(!!rlang::sym("y_threshold"), add_text_round), add_text_suffix)),
group = !!rlang::sym(group)),
color = add_text_color,
fontface = add_text_font_face,
size = add_text_size,
position = ggplot2::position_stack(vjust = 0.5)
)
}
# Remove trailing 0
! no applicable method for 'round_any' applied to an object of class "character"
return(g)
}

39
R/bbox_buffer.R
View file

@ -1,39 +0,0 @@
#' @title Bbbox buffer
#'
#' @param sf_obj A `sf` object
#' @param buffer A buffer, either one value or a vector of 4 values (left, bottom, right, top). Default to 0.
#'
#' @return A bbox with a buffer
#'
#' @export
buffer_bbox <- function(sf_obj, buffer = 0){
rlang::check_installed("sf", reason = "Package \"sf\" needed for `buffer_bbox()` to work. Please install it.")
if (!(length(buffer) %in% c(1,4)) | !is.numeric(buffer)) stop("Please provide a numeric buffer of length 1 or 4.")
bbox <- sf::st_bbox(sf_obj)
xrange <- bbox$xmax - bbox$xmin # range of x values
yrange <- bbox$ymax - bbox$ymin # range of y values
bbox_with_buffer <- if (length(buffer) == 1) {
c(
bbox[1] - (buffer * xrange), # xmin - left
bbox[2] - (buffer * yrange), # ymin - bottom
bbox[3] + (buffer * xrange), # xmax - right
bbox[4] + (buffer * yrange) # ymax - top
)
} else if (length(buffer) == 4) {
c(
bbox[1] - (buffer[1] * xrange), # xmin - left
bbox[2] - (buffer[2] * yrange), # ymin - bottom
bbox[3] + (buffer[3] * xrange), # xmax - right
bbox[4] + (buffer[4] * yrange) # ymax - top
)
} else {
print("Missed something while writing the funtion.")
}
}

13
R/checks.R Normal file
View file

@ -0,0 +1,13 @@
#' @title Check if variables are in data frame
#'
#' @param df A data frame
#' @param vars A vector of variable names
#'
#' @return A stop statement
check_vars_in_df <- function(df, vars) {
vars_nin <- setdiff(vars, colnames(df))
if (length(vars_nin) > 0) {
rlang::abort(glue::glue("Variables ", glue::glue_collapse(vars_nin, sep = ", ", last = ", and "), " not found in data frame."))
}
}

145
R/color.R Normal file
View file

@ -0,0 +1,145 @@
#' Helpers to extract defined colors as hex codes
#'
#' [color()] returns the requested columns, returns NA if absent. [color_pattern()] returns all colors that start with the pattern.
#'
#' @param ... Character names of colors. If NULL returns all colors.
#' @param unname Boolean. Should the output vector be unnamed? Default to `TRUE`.
#' @section Naming of colors:
#' * All branding colors start with "branding";
#' * All , categorical colors start with ", cat_";
#' * All sequential colors start with "seq_";
#'
#' Then, a number indi, cates the number of colors that belong to the palettes, a string the name of the palette, and, finally, a number the position of the color. E.g., "seq_5_red_4" would be the 4th color of a continuous palettes of 5 colors in the red band. Exception is made for white, light_grey, dark_grey, and black.
#'
#'
#' @return Hex codes named or unnamed.
#'
#' @export
color <- function(..., unname = TRUE) {
#------ Prep
# Retrieve colors
cols <- c(...)
# Defined colors
colors <- c(
white = "#FFFFFF"
, light_grey = "#E3E3E3"
, dark_grey = "#464647"
, black = "#000000"
, cat_2_yellow_1 = "#ffc20a"
, cat_2_yellow_2 = "#0c7bdc"
, cat_2_light_1 = "#fefe62"
, cat_2_light_2 = "#d35fb7"
, cat_2_green_1 = "#1aff1a"
, cat_2_green_2 = "#4b0092"
, cat_2_blue_1 = "#1a85ff"
, cat_2_blue_2 = "#d41159"
, cat_5_main_1 = "#083d77" # yale blue
, cat_5_main_2 = "#4ecdc4" # robin egg blue
, cat_5_main_3 = "#f4c095" # peach
, cat_5_main_4 = "#b47eb3" # african violet
, cat_5_main_5 = "#ffd5ff" # mimi pink
, seq_5_main_1 = "#083d77" # yale blue
, seq_5_main_2 = "##396492"
, seq_5_main_3 = "#6b8bad"
, seq_5_main_4 = "#9cb1c9"
, seq_5_main_5 = "#ced8e4"
, cat_5_ibm_1 = "#648fff"
, cat_5_ibm_2 = "#785ef0"
, cat_5_ibm_3 = "#dc267f"
, cat_5_ibm_4 = "#fe6100"
, cat_5_ibm_5 = "#ffb000"
, cat_3_aquamarine_1 = "aquamarine2"
, cat_3_aquamarine_2 = "cornflowerblue"
, cat_3_aquamarine_3 = "brown1"
, cat_3_tol_high_contrast_1 = "#215589"
, cat_3_tol_high_contrast_2 = "#cfaa34"
, cat_3_tol_high_contrast_3 = "#a35364"
, cat_8_tol_adapted_1 = "#332e86"
, cat_8_tol_adapted_2 = "#50504f"
, cat_8_tol_adapted_3 = "#3dab9a"
, cat_8_tol_adapted_4 = "#86ccee"
, cat_8_tol_adapted_5 = "#ddcb77"
, cat_8_tol_adapted_6 = "#ee5859"
, cat_8_tol_adapted_7 = "#aa4599"
, cat_8_tol_adapted_8 = "#721220"
, div_5_orange_blue_1 = "#c85200"
, div_5_orange_blue_2 = "#e48646"
, div_5_orange_blue_3 = "#cccccc"
, div_5_orange_blue_4 = "#6b8ea4"
, div_5_orange_blue_5 = "#366785"
, div_5_green_purple_1 = "#c85200"
, div_5_green_purple_2 = "#e48646"
, div_5_green_purple_3 = "#cccccc"
, div_5_green_purple_4 = "#6b8ea4"
, div_5_green_purple_5 = "#366785"
)
#------ Checks
# Check that if ... is not null, all colors are defined
if (!is.null(cols)) {
if (cols %notallin% names(colors)) {
rlang::abort(c(
"Some colors not defined",
"*" = glue::glue_collapse(...[which(!... %in% names(cols))], sep = ", ", last = ", and "),
"i" = "Use `color(unname = FALSE)` to see all named available colors."
)
)
}
}
# ------ Return
if (is.null(cols)) {
cols_to_return <- colors
} else {
cols_to_return <- colors[cols]
}
if (unname) {
cols_to_return <- unname(cols_to_return)
}
return(cols_to_return)
}
#' @rdname color
#'
#' @param pattern Pattern of the start of colors' name.
#'
#' @export
color_pattern <- function(pattern, unname = TRUE){
#------ Checks
# Check that pattern is a character scalar
checkmate::assert_character(pattern, len = 1)
# Check that unname is a logical scalar
checkmate::assert_logical(unname, len = 1)
#------ Get colors
# Get colors
col <- color(unname = FALSE)
col <- col[startsWith(names(col), pattern)]
if (unname) {
col <- unname(col)
}
# If col is of length 0, warn
if (length(col) == 0) {
rlang::warn(c(
"No colors match the pattern",
"*" = glue::glue("Pattern used is:'{pattern}'"),
"i" = "Use `color(unname = FALSE)` to see all named available colors."
))
}
return(col)
}

32
R/cols_agora.R
View file

@ -1,32 +0,0 @@
#' @title Function to extract AGORA colors as hex codes
#'
#' @param ... Character names of reach colors. If NULL returns all colors
#' @param unnamed Should the output vector be unnamed? Default to `TRUE`
#'
#' @return An hex code or hex codes named or unnamed
#'
#' @details This function needs to be modified to add colors
#'
#' @export
cols_agora <- function(..., unnamed = TRUE) {
cols <- c(...)
colors_agora <- c(white = "#FFFFFF",
black = "#000000",
main_bordeaux = "#581522",
main_lt_beige = "#DDD8C4",
main_dk_beige = "#B7AD99",
main_lt_grey = "#BCB8B1")
if (is.null(cols)) {
cols_to_return <- colors_agora
} else {
cols_to_return <- colors_agora[cols]
}
if(unnamed){
cols_to_return <- unname(cols_to_return)
}
return(cols_to_return)
}

30
R/cols_impact.R
View file

@ -1,30 +0,0 @@
#' @title Function to extract IMPACT colors as hex codes
#'
#' @param ... Character names of reach colors. If NULL returns all colors
#' @param unnamed Should the output vector be unnamed? Default to `TRUE`
#'
#' @return An hex code or hex codes named or unnamed
#'
#' @details This function needs to be modified to add colors
#'
#' @export
cols_impact <- function(..., unnamed = TRUE) {
cols <- c(...)
colors_impact <- c(white = "#FFFFFF",
black = "#000000",
main_blue = "#315975",
main_gray = "#58585A")
if (is.null(cols)) {
cols_to_return <- colors_impact
} else {
cols_to_return <- colors_impact[cols]
}
if(unnamed){
cols_to_return <- unname(cols_to_return)
}
return(cols_to_return)
}

168
R/cols_reach.R
View file

@ -1,168 +0,0 @@
#' @title Function to extract REACH colors as hex codes
#'
#' @param ... Character names of reach colors. If NULL returns all colors
#' @param unnamed Should the output vector be unnamed? Default to `TRUE`
#'
#' @return An hex code or hex codes named or unnamed
#'
#' @details This function needs to be modified to add colors
#'
#' @export
cols_reach <- function(..., unnamed = TRUE) {
cols <- c(...)
colors_reach <- c(
white = "#FFFFFF",
black = "#000000",
main_grey = "#58585A",
main_red = "#EE5859",
main_lt_grey = "#C7C8CA",
main_beige = "#D2CBB8",
iroise_1 = "#DFECEF",
iroise_2 = "#B1D7E0",
iroise_3 = "#699DA3",
iroise_4 = "#236A7A",
iroise_5 = "#0C3842",
red_main_1 = "#AE2829",
red_main_2 = "#D05E5F",
red_main_3 = "#DB9797",
red_main_4 = "#EBC7C8",
red_main_5 = "#FAF2F2",
red_alt_1 = "#792a2e",
red_alt_2 = "#c0474a",
red_alt_3 = "#ee5859",
red_alt_4 = "#f49695",
red_alt_5 = "#f8d6d6",
red_alt_na = "#f8f4f4",
lt_grey_1 = "#C6C6C6",
lt_grey_2 = "#818183",
grey3 = "#E3E3E3",
dk_grey = "#464647",
two_dots_1 = "#706441",
two_dots_2 = "#56b4e9",
two_dots_flashy_1 = "gold1",
two_dots_flashy_2 = "blue2",
three_dots_1 = "aquamarine2",
three_dots_2 = "cornflowerblue",
three_dots_3 = "brown1",
orpink = "#f8aa9b",
pink = "#f5a6a7",
lt_pink = "#F9C6C7",
hot_pink = "#ef6d6f",
mddk_red = "#bf4749",
dk_red = "#782c2e",
orange = "#F69E61",
lt_green = "#B0CFAC",
green = "#84A181",
dk_green = "#526450",
red_less_4_1 = "#f6e3e3",
red_less_4_2 = "#f3b5b6",
red_less_4_3 = "#ee5a59",
red_less_4_4 = "#9d393c",
red_5_1 = "#f6e3e3",
red_5_2 = "#f3b5b6",
red_5_3 = "#ee5a59",
red_5_4 = "#c0474a",
red_5_5 = "#792a2e",
red_less_7_1 = "#f8f4f4",
red_less_7_2 = "#f8d6d6",
red_less_7_3 = "#f49695",
red_less_7_4 = "#ee5a59",
red_less_7_5 = "#c0474a",
red_less_7_6 = "#792a2e",
red_less_7_7 = "#471119",
green_2_1 = "#cce5c9",
green_2_2 = "#55a065",
green_3_1 = "#e6f2e0",
green_3_2 = "#7ebf85",
green_3_3 = "#2d8246",
green_4_1 = "#e6f2e1",
green_4_2 = "#b0d3ab",
green_4_3 = "#4bab5e",
green_4_4 = "#0c592e",
green_5_1 = "#e6f2e1",
green_5_2 = "#b0d3ab",
green_5_3 = "#6bb26a",
green_5_4 = "#229346",
green_5_5 = "#0c592e",
green_6_1 = "#e6f2e0",
green_6_2 = "#b0d3ab",
green_6_3 = "#75c376",
green_6_4 = "#086d38",
green_6_5 = "#0c592e",
green_6_6 = "#0d4420",
green_7_1 = "#fafafa",
green_7_2 = "#e6f2e0",
green_7_3 = "#b0d3ab",
green_7_4 = "#75c376",
green_7_5 = "#40ab5d",
green_7_6 = "#086d38",
green_7_7 = "#0d4420",
artichoke_2_1 = "#b6c8b1",
artichoke_2_2 = "#53755f",
artichoke_3_1 = "#e4f1db",
artichoke_3_2 = "#89a087",
artichoke_3_3 = "#455843",
artichoke_4_1 = "#e4f1db",
artichoke_4_2 = "#b5ceb2",
artichoke_4_3 = "#89a087",
artichoke_4_4 = "#465944",
artichoke_5_1 = "#e4f1db",
artichoke_5_2 = "#b5ceb2",
artichoke_5_3 = "#89a087",
artichoke_5_4 = "#60755f",
artichoke_5_5 = "#465944",
artichoke_6_1 = "#fafafa",
artichoke_6_2 = "#e4f1db",
artichoke_6_3 = "#b5ceb2",
artichoke_6_4 = "#89a087",
artichoke_6_5 = "#60755f",
artichoke_6_6 = "#455843",
artichoke_7_1 = "#fafafa",
artichoke_7_2 = "#e4f1db",
artichoke_7_3 = "#b5ceb2",
artichoke_7_4 = "#9fb89c",
artichoke_7_5 = "#89a087",
artichoke_7_6 = "#60755f",
artichoke_7_7 = "#455843",
blue_2_1 = "#7cb6c4",
blue_2_2 = "#286877 ",
blue_3_1 = "#b9d7de",
blue_3_2 = "#5ca4b4",
blue_3_3 = "#286877",
blue_4_1 = "#dfecef",
blue_4_2 = "#8fc1cc",
blue_4_3 = "#3f96aa",
blue_4_4 = "#286877",
blue_5_1 = "#dfecef",
blue_5_2 = "#8fc1cc",
blue_5_3 = "#3f96aa",
blue_5_4 = "#256a7a",
blue_5_5 = "#0c3842",
blue_6_1 = "#f4fbfe",
blue_6_2 = "#cfe4e9",
blue_6_3 = "#77b2bf",
blue_6_4 = "#4096aa",
blue_6_5 = "#256a7a",
blue_6_6 = "#0c3842",
blue_7_1 = "#f4fbfe",
blue_7_2 = "#b3d5de",
blue_7_3 = "#77b2bf",
blue_7_4 = "#4096aa",
blue_7_5 = "#27768a",
blue_7_6 = "#0c596b",
blue_7_7 = "#0c3842"
)
if (is.null(cols)) {
cols_to_return <- colors_reach
} else {
cols_to_return <- colors_reach[cols]
}
if (unnamed) {
cols_to_return <- unname(cols_to_return)
}
return(cols_to_return)
}

93
R/data.R
View file

@ -1,93 +0,0 @@
#' Haïti admin 1 centroids shapefile.
#'
#' A multipoint shapefile of Haiti's admin 1.
#'
#' @format A sf multipoint object with 10 features and 9 fields:
#' \describe{
#' \item{ADM1_PC}{Admin 1 postal code.}
#' \item{ADM1_EN}{Full name in English.}
#' \item{ADM1_FR}{Full name in French.}
#' \item{ADM1_HT}{Full name in Haitian Creole.}
#' \item{ADM0_EN}{Country name in English.}
#' \item{ADM0_FR}{Country name in French.}
#' \item{ADM0_HT}{Country name in Haitian Creole.}
#' \item{ADM0_PC}{Country postal code.}
#' \item{ADM1_FR_UPPER}{Admin 1 French name - uppercase.}
#' \item{geometry}{Multipoint geometry.}
#' }
"centroid_admin1"
#' Indicator admin 1 polygons shapefile.
#'
#' A multipolygon shapefile of Haiti's admin 1 with an indicator column 'opn_dfc'.
#'
#' @format A sf multipoint object with 10 features and 10 fields:
#' \describe{
#' \item{ADM1_PC}{Admin 1 postal code.}
#' \item{admin1}{Admin 1 unique id.}
#' \item{opn_dfc}{Proportion of HHs that reported open defecation as sanitation facility.}
#' \item{ADM1_EN}{Full name in English.}
#' \item{ADM1_FR}{Full name in French.}
#' \item{ADM1_HT}{Full name in Haitian Creole.}
#' \item{ADM0_EN}{Country name in English.}
#' \item{ADM0_FR}{Country name in French.}
#' \item{ADM0_HT}{Country name in Haitian Creole.}
#' \item{ADM0_PC}{Country postal code.}
#' \item{geometry}{Multipolygon geometry.}
#' }
"indicator_admin1"
#' Haïti admin 1 lines shapefile.
#'
#' A multiline shapefile of Haiti's admin 1.
#'
#' @format A sf multiline object with 10 features and 8 fields:
#' \describe{
#' \item{ADM1_EN}{Full name in English.}
#' \item{ADM1_FR}{Full name in French.}
#' \item{ADM1_HT}{Full name in Haitian Creole.}
#' \item{ADM0_EN}{Country name in English.}
#' \item{ADM0_FR}{Country name in French.}
#' \item{ADM0_HT}{Country name in Haitian Creole.}
#' \item{ADM0_PCODE}{Country postal code.}
#' \item{geometry}{Multiline geometry.}
#' }
"line_admin1"
#' Haïti border.
#'
#' A multiline shapefile of Haiti's border.
#'
#' @format A sf multiline objet with 1 feature and 6 fields:
#' \describe{
#' \item{fid_1}{fid_1}
#' \item{uno}{uno}
#' \item{count}{count}
#' \item{x_coord}{x_coord}
#' \item{y_coord}{y_coord}
#' \item{area}{area}
#' \item{geometry}{Multiline geometry.}
#' }
"border_admin0"
#' Haïti frontier with Dominican Republic.
#'
#' A multiline shapefile of Haiti's frontier with Dominican Republic.
#'
#' @format A sf multipoint objet with 4 features and 8 fields:
#' \describe{
#' \item{fid_1}{fid_1}
#' \item{objectid}{objectid}
#' \item{id}{id}
#' \item{fromnode}{fromnode}
#' \item{tonode}{tonode}
#' \item{leftpolygo}{leftpolygo}
#' \item{rightpolygo}{rightpolygo}
#' \item{shape_leng}{shape_leng}
#' \item{geometry}{Multiline geometry.}
#' }
"frontier_admin0"

107
R/donut.R
View file

@ -1,107 +0,0 @@
#' @title Simple donut chart (to be used parsimoniously), can be a pie chart
#'
#' @param df A data frame.
#' @param x A character column or coercible as a character column. Will give the donut's fill color.
#' @param y A numeric column.
#' @param alpha Fill transparency.
#' @param x_title The x scale title. Default to NULL.
#' @param title Plot title. Default to NULL.
#' @param subtitle Plot subtitle. Default to NULL.
#' @param caption Plot caption. Default to NULL.
#' @param arrange TRUE or FALSE. Arrange by highest percentage first.
#' @param hole_size Hole size. Default to 3. If less than 2, back to a pie chart.
#' @param add_text TRUE or FALSE. Add the value as text.
#' @param add_text_treshold_display Minimum value to add the text label.
#' @param add_text_color Text color.
#' @param add_text_suffix If percent is FALSE, should we add a suffix to the text label?
#' @param theme Whatever theme. Default to theme_reach().
#'
#' @return A donut chart to be used parsimoniously
#'
#' @export
donut <- function(df,
x,
y,
alpha = 1,
x_title = NULL,
title = NULL,
subtitle = NULL,
caption = NULL,
arrange = TRUE,
hole_size = 3,
add_text = TRUE,
add_text_treshold_display = 5, add_text_color = "white", add_text_suffix = "", theme = theme_reach(legend_reverse = TRUE)){
# Arrange by biggest prop first ?
if (arrange) df <- dplyr::arrange(
df,
{{ y }}
)
# Get levels for scaling
lev <- dplyr::pull(df, {{ x }})
df <- dplyr::mutate(df, "{{x}}" := factor({{ x }}, levels = lev))
# Mapping
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(
x = hole_size,
y = {{ y }},
fill = {{ x }},
color = {{ x }}
)
)
# Add rect
g <- g + ggplot2::geom_col(alpha = alpha)
# Add text labels
if (add_text) {
df <- dplyr::mutate(df, y_treshold = ifelse({{ y }} >= add_text_treshold_display, {{ y }}, NA ))
g <- g +
ggplot2::geom_text(
data = df,
ggplot2::aes(
x = hole_size,
y = !!rlang::sym("y_treshold"),
label = paste0({{ y }}, add_text_suffix)),
color = add_text_color,
position = ggplot2::position_stack(vjust = 0.5))
}
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
fill = x_title,
color = x_title
)
# Transform to polar coordinates and adjust hole
g <- g +
ggplot2::coord_polar(
theta = "y"
)
if (hole_size >= 2) g <- g + ggplot2::xlim(c(1, hole_size + 0.5)) # Try to remove that to see how to make a pie chart
# Add theme
g <- g + theme
# No axis
g <- g + ggplot2::theme(
axis.text = ggplot2::element_blank(),
axis.line = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.title = ggplot2::element_blank()
)
return(g)
}

161
R/dumbbell.R
View file

@ -1,161 +0,0 @@
#' Make dumbbell chart.
#'
#' @param df A data frame.
#' @param col A numeric column.
#' @param group_x The grouping column on the x-axis; only two groups.
#' @param group_y The grouping column on the y-axis.
#' @param point_size Point size.
#' @param point_alpha Point alpha.
#' @param segment_size Segment size.
#' @param segment_color Segment color.
#' @param group_x_title X-group and legend title.
#' @param group_y_title Y-axis and group title.
#' @param x_title X-axis title.
#' @param title Title.
#' @param subtitle Subtitle.
#' @param caption Caption.
#' @param line_to_y_axis TRUE or FALSE; add a line connected points and Y-axis.
#' @param line_to_y_axis_type Line to Y-axis type.
#' @param line_to_y_axis_width Line to Y-axis width.
#' @param line_to_y_axis_color Line to Y-axis color.
#' @param add_text TRUE or FALSE; add text at the points.
#' @param add_text_vjust Vertical adjustment.
#' @param add_text_size Text size.
#' @param add_text_color Text color.
#' @param theme A ggplot2 theme, default to `theme_reach()`
#'
#' @return A dumbbell chart.
#' @export
#'
dumbbell <- function(df,
col,
group_x,
group_y,
point_size = 5,
point_alpha = 1,
segment_size = 2.5,
segment_color = cols_reach("main_lt_grey"),
group_x_title = NULL,
group_y_title = NULL,
x_title = NULL,
title = NULL,
subtitle = NULL,
caption = NULL,
line_to_y_axis = TRUE,
line_to_y_axis_type = 3,
line_to_y_axis_width = 0.5,
line_to_y_axis_color = cols_reach("main_grey"),
add_text = TRUE,
add_text_vjust = 2,
add_text_size = 3.5,
add_text_color = cols_reach("main_grey"),
theme = theme_reach(palette = "primary")){
# Get group keys
group_x_keys <- df |>
dplyr::group_by({{ group_x }}) |>
dplyr::group_keys() |>
dplyr::pull()
# Check if only two groups
if (length(group_x_keys) > 2) rlang::abort("Cannot draw a dumbbell plot for `group_x` with more than 2 groups")
# Pivot long data
df_pivot <- df |>
tidyr::pivot_wider(
id_cols = c({{ group_y}}),
values_from = {{ col }},
names_from = {{ group_x }}
)
df_pivot <- df_pivot |>
dplyr::rowwise() |>
dplyr::mutate(
min = min(!!rlang::sym(group_x_keys[[1]]), !!rlang::sym(group_x_keys[[2]]), na.rm = T),
max = max(!!rlang::sym(group_x_keys[[1]]), !!rlang::sym(group_x_keys[[2]]), na.rm = T)) |>
dplyr::ungroup() |>
dplyr::mutate(diff = max - min)
g <- ggplot2::ggplot(df_pivot)
# Add line
if(line_to_y_axis) {
xend <- min(dplyr::pull(df, {{ col }}))
g <- g +
ggplot2::geom_segment(
ggplot2::aes(
x = min,
y = {{ group_y }},
yend = {{ group_y }}),
xend = xend,
linetype = line_to_y_axis_type,
size = line_to_y_axis_width,
color = line_to_y_axis_color)
}
# Add segment
g <- g +
ggplot2::geom_segment(
ggplot2::aes(
x = !!rlang::sym(group_x_keys[[1]]),
y = {{ group_y }},
xend = !!rlang::sym(group_x_keys[[2]]),
yend = {{ group_y }}),
size = segment_size,
color = segment_color
)
# Add points
g <- g +
ggplot2::geom_point(
data = df,
ggplot2::aes(
x = {{ col }},
y = {{ group_y }},
color = {{ group_x }},
fill = {{ group_x }}
),
size = point_size,
alpha = point_alpha
)
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
x = x_title,
y = group_y_title,
color = group_x_title,
fill = group_x_title
)
# Add stat labels to points
if(add_text) g <- g +
ggrepel::geom_text_repel(
data = df,
ggplot2::aes(
x = {{ col }},
y = {{ group_y}},
label = {{ col }}
),
vjust = add_text_vjust,
size = add_text_size,
color = add_text_color
)
# Expan y axis
# g <- g +
# ggplot2::scale_y_discrete(
# group_y_title,
# expand = c(0, 0))
# Add theme
g <- g + theme
return(g)
}

100
R/internals.R
View file

@ -1,95 +1,15 @@
#' @title Abord bad argument
#'
#' @param arg An argument
#' @param must What arg must be
#' @param not Optional. What arg must not be.
#'
#' @return A stop statement
abort_bad_argument <- function(arg, must, not = NULL) {
msg <- glue::glue("`{arg}` must {must}")
if (!is.null(not)) {
not <- typeof(not)
msg <- glue::glue("{msg}; not {not}.")
}
rlang::abort("error_bad_argument",
message = msg,
arg = arg,
must = must,
not = not
)
# not in
`%notin%` <- function(a, b) {
!(a %in% b)
}
#' @title Stop statement "If not in colnames" with colnames
#'
#' @param .tbl A tibble
#' @param cols A vector of column names (quoted)
#' @param df Provide the tibble name as a character string
#' @param arg Default to NULL.
#'
#' @return A stop statement
if_not_in_stop <- function(.tbl, cols, df, arg = NULL){
if (is.null(arg)) {
msg <- glue::glue("The following column/s is/are missing in `{df}`:")
}
else {
msg <- glue::glue("The following column/s from `{arg}` is/are missing in `{df}`:")
}
if (!all(cols %in% colnames(.tbl))) {
rlang::abort(
c("Missing columns",
"*" =
paste(
msg,
paste(
subvec_not_in(cols, colnames(.tbl)),
collapse = ", ")
)
)
)
}
# not all in
`%notallin%` <- function(a, b) {
!(all(a %in% b))
}
#' @title Stop statement "If not in vector"
#'
#' @param vec A vector of character strings
#' @param cols A set of character strings
#' @param vec_name Provide the vector name as a character string
#' @param arg Default to NULL.
#'
#' @return A stop statement if some elements of vec are not in cols
if_vec_not_in_stop <- function(vec, cols, vec_name, arg = NULL){
if (is.null(arg)) {
msg <- glue::glue("The following element/s is/are missing in `{vec_name}`:")
}
else {
msg <- glue::glue("The following element/s from `{arg}` is/are missing in `{vec_name}`:")
}
if (!all(cols %in% vec)) {
rlang::abort(
c("Missing elements",
"*" =
paste(
msg,
paste(
subvec_not_in(cols, vec),
collapse = ", ")
)
)
)
}
}
#' @title Subvec not in
#'
#' @param vector A vector to subset
#' @param set A set-vector
#'
#' @return A subset of vector not in set
subvec_not_in <- function(vector, set){
vector[!(vector %in% set)]
# infix for null replacement
#' @importFrom rlang `%||%`
`%ifnullrep%` <- function(a, b) {
a %||% b
}

121
R/lollipop.R
View file

@ -1,121 +0,0 @@
#' @title Simple bar chart
#'
#' @param df A data frame.
#' @param x A numeric column.
#' @param y A character column or coercible as a character column.
#' @param flip TRUE or FALSE. Default to TRUE or horizontal lollipop plot.
#' @param wrap Should x-labels be wrapped? Number of characters.
#' @param arrange TRUE or FALSE. Arrange by highest percentage first.
#' @param point_size Point size.
#' @param point_color Point color.
#' @param point_alpha Point alpha.
#' @param segment_size Segment size.
#' @param segment_color Segment color.
#' @param segment_alpha Segment alpha.
#' @param alpha Fill transparency.
#' @param x_title The x scale title. Default to NULL.
#' @param y_title The y scale title. Default to NULL.
#' @param title Plot title. Default to NULL.
#' @param subtitle Plot subtitle. Default to NULL.
#' @param caption Plot caption. Default to NULL.
#' @param add_text TRUE or FALSE. Add the y value as text within the bubble.
#' @param add_text_size Text size.
#' @param add_text_suffix If percent is FALSE, should we add a suffix to the text label?
#' @param add_text_color Added text color. Default to white.
#' @param add_text_fontface Added text font face. Default to "bold".
#' @param theme Whatever theme. Default to theme_reach().
#'
#' @return A bar chart
#'
#' @export
lollipop <- function(df,
x,
y,
flip = TRUE,
wrap = NULL,
arrange = TRUE,
point_size = 3,
point_color = cols_reach("main_red"),
point_alpha = 1,
segment_size = 1,
segment_color = cols_reach("main_grey"),
segment_alpha = 1,
alpha = 1,
x_title = NULL,
y_title = NULL,
title = NULL,
subtitle = NULL,
caption = NULL,
add_text = FALSE,
add_text_size = 3,
add_text_suffix = "",
add_text_color = "white",
add_text_fontface = "bold",
theme = theme_reach()){
# Arrange by biggest prop first ?
if (arrange) df <- dplyr::arrange(
df,
{{ y }}
)
# Get levels for scaling
lev <- dplyr::pull(df, {{ x }})
df <- dplyr::mutate(df, "{{x}}" := factor({{ x }}, levels = lev))
# Mapping
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(x = {{ x }}, y = {{ y }}, xend = {{ x }}, yend = 0)
)
# Add segment
g <- g + ggplot2::geom_segment(
linewidth = segment_size,
alpha = segment_alpha,
color = segment_color
)
g <- g + ggplot2::geom_point(
size = point_size,
alpha = point_alpha,
color = point_color
)
if (!is.null(wrap)) {
g <- g + ggplot2::scale_x_discrete(labels = scales::label_wrap(wrap))
}
# Because a text legend should always be horizontal, especially for an horizontal bar graph
if (flip){
g <- g + ggplot2::coord_flip()
}
# Add text labels
if (add_text) {
g <- g + ggplot2::geom_text(
ggplot2::aes(
label = paste0({{ y }}, add_text_suffix)),
size = add_text_size,
color = add_text_color,
fontface = add_text_fontface)
}
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
x = x_title,
y = y_title,
)
# Add theme
g <- g + theme
return(g)
}

354
R/map.R
View file

@ -1,354 +0,0 @@
#' Wrapper around `tmap::tm_polygons()` with sane defaults for plotting indicator values
#'
#' @param poly Multipolygon shape defined by sf package.
#' @param col Numeric attribute to map.
#' @param buffer A buffer, either one value or a vector of 4 values (left, bottom, right, top).
#' @param n The desire number of classes.
#' @param style Method to process the color scale for continuous numerical variables. See `classInt::classIntervals()` for details.
#' @param palette Vector of fill colors as hexadecimal values. For REACH color palettes, it is possible to use `pal_reach()`. For now,'palette' must be changed manually, accordingly to the number of drawn classes.
#' @param as_count Boolean. When col is a numeric variable, should it be processed as a count variable? For instance, 0, 1-10, 11-20.
#' @param color_na Fill color for missing data.
#' @param text_na Legend text for missing data.
#' @param legend_title Legend title.
#' @param legend_text_separator Text separator for classes. E.g. " to " will give 0, 1 to 10, 11 to 20.
#' @param border_alpha Transparency of the border.
#' @param border_col Color of the border.
#' @param lwd Linewidth of the border.
#' @param ... Other arguments to pass to `tmap::tm_polygons()`.
#'
#' @return A tmap layer.
#' @export
#'
add_indicator_layer <- function(
poly,
col,
buffer = NULL,
n = 5,
style = "pretty",
palette = pal_reach("red_5"),
as_count = TRUE,
color_na = cols_reach("white"),
text_na = "Missing data",
legend_title = "Proportion (%)",
legend_text_separator = " - ",
border_alpha = 1,
border_col = cols_reach("lt_grey_1"),
lwd = 1,
...){
#------ Checks and make valid
rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_indicator_layer()` to work. Please install it.")
poly <- sf::st_make_valid(poly)
#------ Other checks
col_name <- rlang::as_name(rlang::enquo(col))
if_not_in_stop(poly, col_name, "poly", "col")
if (!is.numeric(poly[[col_name]])) rlang::abort(glue::glue("{col_name} is not numeric."))
#------ Prepare data
if(!is.null(buffer)){ buffer <- buffer_bbox(poly, buffer) } else { buffer <- NULL }
#------ Polygon layer
layer <- tmap::tm_shape(
poly,
bbox = buffer
) +
tmap::tm_polygons(
col = col_name,
n = n,
style = style,
palette = palette,
as.count = as_count,
colorNA = color_na,
textNA = text_na,
title = legend_title,
legend.format = list(text.separator = legend_text_separator),
borderl.col = border_col,
border.alpha = border_alpha,
lwd = lwd,
...
)
return(layer)
}
#' Add admin boundaries (lines) and the legend
#'
#' @param lines List of multiline shape defined by sf package.
#' @param colors Vector of hexadecimal codes. Same order as lines.
#' @param labels Vector of labels in the legend. Same order as lines.
#' @param lwds Vector of line widths. Same order as lines.
#' @param title Legend title.
#' @param buffer A buffer, either one value or a vector of 4 values (left, bottom, right, top).
#' @param ... Other arguments to pass to each shape in `tmap::tm_lines()`.
#'
#' @return A tmap layer.
#' @export
#'
add_admin_boundaries <- function(lines, colors, labels, lwds, title = "", buffer = NULL, ...){
#------ Package check
rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_admin_boundaries()` to work. Please install it.")
#------ Check that the length of vectors is identical between arguments
if(!inherits(lines, "list")) rlang::abort("Please provide a list for lines.")
ll <- list(lines, colors, labels, lwds)
if (!all(sapply(ll,length) == length(ll[[1]]))) rlang::abort("lines, colors, labels, lwds do not all have the same length.")
#------ Make valid
lines <- lapply(lines, \(x) sf::st_make_valid(x))
#------ Prepare legend
legend_lines <- tmap::tm_add_legend("line",
title = title,
col = colors,
lwd = lwds,
labels = labels)
#------ Let's go with all line shapes
if(!is.null(buffer)){ buffer <- buffer_bbox(lines[[1]], buffer) } else { buffer <- NULL }
layers <- tmap::tm_shape(lines[[1]], bbox = buffer) +
tmap::tm_lines(lwd = lwds[[1]], col = colors[[1]], ...)
if (length(lines) == 1) {
layers <- layers + legend_lines
return(layers)
} else {
for(i in 2:length(lines)){
layers <- layers + tmap::tm_shape(shp = lines[[i]]) + tmap::tm_lines(lwd = lwds[[i]], col = colors[[i]], ...)
}
layers <- layers + legend_lines
return(layers)
}
}
#' Basic defaults based on `tmap::tm_layout()`
#'
#' @param title Map title.
#' @param legend_position Legend position. Not above the map is a good start.
#' @param frame Boolean. Legend frame?
#' @param legend_frame Legend frame color.
#' @param legend_text_size Legend text size in 'pt'.
#' @param legend_title_size Legend title size in 'pt'.
#' @param title_size Title text size in 'pt'.
#' @param title_fontface Title fontface. Bold if you wanna exemplify a lot what it is about.
#' @param title_color Title font color.
#' @param fontfamily Overall fontfamily. Leelawadee is your precious.
#' @param ... Other arguments to pass to `tmap::tm_layout()`.
#'
#' @return A tmap layer.
#' @export
#'
add_layout <- function(
title = NULL,
legend_position = c(0.02, 0.5),
frame = FALSE,
legend_frame = cols_reach("main_grey"),
legend_text_size = 0.6,
legend_title_size = 0.8,
title_size = 0.9,
title_fontface = "bold",
title_color = cols_reach("main_grey"),
# check.and.fix = TRUE,
fontfamily = "Leelawadee",
...){
layout <- tmap::tm_layout(
title = title,
legend.position = legend_position,
legend.frame = legend_frame,
frame = FALSE,
legend.text.size = legend_text_size,
legend.title.size = legend_title_size,
title.size = title_size,
title.fontface = title_fontface,
title.color = title_color,
fontfamily = fontfamily,
...)
return(layout)
}
#' Wrapper around `tmap::tm_text()` with sane defaults for plotting admin labels.
#'
#' @param point Multipoint shape defined by sf package.
#' @param text Text labels column.
#' @param size Relative size of the text labels.
#' @param fontface Fontface.
#' @param fontfamily Fontfamily. Leelawadee is your precious.
#' @param shadow Boolean. Add a shadow around text labels. Issue opened on Github to request.
#' @param auto_placement Logical that determines whether the labels are placed automatically.
#' @param remove_overlap Logical that determines whether the overlapping labels are removed.
#' @param ... Other arguments to pass to `tmap::tm_text()`.
#'
#' @return A tmap layer.
#' @export
#'
add_admin_labels <- function(point,
text,
size = 0.5,
fontface = "bold",
fontfamily = "Leelawadee",
shadow = TRUE,
auto_placement = FALSE,
remove_overlap = FALSE,
...){
#------ Restrictive sf checks (might not be necessary depending on the desired behaviour)
rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_indicator_layer()` to work. Please install it.")
point <- sf::st_make_valid(point)
#------ Other checks
text_name <- rlang::as_name(rlang::enquo(text))
if_not_in_stop(point, text_name, "point", "text")
#------ Point text layer
layer <- tmap::tm_shape(point) +
tmap::tm_text(text = text_name,
size = size,
fontface = fontface,
fontfamily = fontfamily,
shadow = shadow,
auto.placement = auto_placement,
remove.overlap = remove_overlap,
...)
return(layer)
}
#' Add a compass
#'
#' @param text_size Relative font size.
#' @param position Position of the compass. Vector of two values, specifying the x and y coordinates.
#' @param color_dark Color of the dark parts of the compass.
#' @param text_color color of the text.
#' @param type Compass type, one of: "arrow", "4star", "8star", "radar", "rose".
#' @param ... Other arguments to pass to `tmap::tm_compass()`.
#'
#' @return A tmap layer.
#' @export
#'
add_compass <- function(text_size = 0.6,
position = c("right", 0.8),
color_dark = cols_reach("black"),
text_color = cols_reach("black"),
type = "4star",
...){
compass <- tmap::tm_compass(
text.size = text_size,
position = position,
color.dark = color_dark,
type = type,
text.color = text_color
)
return(compass)
}
#' Add a scale bar
#'
#' @param text_size Relative font size.
#' @param position Position of the compass. Vector of two values, specifying the x and y coordinates.
#' @param color_dark Color of the dark parts of the compass.
#' @param breaks Breaks of the scale bar. If not specified, breaks will be automatically be chosen given the prefered width of the scale bar. Example: c(0, 50, 100).
#' @param ... Other arguments to pass to `tmap::tm_compass()`.
#'
#' @return A tmap layer.
#' @export
#'
add_scale_bar <- function(text_size = 0.6,
position = c("left", 0.01),
color_dark = cols_reach("black"),
breaks = c(0, 50, 100),
...){
scale_bar <- tmap::tm_scale_bar(
text.size = text_size,
position = position,
color.dark = color_dark,
breaks = breaks,
...
)
return(scale_bar)
}
#' Do you want to credit someone or some institution?
#'
#' @param text Text.
#' @param size Relative text size.
#' @param bg_color Background color.
#' @param position Position. Vector of two coordinates. Usually somewhere down.
#' @param ... Other arguments to pass to `tmap::tm_credits()`.
#'
#' @return A tmap layer.
#' @export
#'
add_credits <- function(text, size = 0.4, bg_color = NA, position = c(0.75, 0.02), ...){
tmap::tm_credits(text,
size = size,
bg.color = bg_color,
position = position,
...)
}

34
R/pal_agora.R
View file

@ -1,34 +0,0 @@
#' @title Return function to interpolate an AGORA color palette
#'
#' @param palette Character name of a palette in AGORA palettes
#' @param reverse Boolean indicating whether the palette should be reversed
#' @param color_ramp_palette Should the output be a `grDevices::colorRampPalette` function or a vector of hex codes? Default to the former with `TRUE`
#' @param show_palettes Should the ouput be the set of palettes names to pick from? Default to `FALSE`
#' @param ... Additional arguments to pass to colorRampPalette()
#'
#' @return A color palette
#'
#' @export
pal_agora <- function(palette = "main", reverse = FALSE, color_ramp_palette = FALSE, show_palettes = FALSE, ...) {
palettes_agora <- list(
`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))
pal <- palettes_agora[[palette]]
if (reverse) pal <- rev(pal)
if (color_ramp_palette) {
rlang::check_installed("grDevices", reason = "Package \"grDevices\" needed for `pal_agora()` woth 'color_ramp_palette' set to `TRUE` to work. Please install it.")
pal <- grDevices::colorRampPalette(pal, ...)
}
return(pal)
}

30
R/pal_fallback.R
View file

@ -1,30 +0,0 @@
#' @title Return function to interpolate a fallback palette base on viridis::magma()
#'
#' @param reverse Boolean indicating whether the palette should be reversed
#' @param color_ramp_palette Should the output be a `grDevices::colorRampPalette` function or a vector of hex codes? Default to the latter with `FALSE`
#' @param discrete Boolean. Discrete or not? Default to FALSE.
#' @param n Number of colors in the palette. Default to 5. Passe to `viridis::magma()`
#' @param ... Other parameters to pass to `grDevices::colorRampPalette()`
#'
#' @return A color palette
#'
#' @export
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)
}

34
R/pal_impact.R
View file

@ -1,34 +0,0 @@
#' @title Return function to interpolate an IMPACT color palette
#'
#' @param palette Character name of a palette in IMPACT palettes
#' @param reverse Boolean indicating whether the palette should be reversed
#' @param color_ramp_palette Should the output be a `grDevices::colorRampPalette` function or a vector of hex codes? Default to the former with `TRUE`
#' @param show_palettes Should the ouput be the set of palettes names to pick from? Default to `FALSE`
#' @param ... Additional arguments to pass to colorRampPalette()
#'
#' @return A color palette
#'
#' @export
pal_impact <- function(palette = "main", reverse = FALSE, color_ramp_palette = FALSE, show_palettes = FALSE, ...) {
palettes_impact <- list(
`main` = cols_impact("black", "white", "main_blue", "main_grey"),
`primary` = cols_impact("black", "white"),
`secondary` = cols_impact("main_blue", "main_grey")
)
if (show_palettes) return(names(palettes_impact))
pal <- palettes_impact[[palette]]
if (reverse) pal <- rev(pal)
if (color_ramp_palette) {
rlang::check_installed("grDevices", reason = "Package \"grDevices\" needed for `pal_impact()` woth 'color_ramp_palette' set to `TRUE` to work. Please install it.")
pal <- grDevices::colorRampPalette(pal, ...)
}
return(pal)
}

66
R/pal_reach.R
View file

@ -1,66 +0,0 @@
#' @title Return function to interpolate a REACH color palette
#'
#' @param palette Character name of a palette in REACH palettes
#' @param reverse Boolean indicating whether the palette should be reversed
#' @param color_ramp_palette Should the output be a `grDevices::colorRampPalette` function or a vector of hex codes? Default to the former with `TRUE`
#' @param show_palettes Should the ouput be the set of palettes names to pick from? Default to `FALSE`
#' @param ... Additional arguments to pass to colorRampPalette()
#'
#' @return A color palette
#'
#' @export
pal_reach <- function(palette = "main", reverse = FALSE, color_ramp_palette = FALSE, show_palettes = FALSE, ...) {
palettes_reach <- list(
`main` = cols_reach("main_grey", "main_red", "main_lt_grey", "main_beige"),
`primary` = cols_reach("main_grey", "main_red"),
`secondary` = cols_reach("main_lt_grey", "main_beige"),
`two_dots` = cols_reach("two_dots_1", "two_dots_2"),
`two_dots_flashy` = cols_reach("two_dots_flashy_1", "two_dots_flashy_2"),
`red_main` = cols_reach("red_main_1", "red_main_2", "red_main_3", "red_main_4", "red_main_5"),
`red_main_5` = cols_reach("red_main_1", "red_main_2", "red_main_3", "red_main_4", "red_main_5"),
`red_alt` = cols_reach("red_alt_1", "red_alt_2", "red_alt_3", "red_alt_4", "red_alt_5"),
`red_alt_5` = cols_reach("red_alt_1", "red_alt_2", "red_alt_3", "red_alt_4", "red_alt_5"),
`iroise` = cols_reach("iroise_1", "iroise_2", "iroise_3", "iroise_4", "iroise_5"),
`iroise_5` = cols_reach("iroise_1", "iroise_2", "iroise_3", "iroise_4", "iroise_5"),
`discrete_6` = cols_reach("dk_grey", "red_main_1", "main_beige", "red_main_2", "lt_grey_2", "red_4"),
`red_2` = cols_reach("red_less_4_1", "red_less_4_3"),
`red_3` = cols_reach("red_less_4_1", "red_less_4_2", "red_less_4_3"),
`red_4` = cols_reach("red_less_4_1", "red_less_4_2", "red_less_4_3", "red_less_4_4"),
`red_5` = cols_reach("red_5_1", "red_5_2", "red_5_3", "red_5_4", "red_5_5"),
`red_6` = cols_reach("red_less_7_1", "red_less_2", "red_less_7_3", "red_less_7_4", "red_less_7_5", "red_less_7_6"),
`red_7` = cols_reach("red_less_7_1", "red_less_7_2", "red_less_7_3", "red_less_7_4", "red_less_7_5", "red_less_7_6", "red_less_7_7"),
`green_2` = cols_reach("green_2_1", "green_2_2"),
`green_3` = cols_reach("green_3_1", "green_3_2", "green_3_3"),
`green_4` = cols_reach("green_4_1", "green_4_2", "green_4_3", "green_4_4"),
`green_5` = cols_reach("green_5_1", "green_5_2", "green_5_3", "green_5_4", "green_5_5"),
`green_6` = cols_reach("green_6_1", "green_6_2", "green_6_3", "green_6_4", "green_6_5", "green_6_6"),
`green_7` = cols_reach("green_7_1", "green_7_2", "green_7_3", "green_7_4", "green_7_5", "green_7_6", "green_7_7"),
`artichoke_2` = cols_reach("artichoke_2_1", "artichoke_2_2"),
`artichoke_3` = cols_reach("artichoke_3_1", "artichoke_3_2", "artichoke_3_3"),
`artichoke_4` = cols_reach("artichoke_4_1", "artichoke_4_2", "artichoke_4_3", "artichoke_4_4"),
`artichoke_5` = cols_reach("artichoke_5_1", "artichoke_5_2", "artichoke_5_3", "artichoke_5_4", "artichoke_5_5"),
`artichoke_6` = cols_reach("artichoke_6_1", "artichoke_6_2", "artichoke_6_3", "artichoke_6_4", "artichoke_6_5", "artichoke_6_6"),
`artichoke_7` = cols_reach("artichoke_7_1", "artichoke_7_2", "artichoke_7_3", "artichoke_7_4", "artichoke_7_5", "artichoke_7_6", "artichoke_7_7"),
`blue_2` = cols_reach("blue_2_1", "blue_2_2"),
`blue_3` = cols_reach("blue_3_1", "blue_3_2", "blue_3_3"),
`blue_4` = cols_reach("blue_4_1", "blue_4_2", "blue_4_3", "blue_4_4"),
`blue_5` = cols_reach("blue_5_1", "blue_5_2", "blue_5_3", "blue_5_4", "blue_5_5"),
`blue_6` = cols_reach("blue_6_1", "blue_6_2", "blue_6_3", "blue_6_4", "blue_6_5", "blue_6_6"),
`blue_7` = cols_reach("blue_7_1", "blue_7_2", "blue_7_3", "blue_7_4", "blue_7_5", "blue_7_6", "blue_7_7")
)
if (show_palettes) return(names(palettes_reach))
pal <- palettes_reach[[palette]]
if (reverse) pal <- rev(pal)
if (color_ramp_palette) {
rlang::check_installed("grDevices", reason = "Package \"grDevices\" needed for `pal_reach()` with 'color_ramp_palette' set to `TRUE` to work. Please install it.")
pal <- grDevices::colorRampPalette(pal, ...)
}
return(pal)
}

66
R/palette.R Normal file
View file

@ -0,0 +1,66 @@
#' @title Interpolate a color palette
#'
#' @param palette Character name of a palette in palettes
#' @param reverse Boolean indicating whether the palette should be reversed
#' @param show_palettes Should the ouput be the set of palettes names to pick from? Default to `FALSE`
#' @param ... Additional arguments to pass to colorRampPalette()
#'
#' @return A color palette
#'
#' @export
palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FALSE, ...) {
#------ Checks
# Check that palette is a character scalar
checkmate::assert_character(palette, len = 1)
# Check that reverse is a logical scalar
checkmate::assert_logical(reverse, len = 1)
# Check that show_palettes is a logical scalar
checkmate::assert_logical(show_palettes, len = 1)
#------ Get colors
# Define palettes
pals <- list(
cat_2_yellow = color_pattern("cat_2_yellow")
, cat_2_light = color_pattern("cat_2_light")
, cat_2_green = color_pattern("cat_2_green")
, cat_2_blue = color_pattern("cat_2_blue")
, cat_5_main = color_pattern("cat_5_main")
, cat_5_ibm = color_pattern("cat_5_ibm")
, cat_3_aquamarine = color_pattern("cat_3_aquamarine")
, cat_3_tol_high_contrast = color_pattern("cat_3_tol_high_contrast")
, cat_8_tol_adapted = color_pattern("cat_8_tol_adapted")
, cat_3_custom_1 = c("#003F5C", "#58508D", "#FFA600")
, cat_4_custom_1 = c("#003F5C", "#7a5195", "#ef5675", "#ffa600")
, cat_5_custom_1 = c("#003F5C", "#58508d", "#bc5090", "#ff6361", "#ffa600")
, cat_6_custom_1 = c("#003F5C", "#444e86", "#955196", "#dd5182", "#ff6e54", "#ffa600")
, div_5_orange_blue = color_pattern("div_5_orange_blue")
, div_5_green_purple = color_pattern("div_5_green_purple")
)
# Return if show palettes
if (show_palettes) {
return(names(pals))
}
# palette is in pals
if (palette %notin% names(pals)) {
rlang::abort(c(
"Palette not defined",
"*" = glue::glue("Palette `{palette}` is not defined in the `palettes` list."),
"i" = "Use `palette(show_palettes = TRUE)` to see all available palettes."
))
}
#------ Get palette
pal <- pals[[palette]]
if (reverse) pal <- rev(pal)
return(pal)
}

61
R/palette_gen.R Normal file
View file

@ -0,0 +1,61 @@
#' Generate color palettes
#'
#' [palette_gen()] generates a color palette and let you choose whether continuous or discrete. [palette_gen_categorical()] and [palette_gen_sequential()] generates respectively discrete and continuous palettes.
#'
#' @param palette Palette name from [palette()].
#' @param type "categorical" or "sequential" or "divergent".
#' @param direction 1 or -1; should the order of colors be reversed?
#' @param ... Additional arguments to pass to [colorRampPalette()] when type is "continuous".
#'
#' @export
palette_gen <- function(palette, type, direction = 1, ...) {
if (type %notin% c("categorical", "sequential", "divergent")) rlang::abort("'type' must be categorical or continuous or divergent.")
if (type == "categorical") {
return(palette_gen_categorical(palette = palette, direction = direction))
}
if (type %in% c("sequential", "divergent")) {
return(palette_gen_sequential(palette = palette, direction = direction, ...))
}
}
#' @rdname palette_gen
#'
#' @export
palette_gen_categorical <- function(palette = "cat_5_main", direction = 1) {
if (abs(direction) != 1) rlang::abort("Direction must be either 1 or -1.")
pal <- palette(palette)
f <- function(n) {
if (is.null(n)) n <- length(pal)
if (n > length(pal)) rlang::warn("Not enough colors in this palette!")
pal <- if (direction == 1) pal else rev(pal)
pal <- pal[1:n]
return(pal)
}
return(f)
}
#' @rdname palette_gen
#'
#' @export
palette_gen_sequential <- function(palette = "seq_5_main", direction = 1, ...) {
if (abs(direction) != 1) rlang::abort("Direction must be either 1 or -1.")
pal <- palette(palette)
pal <- if (direction == 1) pal else rev(pal)
grDevices::colorRampPalette(pal, ...)
}

83
R/point.R
View file

@ -2,8 +2,9 @@
#'
#' @param df A data frame.
#' @param x A numeric column.
#' @param y A character column or coercible as a character column.
#' @param y Another numeric column.
#' @param group Some grouping categorical column, e.g. administrative areas or population groups.
#' @param add_color Add a color to bars (if no grouping).
#' @param flip TRUE or FALSE. Default to TRUE or horizontal bar plot.
#' @param alpha Fill transparency.
#' @param size Point size.
@ -13,28 +14,38 @@
#' @param title Plot title. Default to NULL.
#' @param subtitle Plot subtitle. Default to NULL.
#' @param caption Plot caption. Default to NULL.
#' @param theme Whatever theme. Default to theme_reach().
#' @param theme_fun Whatever theme. Default to theme_reach(). NULL if no theming needed.
#' @param scale_impact Use the package custom scales for fill and color.
#'
#' @return A bar chart
#' @inheritParams scale_color_impact_discrete
#'
#' @export
point <- function(df, x, y, group = NULL, flip = TRUE, alpha = 1, size = 1, x_title = NULL, y_title = NULL, group_title = NULL, title = NULL, subtitle = NULL, caption = NULL, theme = theme_reach()){
# To do :
# - automate bar width and text size, or at least give the flexibility and still center text
# - add facet possibility
# Prepare group, x and y names
# if (is.null(x_title)) x_title <- rlang::as_name(rlang::enquo(x))
# if (is.null(y_title)) y_title <- rlang::as_name(rlang::enquo(y))
# if (is.null(group_title)) group_title <- rlang::as_name(rlang::enquo(group))
point <- function(df, x, y, group = "", add_color = color("branding_reach_red"), flip = TRUE, alpha = 1, size = 2, x_title = NULL, y_title = NULL, group_title = NULL, title = NULL, subtitle = NULL, caption = NULL, theme_fun = theme_reach(grid_major_y = TRUE), palette = "cat_5_ibm", scale_impact = TRUE, direction = 1, reverse_guide = TRUE) {
# # Check if numeric and character
if (!any(c("numeric", "integer") %in% class(df[[x]]))) rlang::abort(paste0(x, " must be numeric."))
if (!any(c("numeric", "integer") %in% class(df[[y]]))) rlang::abort(paste0(x, " must be numeric."))
# Mapping
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(x = {{ x }}, y = {{ y }}, fill = {{ group }}, color = {{ group }}
if (group != "") {
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(
x = !!rlang::sym(x),
y = !!rlang::sym(y),
fill = !!rlang::sym(group),
color = !!rlang::sym(group)
)
)
)
} else {
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(
x = !!rlang::sym(x),
y = !!rlang::sym(y)
)
)
}
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
@ -47,35 +58,33 @@ point <- function(df, x, y, group = NULL, flip = TRUE, alpha = 1, size = 1, x_ti
fill = group_title
)
width <- 0.5
dodge_width <- 0.5
# Should the graph use position_fill?
g <- g + ggplot2::geom_point(
if (group != "") {
g <- g + ggplot2::geom_point(
alpha = alpha,
size = size
)
} else {
g <- g + ggplot2::geom_point(
alpha = alpha,
size = size,
color = add_color
)
}
# Labels to percent and expand scale
# if (percent) {
# g <- g + ggplot2::scale_y_continuous(
# labels = scales::label_percent(
# accuracy = 1,
# decimal.mark = ",",
# suffix = " %"),
# expand = c(0.01, 0.1)
# )
# } else {
# g <- g + ggplot2::scale_y_continuous(expand = c(0.01, 0.1))
# }
# # Because a text legend should always be horizontal, especially for an horizontal bar graph
if (flip){
if (flip) {
g <- g + ggplot2::coord_flip()
}
# Add theme
g <- g + theme
g <- g + theme_fun
# Add theme
if (!is.null(theme_fun)) g <- g + theme_fun
# Add scale
if (scale_impact) g <- g + scale_fill_impact_discrete(palette, direction, reverse_guide) + scale_color_impact_discrete(palette, direction, reverse_guide)
return(g)
}

321
R/scale.R
View file

@ -1,248 +1,187 @@
#' Color scale constructor for REACH or AGORA colors
#' One scale for all
#'
#' This function is based on [palette()]. If palette is NULL, the used palette will be magma from gpplot2's viridis scale constructors.
#'
#' @inheritParams palette_gen
#'
#' @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.
#' @param reverse_guide Boolean indicating whether the guide should be reversed.
#' @param ... Additional arguments passed to discrete_scale() or
#' scale_fill_gradient(), used respectively when discrete is TRUE or FALSE.
#'
#' @return A color scale for ggplot
#' @param ... Additional arguments passed to [ggplot2::discrete_scale()] if discrete or [ggplot2::scale_fill_gradient()] if continuous.
#'
#' @export
scale_color <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) {
scale_visualizer_discrete <- function(palette = "cat_5_main", direction = 1, reverse_guide = TRUE, ...) {
if (initiative == "reach") {
s <- scale_color_visualizer_discrete(palette, direction, reverse_guide, ...) +
scale_fill_visualizer_discrete(palette, direction, reverse_guide, ...)
pal <- pal_reach(palette)
return(s)
if (is.null(pal)) {
}
pal <- pal_fallback(
reverse = reverse,
discrete = discrete,
color_ramp_palette = TRUE)
#' @rdname scale_visualizer_dicscrete
#'
#' @export
scale_visualizer_continuous <- function(palette = "seq_5_main", direction = 1, reverse_guide = 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.")
)
)
s <- scale_color_visualizer_continuous(palette, direction, reverse_guide, ...) +
scale_fill_visualizer_continuous(palette, direction, reverse_guide, ...)
if (discrete) palette <- "viridis" else palette <- "magma"
return(s)
} else {
}
pal <- pal_reach(
palette = palette,
reverse = reverse,
color_ramp_palette = TRUE,
show_palettes = FALSE
)
#' Scale constructors for fill and colors
#'
#' This function is based on [palette()]. If palette is NULL, the used palette will be magma from gpplot2's viridis scale constructors.
#'
#' @inheritParams palette_gen
#'
#' @param reverse_guide Boolean indicating whether the guide should be reversed.
#' @param ... Additional arguments passed to [ggplot2::discrete_scale()] if discrete or [ggplot2::scale_fill_gradient()] if continuous.
#'
#' @export
scale_color_visualizer_discrete <- function(palette = "cat_5_main", direction = 1, reverse_guide = TRUE, ...) {
}
} 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(
paste0("There is no initiative '", initiative, "."),
"i" = paste0("initiative should be either 'reach', 'agora' or 'default'")
)
)
}
if (discrete) {
if (!(is.null(palette))) {
ggplot2::discrete_scale(
"colour",
paste0(initiative, "_", palette),
palette = pal,
"color",
palette = palette_gen(palette, "categorical", direction),
guide = ggplot2::guide_legend(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
ticks.colour = "#F1F3F5",
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...
)
} else {
ggplot2::scale_color_gradientn(
colours = pal(256),
guide = ggplot2::guide_colorbar(
ggplot2::scale_colour_viridis_d(
direction = direction,
guide = ggplot2::guide_legend(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
ticks.colour = "#F1F3F5",
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...
)
}
}
#' Fill scale constructor for REACH or AGORA colors
#'
#' @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.
#' @param reverse_guide Boolean indicating whether the guide should be reversed.
#' @param ... Additional arguments passed to discrete_scale() or
#' scale_fill_gradient(), used respectively when discrete is TRUE or FALSE.
#'
#' @return A fill scale for ggplot.
#' @rdname scale_color_visualizer_discrete
#'
#' @export
scale_fill <- function(initiative = "reach", palette = "main", discrete = TRUE, reverse = FALSE, reverse_guide = TRUE, ...) {
scale_fill_visualizer_discrete <- function(palette = "cat_5_main", direction = 1, reverse_guide = TRUE, ...) {
if (!(is.null(palette))) {
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(
paste0("There is no initiative '", initiative, "."),
"i" = paste0("initiative should be either 'reach', 'agora' or 'default'")
)
)
}
if (discrete) {
ggplot2::discrete_scale(
"fill",
paste0(initiative, "_", palette),
palette = pal,
palette = palette_gen(palette, "categorical", direction),
guide = ggplot2::guide_legend(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
ticks.colour = "#F1F3F5",
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...
)
} else {
ggplot2::scale_color_gradientn(
colours = pal(256),
guide = ggplot2::guide_colorbar(
ggplot2::scale_fill_viridis_d(
direction = direction,
guide = ggplot2::guide_legend(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
ticks.colour = "#F1F3F5",
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...
)
}
}
#' @rdname scale_color_visualizer_discrete
#'
#' @export
scale_fill_visualizer_continuous <- function(palette = "seq_5_main", direction = 1, reverse_guide = TRUE, ...) {
if (!(is.null(palette))) {
pal <- palette_gen(palette, "continuous", direction)
ggplot2::scale_fill_gradientn(
colors = pal(256),
guide = ggplot2::guide_colorbar(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...
)
} else {
ggplot2::scale_fill_viridis_c(
option = "magma",
guide = ggplot2::guide_colorbar(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...)
}
}
#' @rdname scale_color_visualizer_discrete
#'
#' @export
scale_color_visualizer_continuous <- function(palette = "seq_5_main", direction = 1, reverse_guide = TRUE, ...) {
if (!(is.null(palette))) {
pal <- palette_gen(palette, "continuous", direction)
ggplot2::scale_fill_gradientn(
colors = pal(256),
guide = ggplot2::guide_colorbar(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
...
)
} else {
ggplot2::scale_colour_viridis_c(
option = "magma",
guide = ggplot2::guide_colorbar(
title.position = "top",
draw.ulim = TRUE,
draw.llim = TRUE,
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
....)
}
}

22
R/test-example.R Normal file
View file

@ -0,0 +1,22 @@
dat <- data.frame(
x = c(15, 34, 59, 21, 33, 66),
y = c("Admin A", "Admin B", "Admin C", "Admin C", "Admin B", "Admin A"),
group = c("Displaced", "Non displaced", "Non displaced", "Displaced", "Displaced", "Non displaced")
)
dat |>
bar(
x = "y",
y = "x",
group = "group",
flip = F,
add_text = F,
title = "In Admin A and C, Non-Displaced Persons Face Greater WASH Challenges Than Their Displaced Counterparts",
subtitle = "% of households not accessing WASH services by admin 1 and status",
caption = "Source: FAO 2022. No message is a real one. Fake data are used in this example. As a cautiom, no decision should be made based on this plot.",
) +
theme_visualizer_bar() +
scale_color_visualizer_discrete() +
scale_fill_visualizer_discrete()

385
R/theme.R Normal file
View file

@ -0,0 +1,385 @@
#' ggplot2 theme for bar charts with sane defaults
#'
#' @rdname theme_visualizer
#' @inheritParams theme_visualizer
#'
#' @export
theme_visualizer_bar <- function(...) {
theme_visualizer_default(
grid_major_y = TRUE
, axis_line_y = FALSE
, axis_ticks_y = FALSE
, grid_major_x = FALSE
, ...
)
}
#' ggplot2 theme wrapper with fonts and colors
#'
#' @param font_family The font family for all plot's texts. Default to "Segoe UI".
#' @param title_size The size of the title. Defaults to 12.
#' @param title_color Title color.
#' @param title_font_face Title font face. Default to "bold". Font face ("plain", "italic", "bold", "bold.italic").
#' @param title_hjust Title horizontal justification. Default to NULL. Use 0.5 to center the title.
#' @param title_font_family Title font family. Default to "Roboto Condensed".
#' @param text_size The size of all text other than the title, subtitle and caption. Defaults to 10.
#' @param text_color Text color.
#' @param text_font_face Text font face. Default to "bold". Font face ("plain", "italic", "bold", "bold.italic").
#' @param panel_background_color The color for the panel background color. Default to white.
#' @param panel_border Boolean. Plot a panel border? Default to FALSE.
#' @param panel_border_color A color. Default to REACH main grey.
#' @param legend_position Position of the legend; Default to "right". Can take "right", "left", "top", "bottom" or "none".
#' @param legend_direction Direction of the legend. Default to "vertical". Can take "vertical" or "horizontal".
#' @param legend_justification In addition to legend_direction, place the legend. Can take "left", "bottom", "center", "right", "top".
#' @param legend_title_size Legend title size.
#' @param legend_title_color Legend title color.
#' @param legend_title_font_face Legend title font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param legend_text_size Legend text size.
#' @param legend_text_color Legend text color.
#' @param legend_text_font_face Legend text font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param legend_reverse Reverse the color in the guide? Default to TRUE.
#' @param title_size The size of the legend title. Defaults to 11.
#' @param title_color Legend title color.
#' @param title_font_face Legend title font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param title_position_to_plot TRUE or FALSE. Positioning to plot or to panel?
#' @param axis_x Boolean. Do you need x-axis?
#' @param axis_y Boolean. Do you need y-axis?
#' @param axis_text_size Axis text size.
#' @param axis_text_color Axis text color.
#' @param axis_text_font_face Axis text font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param axis_text_x Boolean. Do you need the text for the x-axis?
#' @param axis_line_x Boolean. Do you need the line for the x-axis?
#' @param axis_ticks_x Boolean. Do you need the line for the x-axis?
#' @param axis_text_x_angle Angle for the x-axis text.
#' @param axis_text_x_vjust Vertical adjustment for the x-axis text.
#' @param axis_text_x_hjust Vertical adjustment for the x-axis text.
#' @param axis_text_y Boolean. Do you need the text for the y-axis?
#' @param axis_line_y Boolean. Do you need the line for the y-axis?
#' @param axis_ticks_y Boolean. Do you need the line for the y-axis?
#' @param axis_title_size Axis title size.
#' @param axis_title_color Axis title color.
#' @param axis_title_font_face Axis title font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param grid_major_x Boolean. Do you need major grid lines for x-axis?
#' @param grid_major_y Boolean. Do you need major grid lines for y-axis?
#' @param grid_major_x_size Major X line size.
#' @param grid_major_y_size Major Y line size.
#' @param grid_major_color Major grid lines color.
#' @param grid_minor_x Boolean. Do you need minor grid lines for x-axis?
#' @param grid_minor_y Boolean. Do you need minor grid lines for y-axis?
#' @param grid_minor_x_size Minor X line size.
#' @param grid_minor_y_size Minor Y line size.
#' @param grid_minor_color Minor grid lines color.
#' @param caption_position_to_plot TRUE or FALSE. Positioning to plot or to panel?
#' @param ... Additional arguments passed to [ggplot2::theme()].
#'
#'
#' @description Give some reach colors and fonts to a ggplot.
#'
#' @export
theme_visualizer_default <- function(
font_family = "Carlito",
title_size = 14,
title_color = color("dark_grey"),
title_font_face = "bold",
title_hjust = NULL,
title_position_to_plot = TRUE,
title_font_family = "Carlito",
subtitle_size = 13,
subtitle_font_face = "plain",
subtitle_font_family = "Carlito",
text_size = 12,
text_color = color("dark_grey"),
text_font_face = "plain",
panel_background_color = "#FFFFFF",
panel_border = FALSE,
panel_border_color = color("dark_grey"),
legend_position = "bottom",
legend_direction = "horizontal",
legend_justification = "center",
legend_reverse = TRUE,
legend_title_size = 12,
legend_title_color = color("dark_grey"),
legend_title_font_face = "plain",
legend_text_size = 12,
legend_text_color = color("dark_grey"),
legend_text_font_face = "plain",
axis_x = TRUE,
axis_y = TRUE,
axis_text_x = TRUE,
axis_line_x = TRUE,
axis_ticks_x = TRUE,
axis_text_y = TRUE,
axis_line_y = TRUE,
axis_ticks_y = TRUE,
axis_text_size = 12,
axis_text_color = color("dark_grey"),
axis_text_font_face = "plain",
axis_title_size = 15,
axis_title_color = color("dark_grey"),
axis_title_font_face = "plain",
axis_text_x_angle = 0,
axis_text_x_vjust = 0.5,
axis_text_x_hjust = 0.5,
grid_major_x = TRUE,
grid_major_y = FALSE,
grid_major_color = color("dark_grey"),
grid_major_x_size = 0.1,
grid_major_y_size = 0.1,
grid_minor_x = FALSE,
grid_minor_y = FALSE,
grid_minor_color = color("dark_grey"),
grid_minor_x_size = 0.05,
grid_minor_y_size = 0.05,
caption_position_to_plot = TRUE,
caption_text_size = 10,
caption_text_color = color("dark_grey"),
...) {
# Basic simple theme
# theme <- ggplot2::theme_bw()
theme <- ggplot2::theme(
# Title - design
title = ggtext::element_textbox_simple(
family = title_font_family,
color = title_color,
size = title_size,
face = title_font_face
),
# Text - design
text = ggplot2::element_text(
family = font_family,
color = text_color,
size = text_size,
face = text_font_face
),
# Default legend to right position
legend.position = legend_position,
# Defaut legend to vertical direction
legend.direction = legend_direction,
# Default legend to left justified
legend.justification = legend_justification,
# set panel background color
panel.background = ggplot2::element_rect(
fill = panel_background_color
),
# Remove background for legend key
legend.key = ggplot2::element_blank(),
# Text sizes
axis.text = ggplot2::element_text(
size = axis_text_size,
family = font_family,
face = axis_text_font_face,
color = axis_text_color
),
axis.title = ggplot2::element_text(
size = axis_title_size,
family = font_family,
face = axis_title_font_face,
color = axis_title_color
),
# Wrap title
plot.title = ggtext::element_textbox_simple(
hjust = title_hjust,
width = grid::unit(0.8, "npc"),
margin = ggplot2::margin(b = 5)
),
plot.subtitle = ggtext::element_textbox_simple(
hjust = title_hjust,
family = subtitle_font_family,
color = text_color,
size = subtitle_size,
face = subtitle_font_face,
margin = ggplot2::margin(t = 5, b = 5)
),
plot.caption = ggtext::element_textbox_simple(
size = caption_text_size,
family = font_family,
color = caption_text_color
),
legend.title = ggplot2::element_text(
size = legend_title_size,
face = legend_title_font_face,
family = font_family,
color = legend_title_color
),
legend.text = ggplot2::element_text(
size = legend_text_size,
face = legend_text_font_face,
family = font_family,
color = legend_text_color
),
axis.text.x = ggplot2::element_text(
angle = axis_text_x_angle,
vjust = axis_text_x_vjust,
hjust = axis_text_x_hjust
)
)
# Position of title
if (title_position_to_plot) {
theme <- theme +
ggplot2::theme(
plot.title.position = "plot"
)
}
if (caption_position_to_plot) {
theme <- theme +
ggplot2::theme(
plot.caption.position = "plot"
)
}
# Position of caption
# Axis lines ?
if (axis_x & axis_y) {
theme <- theme +
ggplot2::theme(
axis.line = ggplot2::element_line(color = text_color)
)
}
if (!axis_x) {
theme <- theme +
ggplot2::theme(
axis.line.x = ggplot2::element_blank(),
axis.ticks.x = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank()
)
}
if (!axis_y) {
theme <- theme +
ggplot2::theme(
axis.line.y = ggplot2::element_blank(),
axis.ticks.y = ggplot2::element_blank(),
axis.text.y = ggplot2::element_blank()
)
}
if (!axis_line_x) {
theme <- theme +
ggplot2::theme(
axis.line.x = ggplot2::element_blank()
)
}
if (!axis_ticks_x) {
theme <- theme +
ggplot2::theme(
axis.ticks.x = ggplot2::element_blank()
)
}
if (!axis_text_x) {
theme <- theme +
ggplot2::theme(
axis.text.x = ggplot2::element_blank()
)
}
if (!axis_line_y) {
theme <- theme +
ggplot2::theme(
axis.line.y = ggplot2::element_blank()
)
}
if (!axis_ticks_y) {
theme <- theme +
ggplot2::theme(
axis.ticks.y = ggplot2::element_blank()
)
}
if (!axis_text_y) {
theme <- theme +
ggplot2::theme(
axis.text.y = ggplot2::element_blank()
)
}
# X - major grid lines
if (!grid_major_x) {
theme <- theme +
ggplot2::theme(
panel.grid.major.x = ggplot2::element_blank()
)
} else {
theme <- theme +
ggplot2::theme(
panel.grid.major.x = ggplot2::element_line(
color = grid_major_color,
linewidth = grid_major_x_size
)
)
}
# Y - major grid lines
if (!grid_major_y) {
theme <- theme +
ggplot2::theme(
panel.grid.major.y = ggplot2::element_blank()
)
} else {
theme <- theme +
ggplot2::theme(
panel.grid.major.y = ggplot2::element_line(
color = grid_major_color,
linewidth = grid_major_y_size
)
)
}
# X - minor grid lines
if (!grid_minor_x) {
theme <- theme +
ggplot2::theme(
panel.grid.minor.x = ggplot2::element_blank()
)
} else {
theme <- theme +
ggplot2::theme(
panel.grid.minor.x = ggplot2::element_line(
color = grid_minor_color,
linewidth = grid_minor_x_size
)
)
}
# Y - minor grid lines
if (!grid_minor_y) {
theme <- theme +
ggplot2::theme(
panel.grid.minor.y = ggplot2::element_blank()
)
} else {
theme <- theme +
ggplot2::theme(
panel.grid.minor.y = ggplot2::element_line(
color = grid_minor_color,
linewidth = grid_minor_y_size
)
)
}
if (!panel_border) {
theme <- theme +
ggplot2::theme(
panel.border = ggplot2::element_blank()
)
} else {
theme <- theme +
ggplot2::theme(
panel.border = ggplot2::element_rect(color = panel_background_color)
)
}
# Other parameters
theme <- theme + ggplot2::theme(...)
return(theme)
}

290
R/theme_reach.R
View file

@ -1,290 +0,0 @@
#' @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.
#' @param font_family The font family for all plot's texts. Default to "Segoe UI".
#' @param title_size The size of the title. Defaults to 12.
#' @param title_color Title color.
#' @param title_font_face Title font face. Default to "bold". Font face ("plain", "italic", "bold", "bold.italic").
#' @param title_hjust Title horizontal justification. Default to NULL. Use 0.5 to center the title.
#' @param text_size The size of all text other than the title, subtitle and caption. Defaults to 10.
#' @param text_color Text color.
#' @param text_font_face Text font face. Default to "bold". Font face ("plain", "italic", "bold", "bold.italic").
#' @param panel_background_color The color for the panel background color. Default to white.
#' @param panel_border Boolean. Plot a panel border? Default to FALSE.
#' @param panel_border_color A color. Default to REACH main grey.
#' @param legend_position Position of the legend; Default to "right". Can take "right", "left", "top", "bottom" or "none".
#' @param legend_direction Direction of the legend. Default to "vertical". Can take "vertical" or "horizontal".
#' @param legend_title_size Legend title size.
#' @param legend_title_color Legend title color.
#' @param legend_title_font_face Legend title font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param legend_text_size Legend text size.
#' @param legend_text_color Legend text color.
#' @param legend_text_font_face Legend text font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param legend_reverse Reverse the color in the guide? Default to TRUE.
#' @param title_size The size of the legend title. Defaults to 11.
#' @param title_color Legend title color.
#' @param title_font_face Legend title font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param title_position_to_plot TRUE or FALSE. Positioning to plot or to panel?
#' @param axis_x Boolean. Do you need x-axis?
#' @param axis_y Boolean. Do you need y-axis?
#' @param axis_text_size Axis text size.
#' @param axis_text_color Axis text color.
#' @param axis_text_font_face Axis text font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param axis_text_x_angle Angle for the x-axis text.
#' @param axis_text_x_vjust Vertical adjustment for the x-axis text.
#' @param axis_text_x_hjust Vertical adjustment for the x-axis text.
#' @param axis_title_size Axis title size.
#' @param axis_title_color Axis title color.
#' @param axis_title_font_face Axis title font face. Default to "plain". Font face ("plain", "italic", "bold", "bold.italic").
#' @param grid_major_x Boolean. Do you need major grid lines for x-axis?
#' @param grid_major_y Boolean. Do you need major grid lines for y-axis?
#' @param grid_major_x_size Major X line size.
#' @param grid_major_y_size Major Y line size.
#' @param grid_major_color Major grid lines color.
#' @param grid_minor_x Boolean. Do you need minor grid lines for x-axis?
#' @param grid_minor_y Boolean. Do you need minor grid lines for y-axis?
#' @param grid_minor_x_size Minor X line size.
#' @param grid_minor_y_size Minor Y line size.
#' @param grid_minor_color Minor grid lines color.
#' @param caption_position_to_plot TRUE or FALSE. Positioning to plot or to panel?
#' @param ... Additional arguments passed to `ggplot2::gg_theme()`.
#'
#'
#' @description Give some reach colors and fonts to a ggplot.
#'
#' @return The base REACH theme
#'
#' @export
theme_reach <- function(
initiative = "reach",
palette = "main",
discrete = TRUE,
reverse = FALSE,
font_family = "Segoe UI",
title_size = 12,
title_color = cols_reach("main_grey"),
title_font_face = "bold",
title_hjust = NULL,
title_position_to_plot = TRUE,
text_size = 10,
text_color = cols_reach("main_grey"),
text_font_face = "plain",
panel_background_color = "#FFFFFF",
panel_border = FALSE,
panel_border_color = cols_reach("main_grey"),
legend_position = "right",
legend_direction = "vertical",
legend_reverse = TRUE,
legend_title_size = 11,
legend_title_color = cols_reach("main_grey"),
legend_title_font_face = "plain",
legend_text_size = 10,
legend_text_color = cols_reach("main_grey"),
legend_text_font_face = "plain",
axis_x = TRUE,
axis_y = TRUE,
axis_text_size = 10,
axis_text_color = cols_reach("main_grey"),
axis_text_font_face = "plain",
axis_title_size = 11,
axis_title_color = cols_reach("main_grey"),
axis_title_font_face = "bold",
axis_text_x_angle = 0,
axis_text_x_vjust = 0.5,
axis_text_x_hjust = 0.5,
grid_major_x = FALSE,
grid_major_y = FALSE,
grid_major_color = cols_reach("main_lt_grey"),
grid_major_x_size = 0.1,
grid_major_y_size = 0.1,
grid_minor_x = FALSE,
grid_minor_y = FALSE,
grid_minor_color = cols_reach("main_lt_grey"),
grid_minor_x_size = 0.05,
grid_minor_y_size = 0.05,
caption_position_to_plot = TRUE,
...
) {
# 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()
theme_reach <- ggplot2::theme(
# Title - design
title = ggplot2::element_text(
family = font_family,
color = title_color,
size = title_size,
face = title_font_face
),
# Text - design
text = ggplot2::element_text(
family = font_family,
color = text_color,
size = text_size,
face = text_font_face
),
# Default legend to right position
legend.position = legend_position,
# Defaut legend to vertical direction
legend.direction = legend_direction,
# set panel background color
panel.background = ggplot2::element_rect(
fill = panel_background_color
),
# Remove background for legend key
legend.key = ggplot2::element_blank(),
# Text sizes
axis.text = ggplot2::element_text(
size = axis_text_size,
family = font_family,
face = axis_text_font_face,
color = axis_text_color
),
axis.title = ggplot2::element_text(
size = axis_title_size,
family = font_family,
face = axis_title_font_face,
color = axis_title_color),
# Wrap title
plot.title = ggtext::element_textbox(
hjust = title_hjust
),
plot.subtitle = ggtext::element_textbox(
hjust = title_hjust
),
plot.caption = ggtext::element_textbox(),
legend.title = ggplot2::element_text(
size = legend_title_size,
face = legend_title_font_face,
family = font_family,
color = legend_title_color),
legend.text = ggplot2::element_text(
size = legend_text_size,
face = legend_text_font_face,
family = font_family,
color = legend_text_color
),
axis.text.x = ggplot2::element_text(
angle = axis_text_x_angle,
vjust = axis_text_x_vjust,
hjust = axis_text_x_hjust
)
)
# Position of title
if (title_position_to_plot) theme_reach <- theme_reach +
ggplot2::theme(
plot.title.position = "plot"
)
if (caption_position_to_plot) theme_reach <- theme_reach +
ggplot2::theme(
plot.caption.position = "plot"
)
# Position of caption
# Axis lines ?
if (axis_x & axis_y) {
theme_reach <- theme_reach +
ggplot2::theme(
axis.line = ggplot2::element_line(color = text_color))
}
if (!axis_x) {
theme_reach <- theme_reach +
ggplot2::theme(
axis.line.x = ggplot2::element_blank(),
axis.ticks.x = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank())
}
if (!axis_y) {
theme_reach <- theme_reach +
ggplot2::theme(
axis.line.y = ggplot2::element_blank(),
axis.ticks.y = ggplot2::element_blank(),
axis.text.y = ggplot2::element_blank())
}
# X - major grid lines
if (!grid_major_x) theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.major.x = ggplot2::element_blank()
) else theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.major.x = ggplot2::element_line(
color = grid_major_color,
linewidth = grid_major_x_size)
)
# Y - major grid lines
if (!grid_major_y) theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.major.y = ggplot2::element_blank()
) else theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.major.y = ggplot2::element_line(
color = grid_major_color,
linewidth = grid_major_y_size)
)
# X - minor grid lines
if (!grid_minor_x) theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.minor.x = ggplot2::element_blank()
) else theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.minor.x = ggplot2::element_line(
color = grid_minor_color,
linewidth = grid_minor_x_size)
)
# Y - minor grid lines
if (!grid_minor_y) theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.minor.y = ggplot2::element_blank()
) else theme_reach <- theme_reach +
ggplot2::theme(
panel.grid.minor.y = ggplot2::element_line(
color = grid_minor_color,
linewidth = grid_minor_y_size)
)
if (!panel_border) theme_reach <- theme_reach +
ggplot2::theme(
panel.border = ggplot2::element_blank()
) else theme_reach <- theme_reach +
ggplot2::theme(
panel.border = ggplot2::element_rect(color = panel_background_color)
)
# Other parameters
theme_reach <- theme_reach + ggplot2::theme(...)
# Add reach color palettes by default
# (reversed guide is defaulted to TRUE for natural reading)
theme_reach <- list(
theme_reach,
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)
)
return(theme_reach)
}

7
R/visualizeR-package.R
View file

@ -1,7 +0,0 @@
#' @keywords internal
"_PACKAGE"
## usethis namespace: start
#' @importFrom rlang :=
## usethis namespace: end
NULL

74
R/waffle.R
View file

@ -1,74 +0,0 @@
#' @title Simple waffle chart
#'
#' @param df A data frame.
#' @param x A character column or coercible as a character column. Will give the waffle's fill color.
#' @param y A numeric column (if plotting proportion, make sure to have percentages between 0 and 100 and not 0 and 1).
#' @param n_rows Number of rows. Default to 10.
#' @param size Width of the separator between blocks (defaults to 2).
#' @param x_title The x scale title. Default to NULL.
#' @param x_lab The x scale caption. Default to NULL.
#' @param title Plot title. Default to NULL.
#' @param subtitle Plot subtitle. Default to NULL.
#' @param caption Plot caption. Default to NULL.
#' @param arrange TRUE or FALSE. Arrange by highest percentage first.
#' @param theme Whatever theme. Default to theme_reach().
#'
#' @return A waffle chart
#'
#' @export
waffle <- function(df,
x,
y,
n_rows = 10,
size = 2,
x_title = NULL,
x_lab = NULL,
title = NULL,
subtitle = NULL,
caption = NULL,
arrange = TRUE,
theme = theme_reach(
axis_x = FALSE,
axis_y = FALSE,
legend_position = "bottom",
legend_direction = "horizontal",
title_hjust = 0.5)){
# A basic and not robust check
# - add check between 0 and 1
# Arrange by biggest prop first ?
if (arrange) df <- dplyr::arrange(
df,
dplyr::desc({{ y }})
)
# Mutate to 100
# df <- dplyr::mutate(df, "{{y}}" := {{ y }} * 100)
# Prepare named vector
values <- stats::setNames(dplyr::pull(df, {{ y }}), dplyr::pull(df, {{ x }}))
# Make plot
g <- waffle::waffle(values, xlab = x_lab, rows = n_rows, size = size)
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
fill = x_title,
color = x_title
)
# Basic theme
# g <- g +
# hrbrthemes::theme_ipsum() #+
# waffle::theme_enhance_waffle()
# Add theme
g <- g + theme
return(g)
}