R/set_boundary_colors.R
In shirewoman2/Consultancy: Standardized tools for using R within the Simcyp Consultancy Team
Defines functions
make_so_highlight_key
make_gmr_highlight_key
set_boundary_colors
Documented in
make_gmr_highlight_key
make_so_highlight_key
set_boundary_colors
#' INTERNAL: Create a set of boundary colors based on the color set and the
#' boundaries the user needs.
#'
#' @param color_set either a single value, e.g., "red green" or a character
#' vector of colors. Acceptable single-value color set names:\describe{
#' \item{"yellow to red"}{for highlighting in PK tables}
#'
#' \item{"green to red"}{for highlighting in PK tables}
#'
#' \item{"traffic"}{for highlighting in PK tables}
#'
#' \item{"red black"}{for S/O boundary lines or fill}
#'
#' \item{"red green"}{for S/O boundary lines or fill}
#'
#' \item{"muted red green"}{for S/O boundary lines or fill}}
#'
#' @param break_type What type of breaks are these? Options are "GMR" (there
#' will only be 4 and the output will be a named character vector for the
#' intensity of the DDI), "SO highlight" (default) for S/O values in tables,
#' and "SO line" for coloring the lines in S/O graphs. This distinction
#' between "SO highlight" and "SO line" arises because the colors for the
#' lines in the S/O graphs generally should have the 1st color repeated
#' whereas the highlighting for tables should \emph{not} have any repeats. At
#' present, "yellow to red", "traffic", and "green to red" are only available
#' for break_types of "GMR" or "SO highlight". "red black", "red green", and
#' "muted red green" are only available for a break_type of "SO line".
#'
#' @return a character vector of colors, one for each numeric boundary
#'
#' @examples
#' # None. Internal use only.
#'
set_boundary_colors <- function(color_set,
boundaries,
break_type = "SO highlight"){
# Error catching --------------------------------------------------------
# Check whether tidyverse is loaded
if("package:tidyverse" %in% search() == FALSE){
stop("The SimcypConsultancy R package also requires the package tidyverse to be loaded, and it doesn't appear to be loaded yet. Please run `library(tidyverse)` and then try again.")
}
# Tidying inputs
if(any(boundaries < 1)){
warning("At least one of the numbers you specified for boundaries was < 1. We will automatically use both the original number you specified and its inverse for highlighting, so we'll ignore any values < 1 here.",
call. = FALSE)
}
boundaries <- sort(unique(c(boundaries, 1/boundaries)))
boundaries <- boundaries[which(boundaries >= 1)]
break_type <- toupper(break_type)[1]
break_type <- case_when(str_detect(break_type, "SO LIN") ~ "SO LINE",
str_detect(break_type, "SO HIGH") ~ "SO HIGHLIGHT",
.default = break_type)
if(str_detect(break_type, "SO$")){
warning(wrapn("It looks like you wanted a break type of either 'SO line' or 'SO highlight', but we're not sure which. We'll give you colors for break_type = 'SO highlight'."),
call. = FALSE)
break_type <- "SO HIGHLIGHT"
}
if(break_type %in% c("GMR", "SO LINE", "SO HIGHLIGHT") == FALSE){
warning(wrapn("You have specified something for 'break_type' that is not among the permissible options. We'll give you colors for break_type = 'SO highlight'."),
call. = FALSE)
break_type <- "SO HIGHLIGHT"
}
color_set <- tolower(color_set)
GoodColors <- c("red black", "yellow to red", "green to red", "red green",
"muted red green", "lisa", "traffic")
if(length(color_set) == 1 & length(boundaries) > 1 &&
color_set %in% GoodColors == FALSE){
color_set <- switch(break_type,
"SO LINE" = "red black",
"SO HIGHLIGHT" = "yellow to red")
warning(wrapn(paste0("It looks like you're trying to use a set of colors but that you have not provided one of the acceptable color sets. Please check the help file for options here. We'll use a color set of '",
color_set, "'.")),
call. = FALSE)
}
if(length(color_set) > 1 &&
length(boundaries) != length(color_set)){
color_set <- switch(break_type,
"SO LINE" = "red black",
"SO HIGHLIGHT" = "yellow to red")
warning(wrapn(paste0("The number of colors specified does not match the number of boundaries. We'll use the color set '",
color_set, "' instead.")),
call. = FALSE)
}
# Checking that they're real colors if not one of the sets.
ColorCheck <- try(expr = col2rgb(color_set), silent = TRUE)
if(color_set[1] %in% GoodColors == FALSE &&
is.matrix(ColorCheck) == FALSE){
color_set <- switch(break_type,
"SO LINE" = "red black",
"SO HIGHLIGHT" = "yellow to red")
warning(wrapn(paste0("The values you used for highlighting are not all valid colors in R. We'll use the color set '",
color_set, "' instead.")),
call. = FALSE)
}
# A little Easter egg
if(all(tolower(color_set) == "lisa")){
color_set <- "traffic"
}
# Checking for appropriate break types. I think that people (really, I) will
# be more likely to mess up the break_type than the color_set, so, when there
# is an incompatibility there, prioritize matching the color_set and adjust
# the break_type as needed.
if(length(color_set) == 1 &&
(break_type %in% c("SO HIGHLIGHT", "GMR") &
color_set %in% c("green to red", "yellow to red", "traffic") == FALSE)){
warning(wrapn(paste0("You requested ",
color_set, " for the argument 'color_set' and ",
break_type, " for the argument 'break_type', which is not among the available options for that break_type. We will set the break_type to 'SO highlight'.")),
call. = FALSE)
break_type <- "SO HIGHLIGHT"
}
if(length(color_set) == 1 &&
(break_type %in% c("SO LINE") &
color_set %in% c("red black", "red green", "muted red green") == FALSE)){
warning(wrapn(paste0("You requested ",
color_set, " for the argument 'color_set' and ",
break_type, " for the argument 'break_type', which is not among the available options for that break_type. We will set the break_type to 'SO line'.")),
call. = FALSE)
break_type <- "SO LINE"
}
## Dealing w/predefined color sets for highlighting ------------------------
# Re. color sets "yellow to red", "green to red", and "traffic": These are
# meant to be the same sets of colors and only differ in whether there is any
# highlighting for middle (acceptable) values.
# If the user has requested "green to red" but not included 1 in their
# cutoffs, add 1 to their cutoffs.
if(length(color_set) == 1 &&
(color_set == "green to red" & 1 %in% boundaries == FALSE)){
boundaries <- sort(unique(c(1, boundaries)))
}
# If the user has requested "yellow to red", the break_type is "SO
# HIGHLIGHT", and 1 is included in boundaries, then switch the color set to
# "green to red". If the user has requested "yellow to red" and NOT included
# 1 in the boundaries, leave the color set as is but add a 1 so that the
# middle will be white.
if(length(color_set) == 1 &&
(color_set == "yellow to red" & break_type == "SO HIGHLIGHT")){
if(1 %in% boundaries){
color_set <- "green to red"
} else {
boundaries <- sort(unique(c(1, boundaries)))
}
}
# If the user has requested "traffic" and NOT included 1 in the boundaries,
# set the name to traffic_no_middle and add a 1 so that the middle will be
# white.
if(length(color_set) == 1 &&
(color_set == "traffic" & 1 %in% boundaries == FALSE)){
color_set <- "traffic_no_middle"
boundaries <- sort(unique(c(1, boundaries)))
}
# Main body of function ----------------------------------------------------
# Upper number of breaks not including 1
MaxBound <- length(boundaries)
# Tidying inputs
if(1 %in% boundaries &
any(color_set %in% c(GoodColors, "traffic_no_middle"))){
color_set <- paste(color_set, "1")
}
if(length(color_set) == 1){
# Boundaries are only set up with *specific* colors when there are <= 3
# boundaries, not including the middle. If there are more boundaries than
# that, then we'll use colorRampPalette to pick the colors. Because of how
# this is set up in the boundary_color_set switch, we want the breaks to be
# no larger than 4. Note that break_type is set to "SO HIGHLIGHT" if it's a
# GMR break type b/c those result in the same sets of colors.
ColorChoices <- paste(
color_set,
case_match(break_type,
"GMR" ~ "SO HIGHLIGHT",
.default = break_type),
cut(length(boundaries), breaks = c(0:min(c(4, MaxBound)), Inf)))
boundary_color_set <-
switch(ColorChoices,
# red black -----------------------------------------------------
# 1 boundary, e.g., it's only unity
"red black SO LINE (0,1]" = "black",
# 2 boundaries
"red black SO LINE (1,2]" = c("black", "black"),
# 3 boundaries
"red black SO LINE (2,3]" = c("black", "black", "red"),
# 4 boundaries
"red black SO LINE (3,4]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# > 4 boundaries (this is same as above intentionally)
"red black SO LINE (4,Inf]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# 1 boundary, e.g., it's only unity
"red black 1 SO LINE (0,1]" = "black",
# 2 boundaries
"red black 1 SO LINE (1,2]" = c("black", "black"),
# 3 boundaries
"red black 1 SO LINE (2,3]" = c("black", "black", "red"),
# 4 boundaries
"red black 1 SO LINE (3,4]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# > 4 boundaries (this is same as above intentionally)
"red black 1 SO LINE (4,Inf]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# red green ------------------------------------------------------
# 1 boundary, e.g., it's only unity
"red green SO LINE (0,1]" = "#17A142",
# 2 boundaries
"red green SO LINE (1,2]" = c("#17A142", "#17A142"),
# 3 boundaries
"red green SO LINE (2,3]" = c("#17A142", "#17A142", "red"),
# 4 boundaries
"red green SO LINE (3,4]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# >4 boundaries (this is same as above intentionally)
"red green SO LINE (4,Inf]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# 1 boundary, e.g., it's only unity
"red green 1 SO LINE (0,1]" = "#17A142",
# 2 boundaries
"red green 1 SO LINE (1,2]" = c("#17A142", "red"),
# 3 boundaries
"red green 1 SO LINE (2,3]" = c("#17A142", "orange", "red"),
# 4 boundaries
"red green 1 SO LINE (3,4]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# >4 boundaries (this is same as above intentionally)
"red green 1 SO LINE (4,Inf]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# muted red green ------------------------------------------------
# 1 boundary, e.g., it's only unity
"muted red green SO LINE (0,1]" = "#A4E4AF",
# 2 boundaries
"muted red green SO LINE (1,2]" = c("#A4E4AF", "#A4E4AF"),
# 3 boundaries
"muted red green SO LINE (2,3]" = c("#A4E4AF", "#A4E4AF", "#E6A2A2"),
# 4 boundaries
"muted red green SO LINE (3,4]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# >4 boundaries (this is same as above intentionally)
"muted red green SO LINE (4,Inf]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# 1 boundary, e.g., it's only unity
"muted red green 1 SO LINE (0,1]" = "#A4E4AF",
# 2 boundaries
"muted red green 1 SO LINE (1,2]" = c("#A4E4AF", "#A4E4AF"),
# 3 boundaries
"muted red green 1 SO LINE (2,3]" = c("#A4E4AF", "#A4E4AF", "#E6A2A2"),
# 4 boundaries
"muted red green 1 SO LINE (3,4]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# >4 boundaries (this is same as above intentionally)
"muted red green 1 SO LINE (4,Inf]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# yellow to red ---------------------------------------------------
# Note that it is not possible to have a color set of "yellow to
# red" without 1 among the boundaries. That is why there is only
# one set of colors here and not a similar, near replicate set that
# don't have 1 included.
# Just highlight everything white. This would be weird and
# probably not what the user wants, but is among the possible
# choices for inputs.
"yellow to red 1 SO HIGHLIGHT (0,1]" = c("white"),
# white middle, 1 boundary other than middle
"yellow to red 1 SO HIGHLIGHT (1,2]" = c("white", "#FF9595"),
# white middle, 2 boundaries other than middle
"yellow to red 1 SO HIGHLIGHT (2,3]" = c("white", "#FFFF95", "#FF9595"),
# white middle, 3 boundaries other than middle
"yellow to red 1 SO HIGHLIGHT (3,4]" = c("white", "#FFFF95", "#FFDA95", "#FF9595"),
# white middle, >3 boundaries other than middle
"yellow to red 1 SO HIGHLIGHT (4,Inf]" =
c("white",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries))),
# green to red --------------------------------------------------
# Note that it is not possible to have a color set of "green to
# red" without 1 among the boundaries. That is why there is only
# one set of colors here and not a similar, near replicate set that
# don't have 1 included.
# 1 boundary, e.g., it's only unity
"green to red 1 SO HIGHLIGHT (0,1]" = "#A4E4AF",
# 2 boundaries
"green to red 1 SO HIGHLIGHT (1,2]" = c("#A4E4AF", "#E6A2A2"),
# 3 boundaries
"green to red 1 SO HIGHLIGHT (2,3]" = c("#A4E4AF", "#FFDA95", "#E6A2A2"),
# 4 boundaries
"green to red 1 SO HIGHLIGHT (3,4]" = c("#A4E4AF", "#FFFF95", "#FFDA95", "#FF9595"),
# >4 boundaries
"green to red 1 SO HIGHLIGHT (4,Inf]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# traffic --------------------------------------------------------
# Note that it is not possible to have a color set of "traffic"
# without 1 among the boundaries. When the user doesn't include 1,
# we're assuming they want the middle values to be white and only
# the high values to be highlighted, so that color set changes
# internally to "traffic_no_middle".
# Just highlight everything white. This would be weird and
# probably not what the user wants, but is among the possible
# choices for inputs.
"traffic_no_middle 1 SO HIGHLIGHT (0,1]" = c("white"),
# middle is white, 1 boundary other than middle
"traffic_no_middle 1 SO HIGHLIGHT (1,2]" = c("white", "#FF0000"),
# middle is white, 2 boundaries other than middle
"traffic_no_middle 1 SO HIGHLIGHT (2,3]" = c("white", "#FFC000", "#FF0000"),
# middle is white, 3 boundaries other than middle
"traffic_no_middle 1 SO HIGHLIGHT (3,4]" =
c("white", colorRampPalette(c("#FFC000", "#FF0000"))(
length(boundaries)-1)),
# middle is white, >3 boundaries other than middle (this is same as
# above intentionally)
"traffic_no_middle 1 SO HIGHLIGHT (4,Inf]" =
c("white", colorRampPalette(c("#FFC000", "#FF0000"))(
length(boundaries)-1)),
# Just highlight everything green. This would be weird and
# probably not what the user wants, but is among the possible
# choices for inputs.
"traffic 1 SO HIGHLIGHT (0,1]" = c("#00B050"),
# highlight middle, 1 boundary other than middle
"traffic 1 SO HIGHLIGHT (1,2]" = c("#00B050", "#FF0000"),
# highlight middle, 2 boundaries other than middle
"traffic 1 SO HIGHLIGHT (2,3]" = c("#00B050", "#92D050", "#FF0000"),
# highlight middle, 3 boundaries other than middle
"traffic 1 SO HIGHLIGHT (3,4]" = c("#00B050", "#92D050", "#FFC000", "#FF0000"),
# highlight middle, >3 boundaries other than middle
"traffic 1 SO HIGHLIGHT (4,Inf]" =
c("#00B050", "#92D050",
colorRampPalette(c("#FFC000", "#FF0000"))(
length(boundaries)-2))
)
} else {
boundary_color_set <- color_set
}
if(break_type == "GMR"){
names(boundary_color_set) <- c("negligible",
"weak",
"moderate",
"strong")
}
return(boundary_color_set)
}
#' Make a key for highlighted geometric mean ratios for DDIs in a table
#'
#' @param highlight_gmr_colors a set of colors for highlighting geometric mean
#' ratios for DDIs. Options are "yellow to red", "green to red", "traffic" (a
#' more vivid version of "green to red"), or a vector of 4 colors of your
#' choosing.
#'
#' @return a flextable for use as a key for which colors mean what GMR cutoff
#' @export
#'
#' @examples
#' make_gmr_highlight_key("yellow to red")
#'
make_gmr_highlight_key <- function(highlight_gmr_colors){
# Error catching --------------------------------------------------------
# Check whether tidyverse is loaded
if("package:tidyverse" %in% search() == FALSE){
stop("The SimcypConsultancy R package also requires the package tidyverse to be loaded, and it doesn't appear to be loaded yet. Please run `library(tidyverse)` and then try again.")
}
# Main body of function ---------------------------------------------------
highlight_gmr_colors <- set_boundary_colors(color_set = highlight_gmr_colors,
boundaries = c(1, 1.25, 2, 5),
break_type = "GMR")
tibble(`Interaction level` = names(highlight_gmr_colors)) %>%
flextable::flextable() %>%
flextable::bold(part = "header") %>%
flextable::bg(i = 1,
bg = highlight_gmr_colors["negligible"]) %>%
flextable::bg(i = 2,
bg = highlight_gmr_colors["weak"]) %>%
flextable::bg(i = 3,
bg = highlight_gmr_colors["moderate"]) %>%
flextable::bg(i = 4,
bg = highlight_gmr_colors["strong"]) %>%
flextable::width(width = 1.5) %>%
flextable::align(align = "center", part = "all")
}
#' Make a key for highlighted S/O values in a table or graph
#'
#' @param highlight_so_cutoffs cutoffs for highlighting simulated-to-observed
#' ratios. Anything that is above those values or below the inverse of those
#' values will be highlighted. Acceptable input for, say, highlighting values
#' that are > 125\% or < 80\% of the observed and also, with a second color,
#' values that are > 150\% or < 66\% would be: \code{highlight_so_cutoffs =
#' c(1.25, 1.5)}. If you would like the middle range of values to be
#' highlighted, include 1 in your cutoffs. For example, say you would like
#' everything that's < 80\% or > 125\% to be highlighted red but you'd like
#' the "good" values from 80\% to 125\% to be green, you can get that by
#' specifying
#' \code{highlight_so_cutoffs = c(1, 1.25)} and \code{highlight_so_colors =
#' c("green", "red")}
#' @param highlight_so_colors optionally specify a set of colors to use for
#' highlighting S/O values outside the limits you specified with
#' \code{highlight_so_cutoffs}. Options: \describe{
#'
#' \item{"yellow to red" (default)}{A range of light yellow to light orange to
#' light red. If you have included 1 in your cutoffs and you leave
#' \code{highlight_so_colors} with the default setting, values in the middle,
#' "good" range of S/O values will be highlighted a light green.}
#'
#' \item{"traffic"}{light green, yellow, and red designed to display values
#' outside 1.25, 1.5, and 2 fold of unity, respectively. If you include 1 in
#' \code{highlight_so_cutoffs}, you'll get a darker green for "good" S/O
#' values. This color scheme was borrowed from Lisa, so if you've seen her
#' slides, these will look familiar.}
#'
#' \item{a character vector of specific colors}{Any R-acceptable colors, will
#' work here, e.g., \code{highlight_so_colors = c("yellow", "orange", "red")}}.
#' If you do specify your own bespoke colors, you'll need to make sure that
#' you supply one color for every value in \code{highlight_so_cutoffs}.}
#'
#' @return a flextable for use as a key for which colors mean what S/O cutoff
#' @export
#'
#' @examples
#' make_so_highlight_key(highlight_so_colors = "green to red",
#' highlight_so_cutoffs = c(1, 1.25, 1.5, 2))
#'
make_so_highlight_key <- function(highlight_so_cutoffs,
highlight_so_colors){
# Error catching --------------------------------------------------------
# Check whether tidyverse is loaded
if("package:tidyverse" %in% search() == FALSE){
stop("The SimcypConsultancy R package also requires the package tidyverse to be loaded, and it doesn't appear to be loaded yet. Please run `library(tidyverse)` and then try again.")
}
# Main body of function ---------------------------------------------------
highlight_so_colors_orig <- highlight_so_colors
highlight_so_colors <- set_boundary_colors(color_set = highlight_so_colors,
boundaries = highlight_so_cutoffs,
break_type = "SO highlight")
# Need to hack the boundaries if the original color set is one of the
# pre-defined ones where you'll get white for values around 1.
if(tolower(highlight_so_colors_orig[1]) %in%
c("yellow to red", "traffic", "lisa")){
highlight_so_cutoffs <- sort(unique(c(highlight_so_cutoffs, 1)))
}
SOkey <- data.frame(UpperA = highlight_so_cutoffs[1:(length(highlight_so_cutoffs)-1)],
UpperB = highlight_so_cutoffs[2:(length(highlight_so_cutoffs))],
LowerA = 1/highlight_so_cutoffs[2:(length(highlight_so_cutoffs))],
LowerB = 1/highlight_so_cutoffs[1:(length(highlight_so_cutoffs)-1)]) %>%
bind_rows(data.frame(UpperA = NA,
UpperB = highlight_so_cutoffs[length(highlight_so_cutoffs)],
LowerA = NA,
LowerB = 1/highlight_so_cutoffs[length(highlight_so_cutoffs)])) %>%
mutate(across(.cols = everything(), .fns = round_consultancy),
Text = paste(LowerA, "to", LowerB, "fold or", UpperA, "to", UpperB, "fold"))
SOkey$Text[1] <- paste(SOkey$LowerA[1], "to", SOkey$UpperB[1], "fold")
SOkey$Text[nrow(SOkey)] <- paste("<", SOkey$LowerB[nrow(SOkey)],
"fold or >", SOkey$UpperB[nrow(SOkey)], "fold")
SOkey <- SOkey %>% select(Text) %>%
rename(`S/O cutoff` = Text) %>%
flextable::flextable() %>%
flextable::bold(part = "header") %>%
flextable::width(width = 3.5) %>%
flextable::align(align = "center", part = "all")
for(i in 1:length(highlight_so_cutoffs)){
SOkey <- SOkey %>%
flextable::bg(i = i,
bg = highlight_so_colors[i])
}
SOkey
}
shirewoman2/Consultancy documentation built on Feb. 18, 2025, 10 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions make_so_highlight_key make_gmr_highlight_key set_boundary_colors
Documented in make_gmr_highlight_key make_so_highlight_key set_boundary_colors
#' INTERNAL: Create a set of boundary colors based on the color set and the
#' boundaries the user needs.
#'
#' @param color_set either a single value, e.g., "red green" or a character
#' vector of colors. Acceptable single-value color set names:\describe{
#' \item{"yellow to red"}{for highlighting in PK tables}
#'
#' \item{"green to red"}{for highlighting in PK tables}
#'
#' \item{"traffic"}{for highlighting in PK tables}
#'
#' \item{"red black"}{for S/O boundary lines or fill}
#'
#' \item{"red green"}{for S/O boundary lines or fill}
#'
#' \item{"muted red green"}{for S/O boundary lines or fill}}
#'
#' @param break_type What type of breaks are these? Options are "GMR" (there
#' will only be 4 and the output will be a named character vector for the
#' intensity of the DDI), "SO highlight" (default) for S/O values in tables,
#' and "SO line" for coloring the lines in S/O graphs. This distinction
#' between "SO highlight" and "SO line" arises because the colors for the
#' lines in the S/O graphs generally should have the 1st color repeated
#' whereas the highlighting for tables should \emph{not} have any repeats. At
#' present, "yellow to red", "traffic", and "green to red" are only available
#' for break_types of "GMR" or "SO highlight". "red black", "red green", and
#' "muted red green" are only available for a break_type of "SO line".
#'
#' @return a character vector of colors, one for each numeric boundary
#'
#' @examples
#' # None. Internal use only.
#'
set_boundary_colors <- function(color_set,
boundaries,
break_type = "SO highlight"){
# Error catching --------------------------------------------------------
# Check whether tidyverse is loaded
if("package:tidyverse" %in% search() == FALSE){
stop("The SimcypConsultancy R package also requires the package tidyverse to be loaded, and it doesn't appear to be loaded yet. Please run `library(tidyverse)` and then try again.")
}
# Tidying inputs
if(any(boundaries < 1)){
warning("At least one of the numbers you specified for boundaries was < 1. We will automatically use both the original number you specified and its inverse for highlighting, so we'll ignore any values < 1 here.",
call. = FALSE)
}
boundaries <- sort(unique(c(boundaries, 1/boundaries)))
boundaries <- boundaries[which(boundaries >= 1)]
break_type <- toupper(break_type)[1]
break_type <- case_when(str_detect(break_type, "SO LIN") ~ "SO LINE",
str_detect(break_type, "SO HIGH") ~ "SO HIGHLIGHT",
.default = break_type)
if(str_detect(break_type, "SO$")){
warning(wrapn("It looks like you wanted a break type of either 'SO line' or 'SO highlight', but we're not sure which. We'll give you colors for break_type = 'SO highlight'."),
call. = FALSE)
break_type <- "SO HIGHLIGHT"
}
if(break_type %in% c("GMR", "SO LINE", "SO HIGHLIGHT") == FALSE){
warning(wrapn("You have specified something for 'break_type' that is not among the permissible options. We'll give you colors for break_type = 'SO highlight'."),
call. = FALSE)
break_type <- "SO HIGHLIGHT"
}
color_set <- tolower(color_set)
GoodColors <- c("red black", "yellow to red", "green to red", "red green",
"muted red green", "lisa", "traffic")
if(length(color_set) == 1 & length(boundaries) > 1 &&
color_set %in% GoodColors == FALSE){
color_set <- switch(break_type,
"SO LINE" = "red black",
"SO HIGHLIGHT" = "yellow to red")
warning(wrapn(paste0("It looks like you're trying to use a set of colors but that you have not provided one of the acceptable color sets. Please check the help file for options here. We'll use a color set of '",
color_set, "'.")),
call. = FALSE)
}
if(length(color_set) > 1 &&
length(boundaries) != length(color_set)){
color_set <- switch(break_type,
"SO LINE" = "red black",
"SO HIGHLIGHT" = "yellow to red")
warning(wrapn(paste0("The number of colors specified does not match the number of boundaries. We'll use the color set '",
color_set, "' instead.")),
call. = FALSE)
}
# Checking that they're real colors if not one of the sets.
ColorCheck <- try(expr = col2rgb(color_set), silent = TRUE)
if(color_set[1] %in% GoodColors == FALSE &&
is.matrix(ColorCheck) == FALSE){
color_set <- switch(break_type,
"SO LINE" = "red black",
"SO HIGHLIGHT" = "yellow to red")
warning(wrapn(paste0("The values you used for highlighting are not all valid colors in R. We'll use the color set '",
color_set, "' instead.")),
call. = FALSE)
}
# A little Easter egg
if(all(tolower(color_set) == "lisa")){
color_set <- "traffic"
}
# Checking for appropriate break types. I think that people (really, I) will
# be more likely to mess up the break_type than the color_set, so, when there
# is an incompatibility there, prioritize matching the color_set and adjust
# the break_type as needed.
if(length(color_set) == 1 &&
(break_type %in% c("SO HIGHLIGHT", "GMR") &
color_set %in% c("green to red", "yellow to red", "traffic") == FALSE)){
warning(wrapn(paste0("You requested ",
color_set, " for the argument 'color_set' and ",
break_type, " for the argument 'break_type', which is not among the available options for that break_type. We will set the break_type to 'SO highlight'.")),
call. = FALSE)
break_type <- "SO HIGHLIGHT"
}
if(length(color_set) == 1 &&
(break_type %in% c("SO LINE") &
color_set %in% c("red black", "red green", "muted red green") == FALSE)){
warning(wrapn(paste0("You requested ",
color_set, " for the argument 'color_set' and ",
break_type, " for the argument 'break_type', which is not among the available options for that break_type. We will set the break_type to 'SO line'.")),
call. = FALSE)
break_type <- "SO LINE"
}
## Dealing w/predefined color sets for highlighting ------------------------
# Re. color sets "yellow to red", "green to red", and "traffic": These are
# meant to be the same sets of colors and only differ in whether there is any
# highlighting for middle (acceptable) values.
# If the user has requested "green to red" but not included 1 in their
# cutoffs, add 1 to their cutoffs.
if(length(color_set) == 1 &&
(color_set == "green to red" & 1 %in% boundaries == FALSE)){
boundaries <- sort(unique(c(1, boundaries)))
}
# If the user has requested "yellow to red", the break_type is "SO
# HIGHLIGHT", and 1 is included in boundaries, then switch the color set to
# "green to red". If the user has requested "yellow to red" and NOT included
# 1 in the boundaries, leave the color set as is but add a 1 so that the
# middle will be white.
if(length(color_set) == 1 &&
(color_set == "yellow to red" & break_type == "SO HIGHLIGHT")){
if(1 %in% boundaries){
color_set <- "green to red"
} else {
boundaries <- sort(unique(c(1, boundaries)))
}
}
# If the user has requested "traffic" and NOT included 1 in the boundaries,
# set the name to traffic_no_middle and add a 1 so that the middle will be
# white.
if(length(color_set) == 1 &&
(color_set == "traffic" & 1 %in% boundaries == FALSE)){
color_set <- "traffic_no_middle"
boundaries <- sort(unique(c(1, boundaries)))
}
# Main body of function ----------------------------------------------------
# Upper number of breaks not including 1
MaxBound <- length(boundaries)
# Tidying inputs
if(1 %in% boundaries &
any(color_set %in% c(GoodColors, "traffic_no_middle"))){
color_set <- paste(color_set, "1")
}
if(length(color_set) == 1){
# Boundaries are only set up with *specific* colors when there are <= 3
# boundaries, not including the middle. If there are more boundaries than
# that, then we'll use colorRampPalette to pick the colors. Because of how
# this is set up in the boundary_color_set switch, we want the breaks to be
# no larger than 4. Note that break_type is set to "SO HIGHLIGHT" if it's a
# GMR break type b/c those result in the same sets of colors.
ColorChoices <- paste(
color_set,
case_match(break_type,
"GMR" ~ "SO HIGHLIGHT",
.default = break_type),
cut(length(boundaries), breaks = c(0:min(c(4, MaxBound)), Inf)))
boundary_color_set <-
switch(ColorChoices,
# red black -----------------------------------------------------
# 1 boundary, e.g., it's only unity
"red black SO LINE (0,1]" = "black",
# 2 boundaries
"red black SO LINE (1,2]" = c("black", "black"),
# 3 boundaries
"red black SO LINE (2,3]" = c("black", "black", "red"),
# 4 boundaries
"red black SO LINE (3,4]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# > 4 boundaries (this is same as above intentionally)
"red black SO LINE (4,Inf]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# 1 boundary, e.g., it's only unity
"red black 1 SO LINE (0,1]" = "black",
# 2 boundaries
"red black 1 SO LINE (1,2]" = c("black", "black"),
# 3 boundaries
"red black 1 SO LINE (2,3]" = c("black", "black", "red"),
# 4 boundaries
"red black 1 SO LINE (3,4]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# > 4 boundaries (this is same as above intentionally)
"red black 1 SO LINE (4,Inf]" = c("black",
colorRampPalette(c("black", "#FFC000", "red"))(
length(boundaries) - 1)),
# red green ------------------------------------------------------
# 1 boundary, e.g., it's only unity
"red green SO LINE (0,1]" = "#17A142",
# 2 boundaries
"red green SO LINE (1,2]" = c("#17A142", "#17A142"),
# 3 boundaries
"red green SO LINE (2,3]" = c("#17A142", "#17A142", "red"),
# 4 boundaries
"red green SO LINE (3,4]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# >4 boundaries (this is same as above intentionally)
"red green SO LINE (4,Inf]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# 1 boundary, e.g., it's only unity
"red green 1 SO LINE (0,1]" = "#17A142",
# 2 boundaries
"red green 1 SO LINE (1,2]" = c("#17A142", "red"),
# 3 boundaries
"red green 1 SO LINE (2,3]" = c("#17A142", "orange", "red"),
# 4 boundaries
"red green 1 SO LINE (3,4]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# >4 boundaries (this is same as above intentionally)
"red green 1 SO LINE (4,Inf]" = c("#17A142",
colorRampPalette(c("#17A142", "red"))(
length(boundaries) - 1)),
# muted red green ------------------------------------------------
# 1 boundary, e.g., it's only unity
"muted red green SO LINE (0,1]" = "#A4E4AF",
# 2 boundaries
"muted red green SO LINE (1,2]" = c("#A4E4AF", "#A4E4AF"),
# 3 boundaries
"muted red green SO LINE (2,3]" = c("#A4E4AF", "#A4E4AF", "#E6A2A2"),
# 4 boundaries
"muted red green SO LINE (3,4]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# >4 boundaries (this is same as above intentionally)
"muted red green SO LINE (4,Inf]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# 1 boundary, e.g., it's only unity
"muted red green 1 SO LINE (0,1]" = "#A4E4AF",
# 2 boundaries
"muted red green 1 SO LINE (1,2]" = c("#A4E4AF", "#A4E4AF"),
# 3 boundaries
"muted red green 1 SO LINE (2,3]" = c("#A4E4AF", "#A4E4AF", "#E6A2A2"),
# 4 boundaries
"muted red green 1 SO LINE (3,4]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# >4 boundaries (this is same as above intentionally)
"muted red green 1 SO LINE (4,Inf]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# yellow to red ---------------------------------------------------
# Note that it is not possible to have a color set of "yellow to
# red" without 1 among the boundaries. That is why there is only
# one set of colors here and not a similar, near replicate set that
# don't have 1 included.
# Just highlight everything white. This would be weird and
# probably not what the user wants, but is among the possible
# choices for inputs.
"yellow to red 1 SO HIGHLIGHT (0,1]" = c("white"),
# white middle, 1 boundary other than middle
"yellow to red 1 SO HIGHLIGHT (1,2]" = c("white", "#FF9595"),
# white middle, 2 boundaries other than middle
"yellow to red 1 SO HIGHLIGHT (2,3]" = c("white", "#FFFF95", "#FF9595"),
# white middle, 3 boundaries other than middle
"yellow to red 1 SO HIGHLIGHT (3,4]" = c("white", "#FFFF95", "#FFDA95", "#FF9595"),
# white middle, >3 boundaries other than middle
"yellow to red 1 SO HIGHLIGHT (4,Inf]" =
c("white",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries))),
# green to red --------------------------------------------------
# Note that it is not possible to have a color set of "green to
# red" without 1 among the boundaries. That is why there is only
# one set of colors here and not a similar, near replicate set that
# don't have 1 included.
# 1 boundary, e.g., it's only unity
"green to red 1 SO HIGHLIGHT (0,1]" = "#A4E4AF",
# 2 boundaries
"green to red 1 SO HIGHLIGHT (1,2]" = c("#A4E4AF", "#E6A2A2"),
# 3 boundaries
"green to red 1 SO HIGHLIGHT (2,3]" = c("#A4E4AF", "#FFDA95", "#E6A2A2"),
# 4 boundaries
"green to red 1 SO HIGHLIGHT (3,4]" = c("#A4E4AF", "#FFFF95", "#FFDA95", "#FF9595"),
# >4 boundaries
"green to red 1 SO HIGHLIGHT (4,Inf]" = c("#A4E4AF",
colorRampPalette(c("#FFFF95", "#FFDA95", "#FF9595"))(
length(boundaries)-1)),
# traffic --------------------------------------------------------
# Note that it is not possible to have a color set of "traffic"
# without 1 among the boundaries. When the user doesn't include 1,
# we're assuming they want the middle values to be white and only
# the high values to be highlighted, so that color set changes
# internally to "traffic_no_middle".
# Just highlight everything white. This would be weird and
# probably not what the user wants, but is among the possible
# choices for inputs.
"traffic_no_middle 1 SO HIGHLIGHT (0,1]" = c("white"),
# middle is white, 1 boundary other than middle
"traffic_no_middle 1 SO HIGHLIGHT (1,2]" = c("white", "#FF0000"),
# middle is white, 2 boundaries other than middle
"traffic_no_middle 1 SO HIGHLIGHT (2,3]" = c("white", "#FFC000", "#FF0000"),
# middle is white, 3 boundaries other than middle
"traffic_no_middle 1 SO HIGHLIGHT (3,4]" =
c("white", colorRampPalette(c("#FFC000", "#FF0000"))(
length(boundaries)-1)),
# middle is white, >3 boundaries other than middle (this is same as
# above intentionally)
"traffic_no_middle 1 SO HIGHLIGHT (4,Inf]" =
c("white", colorRampPalette(c("#FFC000", "#FF0000"))(
length(boundaries)-1)),
# Just highlight everything green. This would be weird and
# probably not what the user wants, but is among the possible
# choices for inputs.
"traffic 1 SO HIGHLIGHT (0,1]" = c("#00B050"),
# highlight middle, 1 boundary other than middle
"traffic 1 SO HIGHLIGHT (1,2]" = c("#00B050", "#FF0000"),
# highlight middle, 2 boundaries other than middle
"traffic 1 SO HIGHLIGHT (2,3]" = c("#00B050", "#92D050", "#FF0000"),
# highlight middle, 3 boundaries other than middle
"traffic 1 SO HIGHLIGHT (3,4]" = c("#00B050", "#92D050", "#FFC000", "#FF0000"),
# highlight middle, >3 boundaries other than middle
"traffic 1 SO HIGHLIGHT (4,Inf]" =
c("#00B050", "#92D050",
colorRampPalette(c("#FFC000", "#FF0000"))(
length(boundaries)-2))
)
} else {
boundary_color_set <- color_set
}
if(break_type == "GMR"){
names(boundary_color_set) <- c("negligible",
"weak",
"moderate",
"strong")
}
return(boundary_color_set)
}
#' Make a key for highlighted geometric mean ratios for DDIs in a table
#'
#' @param highlight_gmr_colors a set of colors for highlighting geometric mean
#' ratios for DDIs. Options are "yellow to red", "green to red", "traffic" (a
#' more vivid version of "green to red"), or a vector of 4 colors of your
#' choosing.
#'
#' @return a flextable for use as a key for which colors mean what GMR cutoff
#' @export
#'
#' @examples
#' make_gmr_highlight_key("yellow to red")
#'
make_gmr_highlight_key <- function(highlight_gmr_colors){
# Error catching --------------------------------------------------------
# Check whether tidyverse is loaded
if("package:tidyverse" %in% search() == FALSE){
stop("The SimcypConsultancy R package also requires the package tidyverse to be loaded, and it doesn't appear to be loaded yet. Please run `library(tidyverse)` and then try again.")
}
# Main body of function ---------------------------------------------------
highlight_gmr_colors <- set_boundary_colors(color_set = highlight_gmr_colors,
boundaries = c(1, 1.25, 2, 5),
break_type = "GMR")
tibble(`Interaction level` = names(highlight_gmr_colors)) %>%
flextable::flextable() %>%
flextable::bold(part = "header") %>%
flextable::bg(i = 1,
bg = highlight_gmr_colors["negligible"]) %>%
flextable::bg(i = 2,
bg = highlight_gmr_colors["weak"]) %>%
flextable::bg(i = 3,
bg = highlight_gmr_colors["moderate"]) %>%
flextable::bg(i = 4,
bg = highlight_gmr_colors["strong"]) %>%
flextable::width(width = 1.5) %>%
flextable::align(align = "center", part = "all")
}
#' Make a key for highlighted S/O values in a table or graph
#'
#' @param highlight_so_cutoffs cutoffs for highlighting simulated-to-observed
#' ratios. Anything that is above those values or below the inverse of those
#' values will be highlighted. Acceptable input for, say, highlighting values
#' that are > 125\% or < 80\% of the observed and also, with a second color,
#' values that are > 150\% or < 66\% would be: \code{highlight_so_cutoffs =
#' c(1.25, 1.5)}. If you would like the middle range of values to be
#' highlighted, include 1 in your cutoffs. For example, say you would like
#' everything that's < 80\% or > 125\% to be highlighted red but you'd like
#' the "good" values from 80\% to 125\% to be green, you can get that by
#' specifying
#' \code{highlight_so_cutoffs = c(1, 1.25)} and \code{highlight_so_colors =
#' c("green", "red")}
#' @param highlight_so_colors optionally specify a set of colors to use for
#' highlighting S/O values outside the limits you specified with
#' \code{highlight_so_cutoffs}. Options: \describe{
#'
#' \item{"yellow to red" (default)}{A range of light yellow to light orange to
#' light red. If you have included 1 in your cutoffs and you leave
#' \code{highlight_so_colors} with the default setting, values in the middle,
#' "good" range of S/O values will be highlighted a light green.}
#'
#' \item{"traffic"}{light green, yellow, and red designed to display values
#' outside 1.25, 1.5, and 2 fold of unity, respectively. If you include 1 in
#' \code{highlight_so_cutoffs}, you'll get a darker green for "good" S/O
#' values. This color scheme was borrowed from Lisa, so if you've seen her
#' slides, these will look familiar.}
#'
#' \item{a character vector of specific colors}{Any R-acceptable colors, will
#' work here, e.g., \code{highlight_so_colors = c("yellow", "orange", "red")}}.
#' If you do specify your own bespoke colors, you'll need to make sure that
#' you supply one color for every value in \code{highlight_so_cutoffs}.}
#'
#' @return a flextable for use as a key for which colors mean what S/O cutoff
#' @export
#'
#' @examples
#' make_so_highlight_key(highlight_so_colors = "green to red",
#' highlight_so_cutoffs = c(1, 1.25, 1.5, 2))
#'
make_so_highlight_key <- function(highlight_so_cutoffs,
highlight_so_colors){
# Error catching --------------------------------------------------------
# Check whether tidyverse is loaded
if("package:tidyverse" %in% search() == FALSE){
stop("The SimcypConsultancy R package also requires the package tidyverse to be loaded, and it doesn't appear to be loaded yet. Please run `library(tidyverse)` and then try again.")
}
# Main body of function ---------------------------------------------------
highlight_so_colors_orig <- highlight_so_colors
highlight_so_colors <- set_boundary_colors(color_set = highlight_so_colors,
boundaries = highlight_so_cutoffs,
break_type = "SO highlight")
# Need to hack the boundaries if the original color set is one of the
# pre-defined ones where you'll get white for values around 1.
if(tolower(highlight_so_colors_orig[1]) %in%
c("yellow to red", "traffic", "lisa")){
highlight_so_cutoffs <- sort(unique(c(highlight_so_cutoffs, 1)))
}
SOkey <- data.frame(UpperA = highlight_so_cutoffs[1:(length(highlight_so_cutoffs)-1)],
UpperB = highlight_so_cutoffs[2:(length(highlight_so_cutoffs))],
LowerA = 1/highlight_so_cutoffs[2:(length(highlight_so_cutoffs))],
LowerB = 1/highlight_so_cutoffs[1:(length(highlight_so_cutoffs)-1)]) %>%
bind_rows(data.frame(UpperA = NA,
UpperB = highlight_so_cutoffs[length(highlight_so_cutoffs)],
LowerA = NA,
LowerB = 1/highlight_so_cutoffs[length(highlight_so_cutoffs)])) %>%
mutate(across(.cols = everything(), .fns = round_consultancy),
Text = paste(LowerA, "to", LowerB, "fold or", UpperA, "to", UpperB, "fold"))
SOkey$Text[1] <- paste(SOkey$LowerA[1], "to", SOkey$UpperB[1], "fold")
SOkey$Text[nrow(SOkey)] <- paste("<", SOkey$LowerB[nrow(SOkey)],
"fold or >", SOkey$UpperB[nrow(SOkey)], "fold")
SOkey <- SOkey %>% select(Text) %>%
rename(`S/O cutoff` = Text) %>%
flextable::flextable() %>%
flextable::bold(part = "header") %>%
flextable::width(width = 3.5) %>%
flextable::align(align = "center", part = "all")
for(i in 1:length(highlight_so_cutoffs)){
SOkey <- SOkey %>%
flextable::bg(i = i,
bg = highlight_so_colors[i])
}
SOkey
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.