#' Generate color scales based on a value.
#'
#' This function is an adaptation of colortools package. As the package was removed from CRAN on 23-06-2022, this utility function came to existence in order to cover the gap. It is, on its basis,
#' an adaptation of the package into a single function. Original code, developed by Gaston Sanchez, can be found in: <https://github.com/gastonstat/colortools>
#'
#' @inheritParams doc_function
#' @param colors.use \strong{\code{\link[base]{character}}} | One color upon which generate the color scale. Can be a name or a HEX code.
#' @param n \strong{\code{\link[base]{numeric}}} | Number of colors to include in the color wheel. Use it when all other options are FALSE, otherwise, it becomes 12.
#' @param opposite \strong{\code{\link[base]{logical}}} | Return the opposing color to the one provided.
#' @param adjacent \strong{\code{\link[base]{logical}}} | Return the adjacent colors to the one provided.
#' @param triadic \strong{\code{\link[base]{logical}}} | Return the triadic combination of colors to the one provided.
#' @param split_complementary \strong{\code{\link[base]{logical}}} | Return the split complementary combination of colors to the one provided.
#' @param tetradic \strong{\code{\link[base]{logical}}} | Return the tetradic combination of colors to the one provided.
#' @param square \strong{\code{\link[base]{logical}}} | Return the square combination of colors to the one provided.
#' @param complete_output \strong{\code{\link[base]{logical}}} | Runs all the previous options and returns all the outputs as a list that contains all color vectors, all plots and a combined plot with everything.
#' @param plot \strong{\code{\link[base]{logical}}} | Whether to also return a plot displaying the values instead of a vector with the color.
#' @return A character vector with the desired color scale.
#' @export
#' @example man/examples/examples_do_ColorPalette.R
do_ColorPalette <- function(colors.use,
n = 12,
opposite = FALSE,
adjacent = FALSE,
triadic = FALSE,
split_complementary = FALSE,
tetradic = FALSE,
square = FALSE,
complete_output = FALSE,
plot = FALSE,
font.size = 14,
font.type = "sans"){
# Add lengthy error messages.
withr::local_options(.new = list("warning.length" = 8170))
check_suggests(function_name = "do_ColorPalette")
# Check logical parameters.
logical_list <- list("opposite" = opposite,
"adjacent" = adjacent,
"triadic" = triadic,
"split_complementary" = split_complementary,
"tetradic" = tetradic,
"square" = square,
"complete_output" = complete_output)
check_type(parameters = logical_list, required_type = "logical", test_function = is.logical)
# Check numeric parameters.
numeric_list <- list("n" = n,
"font.size", font.size)
check_type(parameters = numeric_list, required_type = "numeric", test_function = is.numeric)
# Check character parameters.
character_list <- list("colors.use" = colors.use,
"font.type" = font.type)
check_type(parameters = character_list, required_type = "character", test_function = is.character)
# Check that the colors provided are only one.
assertthat::assert_that(length(colors.use) == 1,
msg = paste0(add_cross(), crayon_body("Please, provide a single "),
crayon_key("color"),
crayon_body(" to "),
crayon_key("colors.use")))
# Check that the color provided is a valid color representation.
check_colors(colors.use, parameter_name = "colors.use")
# Check that only one option is activated.
options_list <- c(opposite, adjacent, triadic, split_complementary, tetradic, square, complete_output)
if (sum(options_list) > 0){
assertthat::assert_that(sum(options_list) == 1,
msg = paste0(add_cross(), crayon_body("Please, select only "),
crayon_key("one option"),
crayon_body(" to form the color scale.\nIf you want more than "),
crayon_key("one output"),
crayon_body(", consider using the paramter"),
crayon_key("complete_output"),
crayon_body(".")))
}
# Check that n is actually positive.
assertthat::assert_that(n > 0,
msg = paste0(add_cross(), crayon_body("Please, provide a "),
crayon_key("positive value"),
crayon_body(" to the parameter "),
crayon_key("n"),
crayon_body(".")))
# If any option is set to TRUE, pal_length is 12
if (sum(options_list) >= 1 & n != 12){
warning(paste0(add_warning(), crayon_body("When a "),
crayon_key("color output"),
crayon_body(" option is selected, parameter "),
crayon_key("n"),
crayon_body(" becomes by default "),
crayon_key("12"),
crayon_body("\nPlease consider not using "),
crayon_key("n"),
crayon_body(" in such cases.")), call. = FALSE)
n <- 12
}
# Convert input to RGB colors: Input can be either color names, hex code.
RGB_colors <- grDevices::col2rgb(colors.use)
# Convert RGB values to HSV values.
HSV_colors <- grDevices::rgb2hsv(RGB_colors)[, 1]
# Get HSV components.
hue <- HSV_colors[[1]] # Hue
sat <- HSV_colors[[2]] # Saturation
val <- HSV_colors[[3]] # Value
# Generate a vector of hues that range a total of 1 unit, divided equally by n.
hue_vector <- seq(hue, hue + 1, by = 1 / n)
# Subset only the n colors.
hue_vector <- hue_vector[1:n]
# As this will generate hues over 1, anything over it, we deduct 1.
hue_vector[hue_vector > 1] <- hue_vector[hue_vector > 1] - 1
# Transform HSV values into HEX codes.
colors <- grDevices::hsv(hue_vector, sat, val)
# Add transparency value of the original color to the generated color scale.
# This only works in the case the original color has a transparency value.
if (substr(colors.use, 1, 1) == "#" && nchar(colors.use) == 9){
alpha <- substr(colors.use, 8, 9)
colors <- paste(colors, alpha, sep="")
}
# If opposite is TRUE, select the first and middle colors.
if (isTRUE(opposite)){
colors.mod <- colors[c(1, 7)]
# If adjacent is TRUE, select the hues next to the original color.
} else if (isTRUE(adjacent)){
colors.mod <- colors[c(1, 2, 12)]
# If triadic is TRUE, select the hues forming a triangle.
} else if (isTRUE(triadic)){
colors.mod <- colors[c(1, 5, 9)]
# If split_complementary is TRUE, select the hues forming a triangle.
} else if (isTRUE(split_complementary)){
colors.mod <- colors[c(1, 6, 8)]
# If tetradic is TRUE, select the hues forming a triangle.
} else if (isTRUE(tetradic)){
colors.mod <- colors[c(1, 3, 7, 9)]
# If square is TRUE, select the hues forming a triangle.
} else if (isTRUE(square)){
colors.mod <- colors[c(1, 4, 7, 10)]
# If complete_output is TRUE, report everything.
} else {
colors.mod <- colors
}
if (isTRUE(plot) & base::isFALSE(complete_output)){
# Dummy df to plot.
names(colors) <- colors
df <- data.frame("values" = rep(1, n), "names" = factor(colors, levels = names(colors)))
limits <- c(-5, 1.35)
colors.use <- colors
# Define name for the center of the plot.
if (isTRUE(opposite)){
name_center <- "Opposite"
colors.use[!(names(colors.use) %in% colors[c(1, 7)])] <- "grey75"
# If adjacent is TRUE, select the hues next to the original color.
} else if (isTRUE(adjacent)){
name_center <- "Adjacent"
colors.use[!(names(colors.use) %in% colors[c(1, 2, 12)])] <- "grey75"
# If triadic is TRUE, select the hues forming a triangle.
} else if (isTRUE(triadic)){
name_center <- "Triadic"
colors.use[!(names(colors.use) %in% colors[c(1, 5, 9)])] <- "grey75"
# If split_complementary is TRUE, select the hues forming a triangle.
} else if (isTRUE(split_complementary)){
name_center <- stringr::str_wrap("Split complementary", width = 5)
colors.use[!(names(colors.use) %in% colors[c(1, 6, 8)])] <- "grey75"
# If tetradic is TRUE, select the hues forming a triangle.
} else if (isTRUE(tetradic)){
name_center <- "Tetradic"
colors.use[!(names(colors.use) %in% colors[c(1, 3, 7, 9)])] <- "grey75"
# If square is TRUE, select the hues forming a triangle.
} else if (isTRUE(square)){
name_center <- "Square"
colors.use[!(names(colors.use) %in% colors[c(1, 4, 7, 10)])] <- "grey75"
# If complete_output is TRUE, report everything.
} else {
name_center <- "Wheel"
}
# Define blank labels.
count <- 0
if ("grey75" %in% colors.use){
names.vector <- NULL
# Iterate over each color.
for (name in names(colors.use)){
if (colors.use[name] == "grey75"){
count <- count + 1
label.use <- paste0(rep(" ", count), collapse = "")
} else {
label.use <- name
}
names.vector <- append(names.vector, label.use)
}
names(colors.use) <- names.vector
df[["names"]] <- factor(names(colors.use), levels = names(colors.use))
}
p <- ggplot2::ggplot(data = df, mapping = ggplot2::aes(x = .data[["names"]],
y = .data[["values"]],
fill = .data[["names"]])) +
ggplot2::geom_col(color = "black", linewidth = 1) +
ggplot2::coord_polar(start = ifelse(sum(options_list) == 1, -0.275, 0), direction = 1, clip = "off") +
ggplot2::scale_fill_manual(values = colors.use, na.value = "grey75") +
ggplot2::ylim(limits) +
# Add X axis title in the center of the plot.
ggplot2::annotate(geom = "text",
x = df[["names"]][[1]],
y = limits[[1]],
angle = 0,
hjust = 0.5,
vjust = 0.5,
label = name_center,
size = 8,
fontface = "bold") +
ggplot2::theme_minimal(base_size = font.size) +
ggplot2::theme(axis.title = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.text.y = ggplot2::element_blank(),
axis.text.x = ggplot2::element_text(face = "bold", color = "black"),
panel.grid.major = ggplot2::element_blank(),
plot.title.position = "plot",
plot.title = ggplot2::element_text(face = "bold", hjust = 0),
plot.subtitle = ggplot2::element_text(hjust = 0),
plot.caption = ggplot2::element_text(hjust = 1),
panel.grid = ggplot2::element_blank(),
text = ggplot2::element_text(family = font.type),
plot.caption.position = "plot",
legend.text = ggplot2::element_text(face = "bold"),
legend.position = "none",
legend.title = ggplot2::element_text(face = "bold"),
legend.justification = "center",
plot.margin = ggplot2::margin(t = 10, r = 40, b = 10, l = 40),
plot.background = ggplot2::element_rect(fill = "white", color = "white"),
panel.background = ggplot2::element_rect(fill = "white", color = "white"),
legend.background = ggplot2::element_rect(fill = "white", color = "white"))
} else if (isTRUE(plot) & isTRUE(complete_output)) {
stop(paste0(add_cross(), crayon_body("Parameter "),
crayon_key("plot"),
crayon_body(" only works when "),
crayon_key("complete_output"),
crayon_body(" is set to "),
crayon_key("FALSE"),
crayon_body(".")), call. = FALSE)
}
# Complete output.
# If plot = TRUE, return the plot, if not, colors. If complete_output = TRUE, return the report.
if (isTRUE(complete_output)){
# List of colors.
return_colors <- list("wheel" = do_ColorPalette(colors.use = colors.use,
n = n),
"opposite" = do_ColorPalette(colors.use = colors.use,
n = n,
opposite = TRUE),
"adjacent" = do_ColorPalette(colors.use = colors.use,
n = n,
adjacent = TRUE),
"triadic" = do_ColorPalette(colors.use = colors.use,
n = n,
triadic = TRUE),
"split_complementary" = do_ColorPalette(colors.use = colors.use,
n = n,
split_complementary = TRUE),
"tetradic" = do_ColorPalette(colors.use = colors.use,
n = n,
tetradic = TRUE),
"square" = do_ColorPalette(colors.use = colors.use,
n = n,
square = TRUE))
# List of plots.
return_plots <- list("wheel" = do_ColorPalette(colors.use = colors.use,
n = n,
plot = TRUE),
"opposite" = do_ColorPalette(colors.use = colors.use,
n = n,
opposite = TRUE,
plot = TRUE),
"adjacent" = do_ColorPalette(colors.use = colors.use,
n = n,
adjacent = TRUE,
plot = TRUE),
"triadic" = do_ColorPalette(colors.use = colors.use,
n = n,
triadic = TRUE,
plot = TRUE),
"split_complementary" = do_ColorPalette(colors.use = colors.use,
n = n,
split_complementary = TRUE,
plot = TRUE),
"tetradic" = do_ColorPalette(colors.use = colors.use,
n = n,
tetradic = TRUE,
plot = TRUE),
"square" = do_ColorPalette(colors.use = colors.use,
n = n,
square = TRUE,
plot = TRUE))
layout <- "ABCD
EFGH"
patch <- patchwork::wrap_plots(A = return_plots[["wheel"]],
B = return_plots[["opposite"]],
C = return_plots[["adjacent"]],
D = return_plots[["triadic"]],
E = return_plots[["split_complementary"]],
F = return_plots[["tetradic"]],
G = return_plots[["square"]],
H = patchwork::plot_spacer(),
design = layout)
# Build the output object.
return_object <- list("colors" = return_colors,
"plots" = return_plots,
"combined_plot" = patch)
} else {
if (isTRUE(plot)){
return_object <- p
} else {
return_object <- colors.mod
}
}
return(return_object)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.