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

622
R/bar.R
View file

@ -1,14 +1,19 @@
#' @rdname bar #' @rdname bar
#' #'
#' @inheritParams bar #' @inheritParams bar
#' #'
#' @export #' @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, ...) bar(flip = flip, add_text = add_text, theme_fun = theme_fun, ...)
} }
#' Simple bar chart #' Simple bar chart
#' #'
#' `bar()` is a simple bar chart with some customization allowed, in particular the `theme_fun` argument for theming. `hbar()` uses `bar()` with sane defaults for a horizontal bar chart. #' `bar()` is a simple bar chart with some customization allowed, in particular the `theme_fun` argument for theming. `hbar()` uses `bar()` with sane defaults for a horizontal bar chart.
#' #'
#' @param df A data frame. #' @param df A data frame.
@ -46,7 +51,7 @@ hbar <- function(..., flip = TRUE, add_text = FALSE, theme_fun = theme_bar(flip
#' @param theme_fun Whatever theme function. For no custom theme, use theme_fun = NULL. #' @param theme_fun Whatever theme function. For no custom theme, use theme_fun = NULL.
#' #'
#' @inheritParams reorder_by #' @inheritParams reorder_by
#' #'
#' @importFrom rlang `:=` #' @importFrom rlang `:=`
#' #'
#' @export #' @export
@ -92,291 +97,347 @@ bar <- function(
), ),
scale_fill_fun = scale_fill_visualizer_discrete(), 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
#------ Checks checkmate::assert_data_frame(df)
# df is a data frame
checkmate::assert_data_frame(df)
# x and y and group are character
checkmate::assert_character(x, len = 1)
checkmate::assert_character(y, len = 1)
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))
# x_rm_na, y_rm_na and group_rm_na are logical scalar
checkmate::assert_logical(x_rm_na, len = 1)
checkmate::assert_logical(y_rm_na, len = 1)
checkmate::assert_logical(group_rm_na, len = 1)
checkmate::assert_logical(facet_rm_na, len = 1)
# flip is a logical scalar
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)
# alpha is a numeric scalar between 0 and 1 # x and y and group are character
checkmate::assert_numeric(alpha, lower = 0, upper = 1, len = 1) checkmate::assert_character(x, len = 1)
checkmate::assert_character(y, len = 1)
# add_text is a logical scalar checkmate::assert_character(group, len = 1)
checkmate::assert_logical(add_text, len = 1)
# add_text_size is a numeric scalar
checkmate::assert_numeric(add_text_size, len = 1)
# add_text_font_face is a character scalar in bold plain or italic
checkmate::assert_choice(add_text_font_face, c("bold", "plain", "italic"))
# add_text_threshold_display is a numeric scalar
checkmate::assert_numeric(add_text_threshold_display, len = 1)
# add_text_suffix is a character scalar
checkmate::assert_character(add_text_suffix, len = 1)
# add_text_expand_limit is a numeric scalar
checkmate::assert_numeric(add_text_expand_limit, len = 1)
# add_text_round is a numeric scalar
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"))
# Check if position is stack or dodge # x and y are columns in df
if (position %notin% c("stack", "dodge")) rlang::abort("Position should be either 'stack' or 'dodge'.") checkmate::assert_choice(x, colnames(df))
checkmate::assert_choice(y, colnames(df))
if (group != "") {
checkmate::assert_choice(group, colnames(df))
}
#----- Data wrangling # x_rm_na, y_rm_na and group_rm_na are logical scalar
checkmate::assert_logical(x_rm_na, len = 1)
# facets over group checkmate::assert_logical(y_rm_na, len = 1)
if (group != "" && facet != "" && group == facet) { checkmate::assert_logical(group_rm_na, len = 1)
rlang::warn("'group' and 'facet' are the same identical.") checkmate::assert_logical(facet_rm_na, len = 1)
}
# remove NAs using base R # flip is a logical scalar
if (x_rm_na) df <- df[!(is.na(df[[x]])),] checkmate::assert_logical(flip, len = 1)
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]])),]
# wrap is a numeric scalar or NULL
# reorder if (!is.null(wrap)) {
dir_order <- if(flip && order %in% c("x", "grouped_x")) { checkmate::assert_numeric(wrap, len = 1, null.ok = TRUE)
-1 }
} else if (!flip && order %in% c("x", "grouped_x")) {
1
} else if (flip) {
1
} else {
-1
}
group_order <- if (group != "" || (group == "" && facet == "")) {
group
} else if (group == "" && facet != "") {
facet
}
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( # alpha is a numeric scalar between 0 and 1
df, checkmate::assert_numeric(alpha, lower = 0, upper = 1, len = 1)
mapping = ggplot2::aes(
x = !!rlang::sym(x), # add_text is a logical scalar
y = !!rlang::sym(y), checkmate::assert_logical(add_text, len = 1)
fill = !!rlang::sym(group),
color = !!rlang::sym(group) # add_text_size is a numeric scalar
) checkmate::assert_numeric(add_text_size, len = 1)
# add_text_font_face is a character scalar in bold plain or italic
checkmate::assert_choice(add_text_font_face, c("bold", "plain", "italic"))
# add_text_threshold_display is a numeric scalar
checkmate::assert_numeric(add_text_threshold_display, len = 1)
# add_text_suffix is a character scalar
checkmate::assert_character(add_text_suffix, len = 1)
# add_text_expand_limit is a numeric scalar
checkmate::assert_numeric(add_text_expand_limit, len = 1)
# add_text_round is a numeric scalar
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"))
}
# 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'.")
}
#----- Data wrangling
# facets over group
if (group != "" && facet != "" && group == facet) {
rlang::warn("'group' and 'facet' are the same identical.")
}
# 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]])), ]
}
# reorder
dir_order <- if (flip && order %in% c("x", "grouped_x")) {
-1
} else if (!flip && order %in% c("x", "grouped_x")) {
1
} else if (flip) {
1
} else {
-1
}
group_order <- if (group != "" || (group == "" && facet == "")) {
group
} else if (group == "" && facet != "") {
facet
}
df <- reorder_by(
df = df,
x = x,
y = y,
group = group_order,
order = order,
dir_order = dir_order
) )
} else { # prepare aes
if (group != "") {
g <- ggplot2::ggplot( g <- ggplot2::ggplot(
df, df,
mapping = ggplot2::aes( mapping = ggplot2::aes(
x = !!rlang::sym(x), x = !!rlang::sym(x),
y = !!rlang::sym(y) 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 # add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs( g <- g +
title = title, ggplot2::labs(
subtitle = subtitle, title = title,
caption = caption, subtitle = subtitle,
x = y_title, caption = caption,
y = x_title, x = y_title,
color = group_title, y = x_title,
fill = group_title color = group_title,
) fill = group_title
)
# width # width
width <- width width <- width
dodge_width <- width dodge_width <- width
# facets # facets
if (facet != "") { if (facet != "") {
if (flip) {
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"
)
}
}
# should the graph use position_fill?
if (group != "") {
if (position == "stack") {
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_stack()
)
} else if (position == "dodge") {
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_dodge2(
width = dodge_width,
preserve = "single"
)
)
} else {
g <- g +
ggplot2::geom_col(
alpha = alpha,
width = width
)
}
} 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::geom_col(
alpha = alpha,
width = width,
fill = add_color,
color = add_color
)
}
}
# wrap labels on the x scale?
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) { if (flip) {
g <- g + ggplot2::facet_grid(rows = ggplot2::vars(!!rlang::sym(facet)), scales = "free", space = "free_y") g <- g + ggplot2::coord_flip()
}
# add text to bars
if (flip) {
hjust_flip <- -0.5
} else { } else {
g <- g + ggplot2::facet_grid(cols = ggplot2::vars(!!rlang::sym(facet)), scales = "free", space = "free_x") hjust_flip <- 0.5
} }
} if (flip) {
vjust_flip <- 0.5
# 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(
alpha = alpha,
width = width,
position = ggplot2::position_stack()
)
} else if (position == "dodge"){
g <- g + ggplot2::geom_col(
alpha = alpha,
width = width,
position = ggplot2::position_dodge2(
width = dodge_width,
preserve = "single")
)
} else{
g <- g + ggplot2::geom_col(
alpha = alpha,
width = width
)
}
} 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 { } else {
g <- g + ggplot2::geom_col( vjust_flip <- -0.5
alpha = alpha,
width = width,
fill = add_color,
color = add_color
)
} }
}
# wrap labels on the x scale? # function for interaction
if (!is.null(wrap)) { interaction_f <- function(group, facet, data) {
g <- g + ggplot2::scale_x_discrete(labels = scales::label_wrap(wrap)) if (group == "" && facet == "") {
} return(NULL)
} else if (group != "" && facet != "") {
return(interaction(data[[group]], data[[facet]]))
# because a text legend should always be horizontal, especially for an horizontal bar graph } else if (group != "") {
if (flip) g <- g + ggplot2::coord_flip() return(data[[group]])
# Add text to bars } else if (facet != "") {
if (flip) hjust_flip <- -0.5 else hjust_flip <- 0.5 return(data[[facet]])
if (flip) vjust_flip <- 0.5 else vjust_flip <- -0.5 } else {
return(NULL)
# Function for interaction }
interaction_f <- function(group, facet, data) {
if (group == "" && facet == "") {
return(NULL)
} else if (group != "" && facet != "") {
return(interaction(data[[group]], data[[facet]]))
} else if (group != "") {
return(data[[group]])
} else if (facet != "") {
return(data[[facet]])
} else {
return(NULL)
} }
}
# add text labels
# add text labels if (add_text & position == "dodge") {
if (add_text & position == "dodge") { df <- dplyr::mutate(
df,
df <- dplyr::mutate(df, "y_threshold" := ifelse(!!rlang::sym(y) >= add_text_threshold_display, !!rlang::sym(y), NA )) "y_threshold" := ifelse(
!!rlang::sym(y) >= add_text_threshold_display,
# expand limits !!rlang::sym(y),
g <- g + ggplot2::geom_blank( NA
data = df, )
ggplot2::aes(
x = !!rlang::sym(x),
y = !!rlang::sym(y) * add_text_expand_limit,
group = interaction_f(group, facet, df)
)
)
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)
) )
# expand limits
g <- g +
ggplot2::geom_blank(
data = df,
ggplot2::aes(
x = !!rlang::sym(x),
y = !!rlang::sym(y) * add_text_expand_limit,
group = interaction_f(group, facet, df)
)
)
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)
)
} else if (add_text & position == "stack") { } else if (add_text & position == "stack") {
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 )) g <- g +
ggplot2::geom_text(
g <- g + ggplot2::geom_text( data = df,
data = df, ggplot2::aes(
ggplot2::aes( label = ifelse(
label = ifelse(is.na(!!rlang::sym("y_threshold")), NA, is.na(!!rlang::sym("y_threshold")),
paste0(round(!!rlang::sym("y_threshold"), add_text_round), add_text_suffix)), NA,
group = interaction_f(group, facet, df) paste0(
), round(!!rlang::sym("y_threshold"), add_text_round),
hjust = hjust_flip, add_text_suffix
vjust = vjust_flip, )
color = add_text_color, ),
fontface = add_text_font_face, group = interaction_f(group, facet, df)
size = add_text_size, ),
position = ggplot2::position_dodge2(width = dodge_width) 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 # y scale tweaks
@ -385,23 +446,32 @@ if (add_text & position == "dodge") {
# start at 0 # start at 0
expand = ggplot2::expansion(mult = c(0, y_expand)), expand = ggplot2::expansion(mult = c(0, y_expand)),
# remove trailing 0 and choose accuracy of y labels # remove trailing 0 and choose accuracy of y labels
labels = scales::label_number( labels = scales::label_number(
accuracy = 0.1, accuracy = 0.1,
drop0trailing = TRUE, drop0trailing = TRUE,
big.mark = "", big.mark = "",
decimal.mark = "."), decimal.mark = "."
) ),
)
# Remove guides for legend if !add_color_guide # # 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 fun # # add theme fun
if (!is.null(theme_fun)) g <- g + theme_fun if (!is.null(theme_fun)) {
g <- g + theme_fun
}
# Add scale 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) 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)) vars_nin <- setdiff(vars, colnames(df))
if (length(vars_nin) > 0) { 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."
))
} }
} }

