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

Air formatting

Browse source
This commit is contained in:
gnoblet 2025-07-01 19:49:47 +02:00
parent a4f398ab3d
commit ead630c106
13 changed files with 816 additions and 640 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

240
R/bar.R
View file

@ -3,7 +3,12 @@
#' @inheritParams bar
#'
#' @export
hbar <- function(..., flip = TRUE, add_text = FALSE, theme_fun = theme_bar(flip = flip, add_text = add_text)) {
hbar <- function(
...,
flip = TRUE,
add_text = FALSE,
theme_fun = theme_bar(flip = flip, add_text = add_text)
) {
bar(flip = flip, add_text = add_text, theme_fun = theme_fun, ...)
}
@ -93,8 +98,6 @@ bar <- function(
scale_fill_fun = scale_fill_visualizer_discrete(),
scale_color_fun = scale_color_visualizer_discrete()
) {
#------ Checks
# df is a data frame
@ -108,7 +111,9 @@ checkmate::assert_character(group, len = 1)
# x and y are columns in df
checkmate::assert_choice(x, colnames(df))
checkmate::assert_choice(y, colnames(df))
if (group != "") checkmate::assert_choice(group, colnames(df))
if (group != "") {
checkmate::assert_choice(group, colnames(df))
}
# x_rm_na, y_rm_na and group_rm_na are logical scalar
checkmate::assert_logical(x_rm_na, len = 1)
@ -120,7 +125,9 @@ checkmate::assert_logical(facet_rm_na, len = 1)
checkmate::assert_logical(flip, len = 1)
# wrap is a numeric scalar or NULL
if (!is.null(wrap)) checkmate::assert_numeric(wrap, len = 1, null.ok = TRUE)
if (!is.null(wrap)) {
checkmate::assert_numeric(wrap, len = 1, null.ok = TRUE)
}
# alpha is a numeric scalar between 0 and 1
checkmate::assert_numeric(alpha, lower = 0, upper = 1, len = 1)
@ -147,11 +154,20 @@ checkmate::assert_numeric(add_text_expand_limit, len = 1)
checkmate::assert_numeric(add_text_round, len = 1)
# x and y are numeric or 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"))
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"))
}
# width is a numeric scalar between 0 and 1
checkmate::assert_numeric(width, lower = 0, upper = 1, len = 1)
# Check if position is stack or dodge
if (position %notin% c("stack", "dodge")) rlang::abort("Position should be either 'stack' or 'dodge'.")
if (position %notin% c("stack", "dodge")) {
rlang::abort("Position should be either 'stack' or 'dodge'.")
}
#----- Data wrangling
@ -161,11 +177,18 @@ if (group != "" && facet != "" && group == facet) {
}
# remove NAs using base R
if (x_rm_na) df <- df[!(is.na(df[[x]])),]
if (y_rm_na) df <- df[!(is.na(df[[y]])),]
if (group != "" && group_rm_na) df <- df[!(is.na(df[[group]])),]
if (facet != "" && facet_rm_na) df <- df[!(is.na(df[[facet]])),]
if (x_rm_na) {
df <- df[!(is.na(df[[x]])), ]
}
if (y_rm_na) {
df <- df[!(is.na(df[[y]])), ]
}
if (group != "" && group_rm_na) {
df <- df[!(is.na(df[[group]])), ]
}
if (facet != "" && facet_rm_na) {
df <- df[!(is.na(df[[facet]])), ]
}
# reorder
dir_order <- if (flip && order %in% c("x", "grouped_x")) {
@ -182,11 +205,17 @@ group_order <- if (group != "" || (group == "" && facet == "")) {
} else if (group == "" && facet != "") {
facet
}
df <- reorder_by(df = df, x = x, y = y, group = group_order, order = order, dir_order = dir_order)
df <- reorder_by(
df = df,
x = x,
y = y,
group = group_order,
order = order,
dir_order = dir_order
)
# prepare aes
if (group != "") {
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(
@ -196,9 +225,7 @@ if(group != "") {
color = !!rlang::sym(group)
)
)
} else {
g <- ggplot2::ggplot(
df,
mapping = ggplot2::aes(
@ -209,7 +236,8 @@ if(group != "") {
}
# add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
g <- g +
ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
@ -226,57 +254,52 @@ dodge_width <- width
# facets
if (facet != "") {
if (flip) {
g <- g + ggplot2::facet_grid(rows = ggplot2::vars(!!rlang::sym(facet)), scales = "free", space = "free_y")
g <- g +
ggplot2::facet_grid(
rows = ggplot2::vars(!!rlang::sym(facet)),
scales = "free",
space = "free_y"
)
} else {
g <- g + ggplot2::facet_grid(cols = ggplot2::vars(!!rlang::sym(facet)), scales = "free", space = "free_x")
g <- g +
ggplot2::facet_grid(
cols = ggplot2::vars(!!rlang::sym(facet)),
scales = "free",
space = "free_x"
)
}
}
# Guides for legend
# g <- g + ggplot2::guides(
# fill = ggplot2::guide_legend(
# title.position = "left",
# title.hjust = 0,
# label.hjust = 0.5,
# #label.position = "bottom",
# direction = "horizontal"),
# color = ggplot2::guide_legend(
# title.position = "left",
# title.hjust = 0,
# label.hjust = 0.5,
# #label.position = "bottom",
# direction = "horizontal")
# )
# should the graph use position_fill?
if (group != "") {
if (position == "stack") {
g <- g + ggplot2::geom_col(
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_stack()
)
} else if (position == "dodge") {
g <- g + ggplot2::geom_col(
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_dodge2(
width = dodge_width,
preserve = "single")
preserve = "single"
)
)
} else {
g <- g + ggplot2::geom_col(
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width
)
}
} else {
if (position == "stack") {
g <- g + ggplot2::geom_col(
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_stack(),
@ -284,17 +307,20 @@ if(group != "") {
color = add_color
)
} else if (position == "dodge") {
g <- g + ggplot2::geom_col(
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_dodge2(
width = dodge_width,
preserve = "single"),
preserve = "single"
),
fill = add_color,
color = add_color
)
} else {
g <- g + ggplot2::geom_col(
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
fill = add_color,
@ -308,14 +334,23 @@ 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
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
}
# Function for interaction
# function for interaction
interaction_f <- function(group, facet, data) {
if (group == "" && facet == "") {
return(NULL)
@ -330,14 +365,20 @@ interaction_f <- function(group, facet, data) {
}
}
# 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 ))
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(
g <- g +
ggplot2::geom_blank(
data = df,
ggplot2::aes(
x = !!rlang::sym(x),
@ -345,28 +386,18 @@ if (add_text & position == "dodge") {
group = interaction_f(group, facet, df)
)
)
g <- g + ggplot2::geom_text(
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 = interaction_f(group, facet, df)),
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)
label = ifelse(
is.na(!!rlang::sym("y_threshold")),
NA,
paste0(
round(!!rlang::sym("y_threshold"), add_text_round),
add_text_suffix
)
} 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 = interaction_f(group, facet, df)
),
hjust = hjust_flip,
@ -376,7 +407,37 @@ if (add_text & position == "dodge") {
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 = interaction_f(group, facet, df)
),
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)
)
}
# y scale tweaks
@ -389,19 +450,28 @@ if (add_text & position == "dodge") {
accuracy = 0.1,
drop0trailing = TRUE,
big.mark = "",
decimal.mark = "."),
decimal.mark = "."
),
)
# Remove guides for legend if !add_color_guide
if (!add_color_guide) g <- g + ggplot2::guides(fill = "none", color = "none")
# # remove guides for legend if !add_color_guide
if (!add_color_guide) {
g <- g + ggplot2::guides(fill = "none", color = "none")
}
# Add theme fun
if (!is.null(theme_fun)) g <- g + theme_fun
# # add theme fun
if (!is.null(theme_fun)) {
g <- g + theme_fun
}
# Add scale fun
if (!is.null(scale_fill_fun)) g <- g + scale_fill_fun
# # # add scale fun
if (!is.null(scale_fill_fun)) {
g <- g + scale_fill_fun
}
if (!is.null(scale_color_fun)) g <- g + scale_color_fun
if (!is.null(scale_color_fun)) {
g <- g + scale_color_fun
}
return(g)
}

6
R/checks.R
View file

@ -8,6 +8,10 @@ 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."))
rlang::abort(glue::glue(
"Variables ",
glue::glue_collapse(vars_nin, sep = ", ", last = ", and "),
" not found in data frame."
))
}
}

120
R/color.R
View file

@ -16,7 +16,6 @@
#'
#' @export
color <- function(..., unname = TRUE) {
#------ Prep
# Retrieve colors
@ -24,63 +23,62 @@ color <- function(..., unname = TRUE) {
# Defined colors
colors <- c(
white = "#FFFFFF"
, lighter_grey = "#F5F5F5"
, light_grey = "#E3E3E3"
, dark_grey = "#464647"
, light_blue_grey = "#B3C6D1"
, grey = "#71716F"
, 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"
white = "#FFFFFF",
lighter_grey = "#F5F5F5",
light_grey = "#E3E3E3",
dark_grey = "#464647",
light_blue_grey = "#B3C6D1",
grey = "#71716F",
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
@ -88,10 +86,13 @@ color <- function(..., unname = TRUE) {
if (cols %notallin% names(colors)) {
rlang::abort(c(
"Some colors not defined",
"*" = glue::glue_collapse(...[which(!... %in% names(cols))], sep = ", ", last = ", and "),
"*" = glue::glue_collapse(
...[which(!... %in% names(cols))],
sep = ", ",
last = ", and "
),
"i" = "Use `color(unname = FALSE)` to see all named available colors."
)
)
))
}
}
@ -116,7 +117,6 @@ color <- function(..., unname = TRUE) {
#'
#' @export
color_pattern <- function(pattern, unname = TRUE) {
#------ Checks
# Check that pattern is a character scalar

52
R/dumbbell.R
View file

@ -29,7 +29,8 @@
#' @return A dumbbell chart.
#' @export
#'
dumbbell <- function(df,
dumbbell <- function(
df,
col,
group_x,
group_y,
@ -53,8 +54,8 @@ dumbbell <- function(df,
add_text_color = color("dark_grey"),
theme_fun = theme_dumbbell(),
scale_fill_fun = scale_fill_visualizer_discrete(),
scale_color_fun = scale_color_visualizer_discrete()){
scale_color_fun = scale_color_visualizer_discrete()
) {
#------ Checks
# df is a data frame
@ -88,7 +89,11 @@ dumbbell <- function(df,
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")
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 |>
@ -101,8 +106,17 @@ dumbbell <- function(df,
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)) |>
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)
@ -110,7 +124,6 @@ dumbbell <- function(df,
# Add line
if (line_to_y_axis) {
xend <- min(dplyr::pull(df, !!rlang::sym(col)))
g <- g +
@ -118,11 +131,13 @@ dumbbell <- function(df,
ggplot2::aes(
x = min,
y = !!rlang::sym(group_y),
yend = !!rlang::sym(group_y)),
yend = !!rlang::sym(group_y)
),
xend = xend,
linetype = line_to_y_axis_type,
linewidth = line_to_y_axis_width,
color = line_to_y_axis_color)
color = line_to_y_axis_color
)
}
# Add segment
@ -132,7 +147,8 @@ dumbbell <- function(df,
x = !!rlang::sym(group_x_keys[[1]]),
y = !!rlang::sym(group_y),
xend = !!rlang::sym(group_x_keys[[2]]),
yend = !!rlang::sym(group_y)),
yend = !!rlang::sym(group_y)
),
linewidth = segment_size,
color = segment_color
)
@ -152,7 +168,8 @@ dumbbell <- function(df,
)
# Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
g <- g +
ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
@ -163,7 +180,8 @@ dumbbell <- function(df,
)
# Add stat labels to points
if(add_text) g <- g +
if (add_text) {
g <- g +
ggrepel::geom_text_repel(
data = df,
ggplot2::aes(
@ -175,15 +193,19 @@ dumbbell <- function(df,
size = add_text_size,
color = add_text_color
)
}
# Add theme
g <- g + theme_fun
# Add scale fun
if (!is.null(scale_fill_fun)) g <- g + scale_fill_fun
if (!is.null(scale_fill_fun)) {
g <- g + scale_fill_fun
}
if (!is.null(scale_color_fun)) g <- g + scale_color_fun
if (!is.null(scale_color_fun)) {
g <- g + scale_color_fun
}
return(g)
}

53
R/palette.R
View file

@ -8,8 +8,12 @@
#' @return A color palette
#'
#' @export
palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FALSE, ...) {
palette <- function(
palette = "cat_5_main",
reverse = FALSE,
show_palettes = FALSE,
...
) {
#------ Checks
# Check that palette is a character scalar
@ -25,21 +29,28 @@ palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FAL
# 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")
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
@ -51,7 +62,9 @@ palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FAL
if (palette %notin% names(pals)) {
rlang::abort(c(
"Palette not defined",
"*" = glue::glue("Palette `{palette}` is not defined in the `palettes` list."),
"*" = glue::glue(
"Palette `{palette}` is not defined in the `palettes` list."
),
"i" = "Use `palette(show_palettes = TRUE)` to see all available palettes."
))
}
@ -60,7 +73,9 @@ palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FAL
pal <- pals[[palette]]
if (reverse) pal <- rev(pal)
if (reverse) {
pal <- rev(pal)
}
return(pal)
}

29
R/palette_gen.R
View file

@ -9,15 +9,20 @@
#'
#' @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 %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, ...))
return(palette_gen_sequential(
palette = palette,
direction = direction,
...
))
}
}
@ -26,15 +31,20 @@ palette_gen <- function(palette, type, direction = 1, ...) {
#'
#' @export
palette_gen_categorical <- function(palette = "cat_5_main", direction = 1) {
if (abs(direction) != 1) rlang::abort("Direction must be either 1 or -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 (is.null(n)) {
n <- length(pal)
}
if (n > length(pal)) rlang::warn("Not enough colors in this palette!")
if (n > length(pal)) {
rlang::warn("Not enough colors in this palette!")
}
pal <- if (direction == 1) pal else rev(pal)
@ -50,8 +60,9 @@ palette_gen_categorical <- function(palette = "cat_5_main", direction = 1) {
#'
#' @export
palette_gen_sequential <- function(palette = "seq_5_main", direction = 1, ...) {
if (abs(direction) != 1) rlang::abort("Direction must be either 1 or -1.")
if (abs(direction) != 1) {
rlang::abort("Direction must be either 1 or -1.")
}
pal <- palette(palette)

61
R/point.R
View file

@ -52,7 +52,6 @@ point <- function(
scale_fill_fun = scale_fill_visualizer_discrete(),
scale_color_fun = scale_color_visualizer_discrete()
) {
#------ Checks
# df is a data frame
@ -66,7 +65,9 @@ point <- function(
# x and y are columns in df
checkmate::assert_choice(x, colnames(df))
checkmate::assert_choice(y, colnames(df))
if (group != "") checkmate::assert_choice(group, colnames(df))
if (group != "") {
checkmate::assert_choice(group, colnames(df))
}
# x_rm_na, y_rm_na and group_rm_na are logical scalar
checkmate::assert_logical(x_rm_na, len = 1)
@ -87,9 +88,12 @@ point <- function(
checkmate::assert_numeric(size, len = 1)
# x and y are numeric
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(y, " must be numeric."))
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(y, " must be numeric."))
}
#----- Data wrangling
@ -99,10 +103,18 @@ point <- function(
}
# remove NAs using base R
if (x_rm_na) df <- df[!(is.na(df[[x]])),]
if (y_rm_na) df <- df[!(is.na(df[[y]])),]
if (group != "" && group_rm_na) df <- df[!(is.na(df[[group]])),]
if (facet != "" && facet_rm_na) df <- df[!(is.na(df[[facet]])),]
if (x_rm_na) {
df <- df[!(is.na(df[[x]])), ]
}
if (y_rm_na) {
df <- df[!(is.na(df[[y]])), ]
}
if (group != "" && group_rm_na) {
df <- df[!(is.na(df[[group]])), ]
}
if (facet != "" && facet_rm_na) {
df <- df[!(is.na(df[[facet]])), ]
}
# prepare aes
if (group != "") {
@ -126,7 +138,8 @@ point <- function(
}
# add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs(
g <- g +
ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
@ -140,13 +153,15 @@ point <- function(
# facets
if (facet != "") {
if (flip) {
g <- g + ggplot2::facet_grid(
g <- g +
ggplot2::facet_grid(
rows = ggplot2::vars(!!rlang::sym(facet)),
scales = facet_scales,
space = if (facet_scales == "free") "free_y" else "fixed"
)
} else {
g <- g + ggplot2::facet_grid(
g <- g +
ggplot2::facet_grid(
cols = ggplot2::vars(!!rlang::sym(facet)),
scales = facet_scales,
space = if (facet_scales == "free") "free_x" else "fixed"
@ -156,12 +171,14 @@ if (facet != "") {
# Should the graph use position_fill?
if (group != "") {
g <- g + ggplot2::geom_point(
g <- g +
ggplot2::geom_point(
alpha = alpha,
size = size
)
} else {
g <- g + ggplot2::geom_point(
g <- g +
ggplot2::geom_point(
alpha = alpha,
size = size,
color = add_color
@ -173,15 +190,23 @@ if (facet != "") {
}
# Remove guides for legend if !add_color_guide
if (!add_color_guide) g <- g + ggplot2::guides(fill = "none", color = "none")
if (!add_color_guide) {
g <- g + ggplot2::guides(fill = "none", color = "none")
}
# Add theme
if (!is.null(theme_fun)) g <- g + theme_fun
if (!is.null(theme_fun)) {
g <- g + theme_fun
}
# Add scale fun
if (!is.null(scale_fill_fun)) g <- g + scale_fill_fun
if (!is.null(scale_fill_fun)) {
g <- g + scale_fill_fun
}
if (!is.null(scale_color_fun)) g <- g + scale_color_fun
if (!is.null(scale_color_fun)) {
g <- g + scale_color_fun
}
return(g)
}

5
R/reorder_by.R
View file

@ -25,7 +25,6 @@
#'
#' @export
reorder_by <- function(df, x, y, group = "", order = "y", dir_order = 1) {
#------ Checks
# df is a data frame
@ -39,7 +38,9 @@ reorder_by <- function(df, x, y, group = "", order = "y", dir_order = 1){
# group is character scalar and in df if not empty
checkmate::assert_character(group, len = 1)
if (group != "") checkmate::assert_subset(group, colnames(df))
if (group != "") {
checkmate::assert_subset(group, colnames(df))
}
# order is a character scalar in c("none", "y", "grouped")
checkmate::assert_choice(order, c("none", "y", "grouped_y", "x", "grouped_x"))

42
R/scale.R
View file

@ -8,8 +8,13 @@
#' @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, title_position = NULL, ...) {
scale_color_visualizer_discrete <- function(
palette = "cat_5_main",
direction = 1,
reverse_guide = TRUE,
title_position = NULL,
...
) {
if (!(is.null(palette))) {
ggplot2::discrete_scale(
"color",
@ -41,8 +46,13 @@ scale_color_visualizer_discrete <- function(palette = "cat_5_main", direction =
#' @rdname scale_color_visualizer_discrete
#'
#' @export
scale_fill_visualizer_discrete <- function(palette = "cat_5_main", direction = 1, reverse_guide = TRUE, title_position = NULL, ...) {
scale_fill_visualizer_discrete <- function(
palette = "cat_5_main",
direction = 1,
reverse_guide = TRUE,
title_position = NULL,
...
) {
if (!(is.null(palette))) {
ggplot2::discrete_scale(
"fill",
@ -74,8 +84,13 @@ scale_fill_visualizer_discrete <- function(palette = "cat_5_main", direction = 1
#' @rdname scale_color_visualizer_discrete
#'
#' @export
scale_fill_visualizer_continuous <- function(palette = "seq_5_main", direction = 1, reverse_guide = TRUE, title_position = NULL, ...) {
scale_fill_visualizer_continuous <- function(
palette = "seq_5_main",
direction = 1,
reverse_guide = TRUE,
title_position = NULL,
...
) {
if (!(is.null(palette))) {
pal <- palette_gen(palette, "continuous", direction)
@ -100,15 +115,21 @@ scale_fill_visualizer_continuous <- function(palette = "seq_5_main", direction =
# 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, title_position = NULL, ...) {
scale_color_visualizer_continuous <- function(
palette = "seq_5_main",
direction = 1,
reverse_guide = TRUE,
title_position = NULL,
...
) {
if (!(is.null(palette))) {
pal <- palette_gen(palette, "continuous", direction)
@ -133,6 +154,7 @@ scale_color_visualizer_continuous <- function(palette = "seq_5_main", direction
# ticks.colour = "#F1F3F5",
reverse = reverse_guide
),
....)
....
)
}
}

41
R/theme_bar.R
View file

@ -5,8 +5,13 @@
#' @rdname theme_default
#'
#' @export
theme_bar <- function(flip = TRUE, add_text = FALSE, axis_text_x_angle = 0, axis_text_x_vjust = 0.5, axis_text_x_hjust = 0.5) {
theme_bar <- function(
flip = TRUE,
add_text = FALSE,
axis_text_x_angle = 0,
axis_text_x_vjust = 0.5,
axis_text_x_hjust = 0.5
) {
# If add_text is TRUE, flip is FALSE
if (!flip && !add_text) {
par_axis_text_font_face <- "plain"
@ -68,22 +73,22 @@ theme_bar <- function(flip = TRUE, add_text = FALSE, axis_text_x_angle = 0, axis
# Theme
t <- theme_default(
axis_text_font_face = par_axis_text_font_face
, axis_x = par_axis_x
, axis_y = par_axis_y
, grid_major_y = par_grid_major_y
, grid_major_x = par_grid_major_x
, grid_minor_y = par_grid_minor_y
, grid_minor_x = par_grid_minor_x
, axis_text_y = par_axis_text_y
, axis_line_y = par_axis_line_y
, axis_ticks_y = par_axis_ticks_y
, axis_text_x = par_axis_text_x
, axis_line_x = par_axis_line_x
, axis_ticks_x = par_axis_ticks_x
, axis_text_x_angle = axis_text_x_angle
, axis_text_x_vjust = axis_text_x_vjust
, axis_text_x_hjust = axis_text_x_hjust
axis_text_font_face = par_axis_text_font_face,
axis_x = par_axis_x,
axis_y = par_axis_y,
grid_major_y = par_grid_major_y,
grid_major_x = par_grid_major_x,
grid_minor_y = par_grid_minor_y,
grid_minor_x = par_grid_minor_x,
axis_text_y = par_axis_text_y,
axis_line_y = par_axis_line_y,
axis_ticks_y = par_axis_ticks_y,
axis_text_x = par_axis_text_x,
axis_line_x = par_axis_line_x,
axis_ticks_x = par_axis_ticks_x,
axis_text_x_angle = axis_text_x_angle,
axis_text_x_vjust = axis_text_x_vjust,
axis_text_x_hjust = axis_text_x_hjust
)
return(t)

10
R/theme_default.R
View file

@ -129,11 +129,13 @@ theme_default <- function(
caption_position_to_plot = TRUE,
caption_size = 12,
caption_color = color("dark_grey"),
...) {
...
) {
# Basic simple theme
theme <- ggplot2::theme_minimal()
theme <- theme + ggplot2::theme(
theme <- theme +
ggplot2::theme(
# # Text - design
text = ggplot2::element_text(
family = text_font_family,
@ -362,7 +364,8 @@ theme_default <- function(
}
# Add facet title text size
theme <- theme + ggplot2::theme(
theme <- theme +
ggplot2::theme(
strip.text = ggplot2::element_text(
size = facet_size,
family = facet_font_family,
@ -378,6 +381,5 @@ theme_default <- function(
# Other parameters
theme <- theme + ggplot2::theme(...)
return(theme)
}

4
R/theme_dumbbell.R
View file

@ -8,6 +8,6 @@
theme_dumbbell <- function() {
theme_default(
axis_line_x = TRUE,
grid_)
grid_
)
}

3
R/theme_point.R
View file

@ -10,8 +10,7 @@
#' @return A custom theme object.
#'
#' @export
theme_point <- function(
) {
theme_point <- function() {
t <- theme_default(
axis_text_font_face = "plain",
axis_x = TRUE,