122
R/color.R
View file

@ -16,7 +16,6 @@
#' #'
#' @export #' @export
color <- function(..., unname = TRUE) { color <- function(..., unname = TRUE) {
#------ Prep #------ Prep
# Retrieve colors # Retrieve colors
@ -24,63 +23,62 @@ color <- function(..., unname = TRUE) {
# Defined colors # Defined colors
colors <- c( colors <- c(
white = "#FFFFFF" white = "#FFFFFF",
, lighter_grey = "#F5F5F5" lighter_grey = "#F5F5F5",
, light_grey = "#E3E3E3" light_grey = "#E3E3E3",
, dark_grey = "#464647" dark_grey = "#464647",
, light_blue_grey = "#B3C6D1" light_blue_grey = "#B3C6D1",
, grey = "#71716F" grey = "#71716F",
, black = "#000000" black = "#000000",
, cat_2_yellow_1 = "#ffc20a" cat_2_yellow_1 = "#ffc20a",
, cat_2_yellow_2 = "#0c7bdc" cat_2_yellow_2 = "#0c7bdc",
, cat_2_light_1 = "#fefe62" cat_2_light_1 = "#fefe62",
, cat_2_light_2 = "#d35fb7" cat_2_light_2 = "#d35fb7",
, cat_2_green_1 = "#1aff1a" cat_2_green_1 = "#1aff1a",
, cat_2_green_2 = "#4b0092" cat_2_green_2 = "#4b0092",
, cat_2_blue_1 = "#1a85ff" cat_2_blue_1 = "#1a85ff",
, cat_2_blue_2 = "#d41159" cat_2_blue_2 = "#d41159",
, cat_5_main_1 = "#083d77" # yale blue cat_5_main_1 = "#083d77", # yale blue
, cat_5_main_2 = "#4ecdc4" # robin egg blue cat_5_main_2 = "#4ecdc4", # robin egg blue
, cat_5_main_3 = "#f4c095" # peach cat_5_main_3 = "#f4c095", # peach
, cat_5_main_4 = "#b47eb3" # african violet cat_5_main_4 = "#b47eb3", # african violet
, cat_5_main_5 = "#ffd5ff" # mimi pink cat_5_main_5 = "#ffd5ff", # mimi pink
, seq_5_main_1 = "#083d77" # yale blue seq_5_main_1 = "#083d77", # yale blue
, seq_5_main_2 = "##396492" seq_5_main_2 = "##396492",
, seq_5_main_3 = "#6b8bad" seq_5_main_3 = "#6b8bad",
, seq_5_main_4 = "#9cb1c9" seq_5_main_4 = "#9cb1c9",
, seq_5_main_5 = "#ced8e4" seq_5_main_5 = "#ced8e4",
, cat_5_ibm_1 = "#648fff" cat_5_ibm_1 = "#648fff",
, cat_5_ibm_2 = "#785ef0" cat_5_ibm_2 = "#785ef0",
, cat_5_ibm_3 = "#dc267f" cat_5_ibm_3 = "#dc267f",
, cat_5_ibm_4 = "#fe6100" cat_5_ibm_4 = "#fe6100",
, cat_5_ibm_5 = "#ffb000" cat_5_ibm_5 = "#ffb000",
, cat_3_aquamarine_1 = "aquamarine2" cat_3_aquamarine_1 = "aquamarine2",
, cat_3_aquamarine_2 = "cornflowerblue" cat_3_aquamarine_2 = "cornflowerblue",
, cat_3_aquamarine_3 = "brown1" cat_3_aquamarine_3 = "brown1",
, cat_3_tol_high_contrast_1 = "#215589" cat_3_tol_high_contrast_1 = "#215589",
, cat_3_tol_high_contrast_2 = "#cfaa34" cat_3_tol_high_contrast_2 = "#cfaa34",
, cat_3_tol_high_contrast_3 = "#a35364" cat_3_tol_high_contrast_3 = "#a35364",
, cat_8_tol_adapted_1 = "#332e86" cat_8_tol_adapted_1 = "#332e86",
, cat_8_tol_adapted_2 = "#50504f" cat_8_tol_adapted_2 = "#50504f",
, cat_8_tol_adapted_3 = "#3dab9a" cat_8_tol_adapted_3 = "#3dab9a",
, cat_8_tol_adapted_4 = "#86ccee" cat_8_tol_adapted_4 = "#86ccee",
, cat_8_tol_adapted_5 = "#ddcb77" cat_8_tol_adapted_5 = "#ddcb77",
, cat_8_tol_adapted_6 = "#ee5859" cat_8_tol_adapted_6 = "#ee5859",
, cat_8_tol_adapted_7 = "#aa4599" cat_8_tol_adapted_7 = "#aa4599",
, cat_8_tol_adapted_8 = "#721220" cat_8_tol_adapted_8 = "#721220",
, div_5_orange_blue_1 = "#c85200" div_5_orange_blue_1 = "#c85200",
, div_5_orange_blue_2 = "#e48646" div_5_orange_blue_2 = "#e48646",
, div_5_orange_blue_3 = "#cccccc" div_5_orange_blue_3 = "#cccccc",
, div_5_orange_blue_4 = "#6b8ea4" div_5_orange_blue_4 = "#6b8ea4",
, div_5_orange_blue_5 = "#366785" div_5_orange_blue_5 = "#366785",
, div_5_green_purple_1 = "#c85200" div_5_green_purple_1 = "#c85200",
, div_5_green_purple_2 = "#e48646" div_5_green_purple_2 = "#e48646",
, div_5_green_purple_3 = "#cccccc" div_5_green_purple_3 = "#cccccc",
, div_5_green_purple_4 = "#6b8ea4" div_5_green_purple_4 = "#6b8ea4",
, div_5_green_purple_5 = "#366785" div_5_green_purple_5 = "#366785"
) )
#------ Checks #------ Checks
# Check that if ... is not null, all colors are defined # Check that if ... is not null, all colors are defined
@ -88,10 +86,13 @@ color <- function(..., unname = TRUE) {
if (cols %notallin% names(colors)) { if (cols %notallin% names(colors)) {
rlang::abort(c( rlang::abort(c(
"Some colors not defined", "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." "i" = "Use `color(unname = FALSE)` to see all named available colors."
) ))
)
} }
} }
@ -115,8 +116,7 @@ color <- function(..., unname = TRUE) {
#' @param pattern Pattern of the start of colors' name. #' @param pattern Pattern of the start of colors' name.
#' #'
#' @export #' @export
color_pattern <- function(pattern, unname = TRUE){ color_pattern <- function(pattern, unname = TRUE) {
#------ Checks #------ Checks
# Check that pattern is a character scalar # Check that pattern is a character scalar

140
R/dumbbell.R
View file

@ -29,32 +29,33 @@
#' @return A dumbbell chart. #' @return A dumbbell chart.
#' @export #' @export
#' #'
dumbbell <- function(df, dumbbell <- function(
col, df,
group_x, col,
group_y, group_x,
point_size = 5, group_y,
point_alpha = 1, point_size = 5,
segment_size = 2.5, point_alpha = 1,
segment_color = color("light_blue_grey"), segment_size = 2.5,
group_x_title = NULL, segment_color = color("light_blue_grey"),
group_y_title = NULL, group_x_title = NULL,
x_title = NULL, group_y_title = NULL,
title = NULL, x_title = NULL,
subtitle = NULL, title = NULL,
caption = NULL, subtitle = NULL,
line_to_y_axis = FALSE, caption = NULL,
line_to_y_axis_type = 3, line_to_y_axis = FALSE,
line_to_y_axis_width = 0.5, line_to_y_axis_type = 3,
line_to_y_axis_color = color("dark_grey"), line_to_y_axis_width = 0.5,
add_text = FALSE, line_to_y_axis_color = color("dark_grey"),
add_text_vjust = 2, add_text = FALSE,
add_text_size = 3.5, add_text_vjust = 2,
add_text_color = color("dark_grey"), add_text_size = 3.5,
theme_fun = theme_dumbbell(), add_text_color = color("dark_grey"),
scale_fill_fun = scale_fill_visualizer_discrete(), theme_fun = theme_dumbbell(),
scale_color_fun = scale_color_visualizer_discrete()){ scale_fill_fun = scale_fill_visualizer_discrete(),
scale_color_fun = scale_color_visualizer_discrete()
) {
#------ Checks #------ Checks
# df is a data frame # df is a data frame
@ -88,7 +89,11 @@ dumbbell <- function(df,
dplyr::pull() dplyr::pull()
# Check if only two groups # 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 # Pivot long data
df_pivot <- df |> df_pivot <- df |>
@ -101,16 +106,24 @@ dumbbell <- function(df,
df_pivot <- df_pivot |> df_pivot <- df_pivot |>
dplyr::rowwise() |> dplyr::rowwise() |>
dplyr::mutate( dplyr::mutate(
min = min(!!rlang::sym(group_x_keys[[1]]), !!rlang::sym(group_x_keys[[2]]), na.rm = T), min = min(
max = max(!!rlang::sym(group_x_keys[[1]]), !!rlang::sym(group_x_keys[[2]]), na.rm = T)) |> !!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::ungroup() |>
dplyr::mutate(diff = max - min) dplyr::mutate(diff = max - min)
g <- ggplot2::ggplot(df_pivot) g <- ggplot2::ggplot(df_pivot)
# Add line # Add line
if(line_to_y_axis) { if (line_to_y_axis) {
xend <- min(dplyr::pull(df, !!rlang::sym(col))) xend <- min(dplyr::pull(df, !!rlang::sym(col)))
g <- g + g <- g +
@ -118,21 +131,24 @@ dumbbell <- function(df,
ggplot2::aes( ggplot2::aes(
x = min, x = min,
y = !!rlang::sym(group_y), y = !!rlang::sym(group_y),
yend = !!rlang::sym(group_y)), yend = !!rlang::sym(group_y)
),
xend = xend, xend = xend,
linetype = line_to_y_axis_type, linetype = line_to_y_axis_type,
linewidth = line_to_y_axis_width, linewidth = line_to_y_axis_width,
color = line_to_y_axis_color) color = line_to_y_axis_color
)
} }
# Add segment # Add segment
g <- g + g <- g +
ggplot2::geom_segment( ggplot2::geom_segment(
ggplot2::aes( ggplot2::aes(
x = !!rlang::sym(group_x_keys[[1]]), x = !!rlang::sym(group_x_keys[[1]]),
y = !!rlang::sym(group_y), y = !!rlang::sym(group_y),
xend = !!rlang::sym(group_x_keys[[2]]), xend = !!rlang::sym(group_x_keys[[2]]),
yend = !!rlang::sym(group_y)), yend = !!rlang::sym(group_y)
),
linewidth = segment_size, linewidth = segment_size,
color = segment_color color = segment_color
) )
@ -152,38 +168,44 @@ dumbbell <- function(df,
) )
# Add title, subtitle, caption, x_title, y_title # Add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs( g <- g +
title = title, ggplot2::labs(
subtitle = subtitle, title = title,
caption = caption, subtitle = subtitle,
x = x_title, caption = caption,
y = group_y_title, x = x_title,
color = group_x_title, y = group_y_title,
fill = group_x_title color = group_x_title,
) fill = group_x_title
)
# Add stat labels to points # Add stat labels to points
if(add_text) g <- g + if (add_text) {
ggrepel::geom_text_repel( g <- g +
data = df, ggrepel::geom_text_repel(
ggplot2::aes( data = df,
x = !!rlang::sym(col), ggplot2::aes(
y = !!rlang::sym(group_y), x = !!rlang::sym(col),
label = !!rlang::sym(col) y = !!rlang::sym(group_y),
), label = !!rlang::sym(col)
vjust = add_text_vjust, ),
size = add_text_size, vjust = add_text_vjust,
color = add_text_color size = add_text_size,
) color = add_text_color
)
}
# Add theme # Add theme
g <- g + theme_fun g <- g + theme_fun
# Add scale 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) return(g)
} }

53
R/palette.R
View file

@ -8,8 +8,12 @@
#' @return A color palette #' @return A color palette
#' #'
#' @export #' @export
palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FALSE, ...) { palette <- function(
palette = "cat_5_main",
reverse = FALSE,
show_palettes = FALSE,
...
) {
#------ Checks #------ Checks
# Check that palette is a character scalar # Check that palette is a character scalar
@ -25,21 +29,28 @@ palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FAL
# Define palettes # Define palettes
pals <- list( pals <- list(
cat_2_yellow = color_pattern("cat_2_yellow") cat_2_yellow = color_pattern("cat_2_yellow"),
, cat_2_light = color_pattern("cat_2_light") cat_2_light = color_pattern("cat_2_light"),
, cat_2_green = color_pattern("cat_2_green") cat_2_green = color_pattern("cat_2_green"),
, cat_2_blue = color_pattern("cat_2_blue") cat_2_blue = color_pattern("cat_2_blue"),
, cat_5_main = color_pattern("cat_5_main") cat_5_main = color_pattern("cat_5_main"),
, cat_5_ibm = color_pattern("cat_5_ibm") cat_5_ibm = color_pattern("cat_5_ibm"),
, cat_3_aquamarine = color_pattern("cat_3_aquamarine") cat_3_aquamarine = color_pattern("cat_3_aquamarine"),
, cat_3_tol_high_contrast = color_pattern("cat_3_tol_high_contrast") cat_3_tol_high_contrast = color_pattern("cat_3_tol_high_contrast"),
, cat_8_tol_adapted = color_pattern("cat_8_tol_adapted") cat_8_tol_adapted = color_pattern("cat_8_tol_adapted"),
, cat_3_custom_1 = c("#003F5C", "#58508D", "#FFA600") cat_3_custom_1 = c("#003F5C", "#58508D", "#FFA600"),
, cat_4_custom_1 = c("#003F5C", "#7a5195", "#ef5675", "#ffa600") cat_4_custom_1 = c("#003F5C", "#7a5195", "#ef5675", "#ffa600"),
, cat_5_custom_1 = c("#003F5C", "#58508d", "#bc5090", "#ff6361", "#ffa600") cat_5_custom_1 = c("#003F5C", "#58508d", "#bc5090", "#ff6361", "#ffa600"),
, cat_6_custom_1 = c("#003F5C", "#444e86", "#955196", "#dd5182", "#ff6e54", "#ffa600") cat_6_custom_1 = c(
, div_5_orange_blue = color_pattern("div_5_orange_blue") "#003F5C",
, div_5_green_purple = color_pattern("div_5_green_purple") "#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 # Return if show palettes
@ -51,7 +62,9 @@ palette <- function(palette = "cat_5_main", reverse = FALSE, show_palettes = FAL
if (palette %notin% names(pals)) { if (palette %notin% names(pals)) {
rlang::abort(c( rlang::abort(c(
"Palette not defined", "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." "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]] pal <- pals[[palette]]
if (reverse) pal <- rev(pal) if (reverse) {
pal <- rev(pal)
}
return(pal) return(pal)
} }

29
R/palette_gen.R
View file

@ -9,15 +9,20 @@
#' #'
#' @export #' @export
palette_gen <- function(palette, type, direction = 1, ...) { palette_gen <- function(palette, type, direction = 1, ...) {
if (type %notin% c("categorical", "sequential", "divergent")) {
if (type %notin% c("categorical", "sequential", "divergent")) rlang::abort("'type' must be categorical or continuous or divergent.") rlang::abort("'type' must be categorical or continuous or divergent.")
}
if (type == "categorical") { if (type == "categorical") {
return(palette_gen_categorical(palette = palette, direction = direction)) return(palette_gen_categorical(palette = palette, direction = direction))
} }
if (type %in% c("sequential", "divergent")) { 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 #' @export
palette_gen_categorical <- function(palette = "cat_5_main", direction = 1) { palette_gen_categorical <- function(palette = "cat_5_main", direction = 1) {
if (abs(direction) != 1) {
if (abs(direction) != 1) rlang::abort("Direction must be either 1 or -1.") rlang::abort("Direction must be either 1 or -1.")
}
pal <- palette(palette) pal <- palette(palette)
f <- function(n) { 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) pal <- if (direction == 1) pal else rev(pal)
@ -50,8 +60,9 @@ palette_gen_categorical <- function(palette = "cat_5_main", direction = 1) {
#' #'
#' @export #' @export
palette_gen_sequential <- function(palette = "seq_5_main", direction = 1, ...) { palette_gen_sequential <- function(palette = "seq_5_main", direction = 1, ...) {
if (abs(direction) != 1) {
if (abs(direction) != 1) rlang::abort("Direction must be either 1 or -1.") rlang::abort("Direction must be either 1 or -1.")
}
pal <- palette(palette) pal <- palette(palette)

171
R/point.R
View file

@ -52,22 +52,23 @@ point <- function(
scale_fill_fun = scale_fill_visualizer_discrete(), scale_fill_fun = scale_fill_visualizer_discrete(),
scale_color_fun = scale_color_visualizer_discrete() scale_color_fun = scale_color_visualizer_discrete()
) { ) {
#------ Checks #------ Checks
# df is a data frame # df is a data frame
checkmate::assert_data_frame(df) checkmate::assert_data_frame(df)
# x and y and group are character # x and y and group are character
checkmate::assert_character(x, len = 1) checkmate::assert_character(x, len = 1)
checkmate::assert_character(y, len = 1) checkmate::assert_character(y, len = 1)
checkmate::assert_character(group, len = 1) checkmate::assert_character(group, len = 1)
# x and y are columns in df # x and y are columns in df
checkmate::assert_choice(x, colnames(df)) checkmate::assert_choice(x, colnames(df))
checkmate::assert_choice(y, 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 # x_rm_na, y_rm_na and group_rm_na are logical scalar
checkmate::assert_logical(x_rm_na, len = 1) checkmate::assert_logical(x_rm_na, len = 1)
checkmate::assert_logical(y_rm_na, len = 1) checkmate::assert_logical(y_rm_na, len = 1)
@ -76,57 +77,69 @@ point <- function(
# facet_scales is a character scalar in c("free", "fixed") # facet_scales is a character scalar in c("free", "fixed")
checkmate::assert_choice(facet_scales, c("free", "fixed")) checkmate::assert_choice(facet_scales, c("free", "fixed"))
# flip is a logical scalar # flip is a logical scalar
checkmate::assert_logical(flip, len = 1) checkmate::assert_logical(flip, len = 1)
# alpha is a numeric scalar between 0 and 1 # alpha is a numeric scalar between 0 and 1
checkmate::assert_numeric(alpha, lower = 0, upper = 1, len = 1) checkmate::assert_numeric(alpha, lower = 0, upper = 1, len = 1)
# size is a numeric scalar # size is a numeric scalar
checkmate::assert_numeric(size, len = 1) checkmate::assert_numeric(size, len = 1)
# x and y are numeric # 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[[x]]))) {
if (!any(c("numeric", "integer") %in% class(df[[y]]))) rlang::abort(paste0(y, " must be numeric.")) 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 #----- Data wrangling
# facets over group # facets over group
if (group != "" && facet != "" && group == facet) { if (group != "" && facet != "" && group == facet) {
rlang::warn("'group' and 'facet' are the same identical.") rlang::warn("'group' and 'facet' are the same identical.")
} }
# remove NAs using base R # remove NAs using base R
if (x_rm_na) df <- df[!(is.na(df[[x]])),] if (x_rm_na) {
if (y_rm_na) df <- df[!(is.na(df[[y]])),] df <- df[!(is.na(df[[x]])), ]
if (group != "" && group_rm_na) df <- df[!(is.na(df[[group]])),] }
if (facet != "" && facet_rm_na) df <- df[!(is.na(df[[facet]])),] 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 # prepare aes
if (group != "") { if (group != "") {
g <- ggplot2::ggplot( g <- ggplot2::ggplot(
df, df,
mapping = ggplot2::aes( mapping = ggplot2::aes(
x = !!rlang::sym(x), x = !!rlang::sym(x),
y = !!rlang::sym(y), y = !!rlang::sym(y),
fill = !!rlang::sym(group), fill = !!rlang::sym(group),
color = !!rlang::sym(group) color = !!rlang::sym(group)
)
) )
)
} else { } else {
g <- ggplot2::ggplot( g <- ggplot2::ggplot(
df, df,
mapping = ggplot2::aes( mapping = ggplot2::aes(
x = !!rlang::sym(x), x = !!rlang::sym(x),
y = !!rlang::sym(y) y = !!rlang::sym(y)
)
) )
)
} }
# add title, subtitle, caption, x_title, y_title # add title, subtitle, caption, x_title, y_title
g <- g + ggplot2::labs( g <- g +
ggplot2::labs(
title = title, title = title,
subtitle = subtitle, subtitle = subtitle,
caption = caption, caption = caption,
@ -134,54 +147,66 @@ point <- function(
y = y_title, y = y_title,
color = group_title, color = group_title,
fill = group_title fill = group_title
) )
# facets # facets
# facets # facets
if (facet != "") { if (facet != "") {
if (flip) { if (flip) {
g <- g + ggplot2::facet_grid( g <- g +
rows = ggplot2::vars(!!rlang::sym(facet)), ggplot2::facet_grid(
scales = facet_scales, rows = ggplot2::vars(!!rlang::sym(facet)),
space = if(facet_scales == "free") "free_y" else "fixed" scales = facet_scales,
) space = if (facet_scales == "free") "free_y" else "fixed"
} else { )
g <- g + ggplot2::facet_grid( } else {
cols = ggplot2::vars(!!rlang::sym(facet)), g <- g +
scales = facet_scales, ggplot2::facet_grid(
space = if(facet_scales == "free") "free_x" else "fixed" cols = ggplot2::vars(!!rlang::sym(facet)),
) scales = facet_scales,
space = if (facet_scales == "free") "free_x" else "fixed"
)
}
} }
}
# Should the graph use position_fill? # Should the graph use position_fill?
if (group != "") { if (group != "") {
g <- g + ggplot2::geom_point( g <- g +
alpha = alpha, ggplot2::geom_point(
size = size alpha = alpha,
size = size
) )
} else { } else {
g <- g + ggplot2::geom_point( g <- g +
alpha = alpha, ggplot2::geom_point(
size = size, alpha = alpha,
color = add_color size = size,
color = add_color
) )
} }
if (flip) { if (flip) {
g <- g + ggplot2::coord_flip() g <- g + ggplot2::coord_flip()
} }
# Remove guides for legend if !add_color_guide # 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 # Add theme
if (!is.null(theme_fun)) g <- g + theme_fun if (!is.null(theme_fun)) {
g <- g + theme_fun
}
# Add scale 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) return(g)
} }

23
R/reorder_by.R
View file

@ -1,31 +1,30 @@
#' Reorder a Data Frame #' Reorder a Data Frame
#' #'
#' @param df A data frame to be reordered. #' @param df A data frame to be reordered.
#' @param x A character scalar specifying the column to be reordered. #' @param x A character scalar specifying the column to be reordered.
#' @param y A character scalar specifying the column to order by if ordering by values. #' @param y A character scalar specifying the column to order by if ordering by values.
#' @param group A character scalar specifying the grouping column (optional). #' @param group A character scalar specifying the grouping column (optional).
#' @param order A character scalar specifying the order type (one of "none", "y", "grouped"). See details. #' @param order A character scalar specifying the order type (one of "none", "y", "grouped"). See details.
#' @param dir_order A logical scalar specifying whether to flip the order. #' @param dir_order A logical scalar specifying whether to flip the order.
#' #'
#' @details Ordering takes the following possible values: #' @details Ordering takes the following possible values:
#' #'
#' * "none": No reordering. #' * "none": No reordering.
#' * "y": Order by values of y. #' * "y": Order by values of y.
#' * "grouped_y": Order by values of y and group. #' * "grouped_y": Order by values of y and group.
#' * "x": Order alphabetically by x. #' * "x": Order alphabetically by x.
#' * "grouped_x": Order alphabetically by x and group. #' * "grouped_x": Order alphabetically by x and group.
#' #'
#' #'
#' @return The reordered data frame. #' @return The reordered data frame.
#' #'
#' @examples #' @examples
#' # Example usage #' # Example usage
#' df <- data.frame(col1 = c("b", "a", "c"), col2 = c(10, 25, 3)) #' df <- data.frame(col1 = c("b", "a", "c"), col2 = c(10, 25, 3))
#' reorder_by(df, "col1", "col2") #' reorder_by(df, "col1", "col2")
#' #'
#' @export #' @export
reorder_by <- function(df, x, y, group = "", order = "y", dir_order = 1){ reorder_by <- function(df, x, y, group = "", order = "y", dir_order = 1) {
#------ Checks #------ Checks
# df is a data frame # df is a data frame
@ -39,15 +38,17 @@ reorder_by <- function(df, x, y, group = "", order = "y", dir_order = 1){
# group is character scalar and in df if not empty # group is character scalar and in df if not empty
checkmate::assert_character(group, len = 1) 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") # order is a character scalar in c("none", "y", "grouped")
checkmate::assert_choice(order, c("none", "y", "grouped_y", "x", "grouped_x")) checkmate::assert_choice(order, c("none", "y", "grouped_y", "x", "grouped_x"))
# dir_order is 1 or -1 (numeric scalar) # dir_order is 1 or -1 (numeric scalar)
checkmate::assert_subset(dir_order, c(1, -1)) checkmate::assert_subset(dir_order, c(1, -1))
#------ Reorder #------ Reorder
# droplevels first # droplevels first
if (is.factor(df[[x]])) { if (is.factor(df[[x]])) {

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

49
R/theme_bar.R
View file

@ -5,10 +5,15 @@
#' @rdname theme_default #' @rdname theme_default
#' #'
#' @export #' @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 add_text is TRUE, flip is FALSE
if (!flip && !add_text){ if (!flip && !add_text) {
par_axis_text_font_face <- "plain" par_axis_text_font_face <- "plain"
par_axis_x <- TRUE par_axis_x <- TRUE
par_axis_y <- TRUE par_axis_y <- TRUE
@ -22,7 +27,7 @@ theme_bar <- function(flip = TRUE, add_text = FALSE, axis_text_x_angle = 0, axis
par_grid_major_x <- FALSE par_grid_major_x <- FALSE
par_grid_minor_y <- TRUE par_grid_minor_y <- TRUE
par_grid_minor_x <- FALSE par_grid_minor_x <- FALSE
} else if (flip && !add_text){ } else if (flip && !add_text) {
par_axis_text_font_face <- "plain" par_axis_text_font_face <- "plain"
par_axis_x <- TRUE par_axis_x <- TRUE
par_axis_y <- TRUE par_axis_y <- TRUE
@ -36,7 +41,7 @@ theme_bar <- function(flip = TRUE, add_text = FALSE, axis_text_x_angle = 0, axis
par_grid_major_x <- TRUE par_grid_major_x <- TRUE
par_grid_minor_y <- FALSE par_grid_minor_y <- FALSE
par_grid_minor_x <- TRUE par_grid_minor_x <- TRUE
} else if (!flip && add_text){ } else if (!flip && add_text) {
par_axis_text_font_face <- "bold" par_axis_text_font_face <- "bold"
par_axis_x <- TRUE par_axis_x <- TRUE
par_axis_y <- TRUE par_axis_y <- TRUE
@ -50,7 +55,7 @@ theme_bar <- function(flip = TRUE, add_text = FALSE, axis_text_x_angle = 0, axis
par_grid_major_x <- FALSE par_grid_major_x <- FALSE
par_grid_minor_y <- FALSE par_grid_minor_y <- FALSE
par_grid_minor_x <- FALSE par_grid_minor_x <- FALSE
} else if (flip && add_text){ } else if (flip && add_text) {
par_axis_text_font_face <- "bold" par_axis_text_font_face <- "bold"
par_axis_x <- TRUE par_axis_x <- TRUE
par_axis_y <- TRUE par_axis_y <- TRUE
@ -68,22 +73,22 @@ theme_bar <- function(flip = TRUE, add_text = FALSE, axis_text_x_angle = 0, axis
# Theme # Theme
t <- theme_default( t <- theme_default(
axis_text_font_face = par_axis_text_font_face axis_text_font_face = par_axis_text_font_face,
, axis_x = par_axis_x axis_x = par_axis_x,
, axis_y = par_axis_y axis_y = par_axis_y,
, grid_major_y = par_grid_major_y grid_major_y = par_grid_major_y,
, grid_major_x = par_grid_major_x grid_major_x = par_grid_major_x,
, grid_minor_y = par_grid_minor_y grid_minor_y = par_grid_minor_y,
, grid_minor_x = par_grid_minor_x grid_minor_x = par_grid_minor_x,
, axis_text_y = par_axis_text_y axis_text_y = par_axis_text_y,
, axis_line_y = par_axis_line_y axis_line_y = par_axis_line_y,
, axis_ticks_y = par_axis_ticks_y axis_ticks_y = par_axis_ticks_y,
, axis_text_x = par_axis_text_x axis_text_x = par_axis_text_x,
, axis_line_x = par_axis_line_x axis_line_x = par_axis_line_x,
, axis_ticks_x = par_axis_ticks_x axis_ticks_x = par_axis_ticks_x,
, axis_text_x_angle = axis_text_x_angle axis_text_x_angle = axis_text_x_angle,
, axis_text_x_vjust = axis_text_x_vjust axis_text_x_vjust = axis_text_x_vjust,
, axis_text_x_hjust = axis_text_x_hjust axis_text_x_hjust = axis_text_x_hjust
) )
return(t) return(t)

164
R/theme_default.R
View file

@ -129,78 +129,80 @@ theme_default <- function(
caption_position_to_plot = TRUE, caption_position_to_plot = TRUE,
caption_size = 12, caption_size = 12,
caption_color = color("dark_grey"), caption_color = color("dark_grey"),
...) { ...
) {
# Basic simple theme # Basic simple theme
theme <- ggplot2::theme_minimal() theme <- ggplot2::theme_minimal()
theme <- theme + ggplot2::theme( theme <- theme +
# # Text - design ggplot2::theme(
text = ggplot2::element_text( # # Text - design
family = text_font_family, text = ggplot2::element_text(
color = text_color, family = text_font_family,
size = text_size, color = text_color,
face = text_font_face size = text_size,
), face = text_font_face
# Default legend to right position ),
legend.position = legend_position, # Default legend to right position
# Defaut legend to vertical direction legend.position = legend_position,
legend.direction = legend_direction, # Defaut legend to vertical direction
# Text sizes legend.direction = legend_direction,
axis.text = ggplot2::element_text( # Text sizes
size = axis_text_size, axis.text = ggplot2::element_text(
family = axis_text_font_family, size = axis_text_size,
face = axis_text_font_face, family = axis_text_font_family,
color = axis_text_color face = axis_text_font_face,
), color = axis_text_color
axis.title = ggplot2::element_text( ),
size = axis_title_size, axis.title = ggplot2::element_text(
family = axis_text_font_family, size = axis_title_size,
face = axis_title_font_face, family = axis_text_font_family,
color = axis_title_color face = axis_title_font_face,
), color = axis_title_color
# # Wrap title ),
plot.title = ggtext::element_textbox_simple( # # Wrap title
hjust = title_hjust, plot.title = ggtext::element_textbox_simple(
family = title_font_family, hjust = title_hjust,
color = title_color, family = title_font_family,
size = title_size, color = title_color,
face = title_font_face, size = title_size,
width = grid::unit(0.9, "npc"), face = title_font_face,
margin = ggplot2::margin(b = 10) width = grid::unit(0.9, "npc"),
), margin = ggplot2::margin(b = 10)
plot.subtitle = ggtext::element_textbox_simple( ),
hjust = title_hjust, plot.subtitle = ggtext::element_textbox_simple(
family = subtitle_font_family, hjust = title_hjust,
color = subtitle_color, family = subtitle_font_family,
size = subtitle_size, color = subtitle_color,
face = subtitle_font_face, size = subtitle_size,
margin = ggplot2::margin(t = 5, b = 10) face = subtitle_font_face,
), margin = ggplot2::margin(t = 5, b = 10)
plot.caption = ggtext::element_textbox_simple( ),
size = caption_size, plot.caption = ggtext::element_textbox_simple(
face = caption_font_face, size = caption_size,
family = caption_font_family, face = caption_font_face,
color = caption_color, family = caption_font_family,
margin = ggplot2::margin(t = 10) color = caption_color,
), margin = ggplot2::margin(t = 10)
legend.title = ggplot2::element_text( ),
size = legend_title_size, legend.title = ggplot2::element_text(
face = legend_title_font_face, size = legend_title_size,
family = legend_title_font_family, face = legend_title_font_face,
color = legend_title_color family = legend_title_font_family,
), color = legend_title_color
legend.text = ggplot2::element_text( ),
size = legend_text_size, legend.text = ggplot2::element_text(
face = legend_text_font_face, size = legend_text_size,
family = legend_text_font_family, face = legend_text_font_face,
color = legend_text_color family = legend_text_font_family,
), color = legend_text_color
axis.text.x = ggplot2::element_text( ),
angle = axis_text_x_angle, axis.text.x = ggplot2::element_text(
vjust = axis_text_x_vjust, angle = axis_text_x_angle,
hjust = axis_text_x_hjust vjust = axis_text_x_vjust,
hjust = axis_text_x_hjust
)
) )
)
# Position of title # Position of title
if (title_position_to_plot) { if (title_position_to_plot) {
@ -362,22 +364,22 @@ theme_default <- function(
} }
# Add facet title text size # Add facet title text size
theme <- theme + ggplot2::theme( theme <- theme +
strip.text = ggplot2::element_text( ggplot2::theme(
size = facet_size, strip.text = ggplot2::element_text(
family = facet_font_family, size = facet_size,
face = facet_font_face, family = facet_font_family,
color = facet_color face = facet_font_face,
), color = facet_color
strip.background = ggplot2::element_rect( ),
fill = facet_bg_color, strip.background = ggplot2::element_rect(
linewidth = 0 fill = facet_bg_color,
linewidth = 0
)
) )
)
# Other parameters # Other parameters
theme <- theme + ggplot2::theme(...) theme <- theme + ggplot2::theme(...)
return(theme) return(theme)
} }

4
R/theme_dumbbell.R
View file

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

29
R/theme_point.R
View file

@ -10,22 +10,21 @@
#' @return A custom theme object. #' @return A custom theme object.
#' #'
#' @export #' @export
theme_point <- function( theme_point <- function() {
) {
t <- theme_default( t <- theme_default(
axis_text_font_face = "plain", axis_text_font_face = "plain",
axis_x = TRUE, axis_x = TRUE,
axis_y = TRUE, axis_y = TRUE,
grid_major_y = TRUE, grid_major_y = TRUE,
grid_major_x = TRUE, grid_major_x = TRUE,
grid_minor_y = FALSE, grid_minor_y = FALSE,
grid_minor_x = FALSE, grid_minor_x = FALSE,
axis_text_x = TRUE, axis_text_x = TRUE,
axis_line_x = TRUE, axis_line_x = TRUE,
axis_ticks_x = TRUE, axis_ticks_x = TRUE,
axis_text_x_angle = 0, axis_text_x_angle = 0,
axis_text_x_vjust = 0.5, axis_text_x_vjust = 0.5,
axis_text_x_hjust = 0 axis_text_x_hjust = 0
) )
return(t) return(t)