andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 04:27:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

feat: added option to choose color palettes for all available plots. this includes a custom function to generate colors from several palettes as well as a select function to include color previews.

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-03-24 12:04:54 +01:00
commit 6c850847b7
No known key found for this signature in database
21 changed files with 1110 additions and 251 deletions
Download patch file Download diff file Expand all files Collapse all files

179
R/custom_SelectInput.R
View file

@ -20,8 +20,7 @@
#' @importFrom shiny selectizeInput #' @importFrom shiny selectizeInput
#' @export #' @export
#' #'
columnSelectInput <- function( columnSelectInput <- function(inputId,
inputId,
label, label,
data, data,
selected = "", selected = "",
@ -30,20 +29,27 @@ columnSelectInput <- function(
placeholder = "", placeholder = "",
onInitialize, onInitialize,
none_label = "No variable selected", none_label = "No variable selected",
maxItems = NULL maxItems = NULL) {
) { datar <- if (is.reactive(data))
datar <- if (is.reactive(data)) data else reactive(data) data
col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) else
reactive(data)
col_subsetr <- if (is.reactive(col_subset))
col_subset
else
reactive(col_subset)
labels <- Map(function(col) { labels <- Map(function(col) {
json <- sprintf( json <- sprintf(
IDEAFilter:::strip_leading_ws(' IDEAFilter:::strip_leading_ws(
'
{ {
"name": "%s", "name": "%s",
"label": "%s", "label": "%s",
"dataclass": "%s", "dataclass": "%s",
"datatype": "%s" "datatype": "%s"
}'), }'
),
col, col,
attr(datar()[[col]], "label") %||% "", attr(datar()[[col]], "label") %||% "",
IDEAFilter:::get_dataFilter_class(datar()[[col]]), IDEAFilter:::get_dataFilter_class(datar()[[col]]),
@ -52,12 +58,25 @@ columnSelectInput <- function(
}, col = names(datar())) }, col = names(datar()))
if (!"none" %in% names(datar())) { if (!"none" %in% names(datar())) {
labels <- c("none" = list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', none_label)), labels) labels <- c("none" = list(
sprintf(
'\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }',
none_label
)
), labels)
choices <- setNames(names(labels), labels) choices <- setNames(names(labels), labels)
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] choices <- choices[match(if (length(col_subsetr()) == 0 ||
isTRUE(col_subsetr() == ""))
names(datar())
else
col_subsetr(), choices)]
} else { } else {
choices <- setNames(names(datar()), labels) choices <- setNames(names(datar()), labels)
choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] choices <- choices[match(if (length(col_subsetr()) == 0 ||
isTRUE(col_subsetr() == ""))
choices
else
col_subsetr(), choices)]
} }
shiny::selectizeInput( shiny::selectizeInput(
@ -66,8 +85,9 @@ columnSelectInput <- function(
choices = choices, choices = choices,
selected = selected, selected = selected,
..., ...,
options = c( options = c(list(
list(render = I("{ render = I(
"{
// format the way that options are rendered // format the way that options are rendered
option: function(item, escape) { option: function(item, escape) {
item.data = JSON.parse(item.label); item.data = JSON.parse(item.label);
@ -95,9 +115,10 @@ columnSelectInput <- function(
escape(item.data.name) + escape(item.data.name) +
'</div>'; '</div>';
} }
}")), }"
if (!is.null(maxItems)) list(maxItems = maxItems)
) )
), if (!is.null(maxItems))
list(maxItems = maxItems))
) )
} }
@ -150,7 +171,10 @@ vectorSelectInput <- function(inputId,
..., ...,
placeholder = "", placeholder = "",
onInitialize) { onInitialize) {
datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices) datar <- if (shiny::is.reactive(choices))
data
else
shiny::reactive(choices)
labels <- sprintf( labels <- sprintf(
IDEAFilter:::strip_leading_ws(' IDEAFilter:::strip_leading_ws('
@ -170,8 +194,9 @@ vectorSelectInput <- function(inputId,
choices = choices_new, choices = choices_new,
selected = selected, selected = selected,
..., ...,
options = c( options = c(list(
list(render = I("{ render = I(
"{
// format the way that options are rendered // format the way that options are rendered
option: function(item, escape) { option: function(item, escape) {
item.data = JSON.parse(item.label); item.data = JSON.parse(item.label);
@ -190,7 +215,123 @@ vectorSelectInput <- function(inputId,
escape(item.data.name) + escape(item.data.name) +
'</div>'; '</div>';
} }
}")) }"
)
))
)
}
#' A selectizeInput customized for named vectors of color names supported by
#' \code{\link{generate_colors}}
#'
#' @param inputId passed to \code{\link[shiny]{selectizeInput}}
#' @param label passed to \code{\link[shiny]{selectizeInput}}
#' @param choices A named \code{vector} from which fields should be populated
#' @param selected default selection
#' @param previews number of preview colors. Default is 4.
#' @param ... passed to \code{\link[shiny]{selectizeInput}}
#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options
#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options
#'
#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element
#' @export
#'
#' @examples
#' if (shiny::interactive()) {
#'top_palettes <- c(
#'"Perceptual (blue-yellow)" = "viridis",
#'"Perceptual (fire)" = "plasma",
#'"Colour-blind friendly" = "Okabe-Ito",
#'"Qualitative (bold)" = "Dark 2",
#'"Qualitative (paired)" = "Paired",
#'"Sequential (blues)" = "Blues",
#'"Diverging (red-blue)" = "RdBu",
#'"Tableau style" = "Tableau 10",
#'"Pastel" = "Pastel 1",
#'"Rainbow" = "rainbow"
#')
#' shinyApp(
#' ui = fluidPage(
#' titlePanel("Color Palette Select Test"),
#' colorSelectInput(
#' inputId = "palette",
#' label = "Color palette",
#' choices = top_palettes,
#' selected = "viridis"
#' ),
#' verbatimTextOutput("selected")
#' ),
#' server = function(input, output, session) {
#' output$selected <- renderPrint(input$palette)
#' }
#' )
#' }
colorSelectInput <- function(inputId,
label,
choices,
selected = "",
previews = 4,
...,
placeholder = "") {
vals <- if (shiny::is.reactive(choices)) {
choices()
} else{
choices
}
swatch_html <- function(palette_name) {
colors <- tryCatch(
suppressMessages(generate_colors(previews, palette_name)),
error = function(e)
rep("#cccccc", 3)
)
# Strip alpha channel to ensure valid 6-digit CSS hex
colors <- substr(colors, 1, 7)
paste0(
sprintf(
"<span style='display:inline-block;width:12px;height:12px;background:%s;border-radius:2px;margin-right:1px;'></span>",
colors
),
collapse = ""
)
}
labels <- sprintf(
'{"name": "%s", "label": "%s", "swatch": "%s"}',
vals,
names(vals) %||% "",
vapply(vals, swatch_html, character(1))
)
choices_new <- stats::setNames(vals, labels)
shiny::selectizeInput(
inputId = inputId,
label = label,
choices = choices_new,
selected = selected,
...,
options = list(
render = I(
"{
option: function(item, escape) {
item.data = JSON.parse(item.label);
return '<div style=\"padding:3px 12px\">' +
'<div><strong>' + escape(item.data.name) + '</strong></div>' +
(item.data.label != '' ? '<div><small>' + escape(item.data.label) + '</small></div>' : '') +
'<div style=\"margin-top:4px\">' + item.data.swatch + '</div>' +
'</div>';
},
item: function(item, escape) {
item.data = JSON.parse(item.label);
return '<div style=\"display:flex;align-items:center;gap:6px\">' +
'<span>' + escape(item.data.name) + '</span>' +
item.data.swatch +
'</div>';
}
}"
)
) )
) )
} }

213
R/data_plots.R
View file

@ -22,11 +22,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
title = "Create plot", title = "Create plot",
icon = bsicons::bs_icon("graph-up"), icon = bsicons::bs_icon("graph-up"),
shiny::uiOutput(outputId = ns("primary")), shiny::uiOutput(outputId = ns("primary")),
shiny::helpText(i18n$t('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.')), shiny::helpText(
i18n$t(
'Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.'
)
),
shiny::tags$br(), shiny::tags$br(),
shiny::uiOutput(outputId = ns("type")), shiny::uiOutput(outputId = ns("type")),
shiny::uiOutput(outputId = ns("secondary")), shiny::uiOutput(outputId = ns("secondary")),
shiny::uiOutput(outputId = ns("tertiary")), shiny::uiOutput(outputId = ns("tertiary")),
shiny::uiOutput(outputId = ns("color_palette")),
shiny::br(), shiny::br(),
shiny::actionButton( shiny::actionButton(
inputId = ns("act_plot"), inputId = ns("act_plot"),
@ -72,14 +77,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
shiny::selectInput( shiny::selectInput(
inputId = ns("plot_type"), inputId = ns("plot_type"),
label = i18n$t("File format"), label = i18n$t("File format"),
choices = list( choices = list("png", "tiff", "eps", "pdf", "jpeg", "svg")
"png",
"tiff",
"eps",
"pdf",
"jpeg",
"svg"
)
), ),
shiny::br(), shiny::br(),
# Button # Button
@ -90,12 +88,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
) )
) )
), ),
shiny::p("We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( shiny::p(
"We have collected a few notes on visualising data and details on the options included in FreesearchR:",
shiny::tags$a(
href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html",
"View notes in new tab", "View notes in new tab",
target = "_blank", target = "_blank",
rel = "noopener noreferrer" rel = "noopener noreferrer"
)) )
)
), ),
shiny::plotOutput(ns("plot"), height = "70vh"), shiny::plotOutput(ns("plot"), height = "70vh"),
shiny::tags$br(), shiny::tags$br(),
@ -116,21 +117,37 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
#' @export #' @export
data_visuals_server <- function(id, data_visuals_server <- function(id,
data, data,
palettes = c(
"Perceptual (blue-yellow)" = "viridis",
"Perceptual (fire)" = "plasma",
"Colour-blind friendly" = "Okabe-Ito",
"Qualitative (bold)" = "Dark 2",
"Qualitative (paired)" = "Paired",
"Sequential (blues)" = "Blues",
"Diverging (red-blue)" = "RdBu",
"Tableau style" = "Tableau 10",
"Pastel" = "Pastel 1",
"Rainbow" = "rainbow"
),
...) { ...) {
shiny::moduleServer( shiny::moduleServer(
id = id, id = id,
module = function(input, output, session) { module = function(input, output, session) {
ns <- session$ns ns <- session$ns
rv <- shiny::reactiveValues( rv <- shiny::reactiveValues(plot.params = NULL,
plot.params = NULL,
plot = NULL, plot = NULL,
code = NULL code = NULL)
)
shiny::observe({ shiny::observe({
bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_plot",title = i18n$t("Create plot")) bslib::accordion_panel_update(
bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_download",title = i18n$t("Download")) id = "acc_plot",
target = "acc_pan_plot",
title = i18n$t("Create plot")
)
bslib::accordion_panel_update(id = "acc_plot",
target = "acc_pan_download",
title = i18n$t("Download"))
}) })
# ## --- New attempt # ## --- New attempt
@ -259,12 +276,10 @@ data_visuals_server <- function(id,
plot_data <- data()[input$primary] plot_data <- data()[input$primary]
} }
plots <- possible_plots( plots <- possible_plots(data = plot_data)
data = plot_data
)
plots_named <- get_plot_options(plots) |> plots_named <- get_plot_options(plots) |>
lapply(\(.x){ lapply(\(.x) {
stats::setNames(.x$descr, .x$note) stats::setNames(.x$descr, .x$note)
}) })
@ -284,23 +299,19 @@ data_visuals_server <- function(id,
output$secondary <- shiny::renderUI({ output$secondary <- shiny::renderUI({
shiny::req(input$type) shiny::req(input$type)
cols <- c( cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames(
rv$plot.params()[["secondary.extra"]], subset_types(data(), rv$plot.params()[["secondary.type"]])
all_but( ), input$primary))
colnames(subset_types(
data(),
rv$plot.params()[["secondary.type"]]
)),
input$primary
)
)
columnSelectInput( columnSelectInput(
inputId = ns("secondary"), inputId = ns("secondary"),
data = data, data = data,
selected = cols[1], selected = cols[1],
placeholder = i18n$t("Please select"), placeholder = i18n$t("Please select"),
label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) i18n$t("Additional variables") else i18n$t("Secondary variable"), label = if (isTRUE(rv$plot.params()[["secondary.multi"]]))
i18n$t("Additional variables")
else
i18n$t("Secondary variable"),
multiple = rv$plot.params()[["secondary.multi"]], multiple = rv$plot.params()[["secondary.multi"]],
maxItems = rv$plot.params()[["secondary.max"]], maxItems = rv$plot.params()[["secondary.max"]],
col_subset = cols, col_subset = cols,
@ -319,10 +330,7 @@ data_visuals_server <- function(id,
col_subset = c( col_subset = c(
"none", "none",
all_but( all_but(
colnames(subset_types( colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])),
data(),
rv$plot.params()[["tertiary.type"]]
)),
input$primary, input$primary,
input$secondary input$secondary
) )
@ -331,64 +339,59 @@ data_visuals_server <- function(id,
) )
}) })
shiny::observeEvent(input$act_plot, ### Color option
{ output$color_palette <- shiny::renderUI({
# shiny::req(input$type)
colorSelectInput(
inputId = ns("color_palette"),
label = i18n$t("Choose color palette"),
choices = palettes
)
})
shiny::observeEvent(input$act_plot, {
if (NROW(data()) > 0) { if (NROW(data()) > 0) {
tryCatch( tryCatch({
{
parameters <- list( parameters <- list(
type = rv$plot.params()[["fun"]], type = rv$plot.params()[["fun"]],
pri = input$primary, pri = input$primary,
sec = input$secondary, sec = input$secondary,
ter = input$tertiary ter = input$tertiary,
color.palette = input$color_palette
) )
## If the dictionary holds additional arguments to pass to the ## If the dictionary holds additional arguments to pass to the
## plotting function, these are included ## plotting function, these are included
if (!is.null(rv$plot.params()[["fun.args"]])){ if (!is.null(rv$plot.params()[["fun.args"]])) {
parameters <- modifyList(parameters,rv$plot.params()[["fun.args"]]) parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]])
} }
shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), { shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."),
rv$plot <- rlang::exec( {
create_plot, rv$plot <- rlang::exec(create_plot,
!!!append_list( !!!append_list(data(), parameters, "data"))
data(),
parameters,
"data"
)
)
}) })
rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})")
}, }, # warning = function(warn) {
# warning = function(warn) {
# showNotification(paste0(warn), type = "warning") # showNotification(paste0(warn), type = "warning")
# }, # },
error = function(err) { error = function(err) {
showNotification(paste0(err), type = "err") showNotification(paste0(err), type = "err")
})
} }
) }, ignoreInit = TRUE)
}
},
ignoreInit = TRUE
)
output$code_plot <- shiny::renderUI({ output$code_plot <- shiny::renderUI({
shiny::req(rv$code) shiny::req(rv$code)
prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code)) prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code))
}) })
shiny::observeEvent( shiny::observeEvent(list(data()), {
list(
data()
),
{
shiny::req(data()) shiny::req(data())
rv$plot <- NULL rv$plot <- NULL
} })
)
output$plot <- shiny::renderPlot({ output$plot <- shiny::renderPlot({
# shiny::req(rv$plot) # shiny::req(rv$plot)
@ -428,16 +431,15 @@ data_visuals_server <- function(id,
width = input$width, width = input$width,
height = input$height_slide, height = input$height_slide,
dpi = 300, dpi = 300,
units = "mm", scale = 2 units = "mm",
scale = 2
) )
}) })
} }
) )
shiny::observe( shiny::observe(return(rv$plot))
return(rv$plot)
)
} }
) )
} }
@ -500,9 +502,11 @@ supported_plots <- function() {
list( list(
plot_bar_rel = list( plot_bar_rel = list(
fun = "plot_bar", fun = "plot_bar",
fun.args =list(style="fill"), fun.args = list(style = "fill"),
descr = i18n$t("Stacked relative barplot"), descr = i18n$t("Stacked relative barplot"),
note = i18n$t("Create relative stacked barplots to show the distribution of categorical levels"), note = i18n$t(
"Create relative stacked barplots to show the distribution of categorical levels"
),
primary.type = c("dichotomous", "categorical"), primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
@ -511,9 +515,11 @@ supported_plots <- function() {
), ),
plot_bar_abs = list( plot_bar_abs = list(
fun = "plot_bar", fun = "plot_bar",
fun.args =list(style="dodge"), fun.args = list(style = "dodge"),
descr = i18n$t("Side-by-side barplot"), descr = i18n$t("Side-by-side barplot"),
note = i18n$t("Create side-by-side barplot to show the distribution of categorical levels"), note = i18n$t(
"Create side-by-side barplot to show the distribution of categorical levels"
),
primary.type = c("dichotomous", "categorical"), primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
@ -523,7 +529,9 @@ supported_plots <- function() {
plot_hbars = list( plot_hbars = list(
fun = "plot_hbars", fun = "plot_hbars",
descr = i18n$t("Stacked horizontal bars"), descr = i18n$t("Stacked horizontal bars"),
note = i18n$t("A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"), note = i18n$t(
"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"
),
primary.type = c("dichotomous", "categorical"), primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
@ -533,7 +541,9 @@ supported_plots <- function() {
plot_violin = list( plot_violin = list(
fun = "plot_violin", fun = "plot_violin",
descr = i18n$t("Violin plot"), descr = i18n$t("Violin plot"),
note = i18n$t("A modern alternative to the classic boxplot to visualise data distribution"), note = i18n$t(
"A modern alternative to the classic boxplot to visualise data distribution"
),
primary.type = c("datatime", "continuous"), primary.type = c("datatime", "continuous"),
secondary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE, secondary.multi = FALSE,
@ -581,7 +591,9 @@ supported_plots <- function() {
plot_euler = list( plot_euler = list(
fun = "plot_euler", fun = "plot_euler",
descr = i18n$t("Euler diagram"), descr = i18n$t("Euler diagram"),
note = i18n$t("Generate area-proportional Euler diagrams to display set relationships"), note = i18n$t(
"Generate area-proportional Euler diagrams to display set relationships"
),
primary.type = c("dichotomous"), primary.type = c("dichotomous"),
secondary.type = c("dichotomous"), secondary.type = c("dichotomous"),
secondary.multi = TRUE, secondary.multi = TRUE,
@ -622,7 +634,7 @@ possible_plots <- function(data) {
out <- type out <- type
} else { } else {
out <- supported_plots() |> out <- supported_plots() |>
lapply(\(.x){ lapply(\(.x) {
if (type %in% .x$primary.type) { if (type %in% .x$primary.type) {
.x$descr .x$descr
} }
@ -650,12 +662,12 @@ possible_plots <- function(data) {
#' get_plot_options() #' get_plot_options()
get_plot_options <- function(data) { get_plot_options <- function(data) {
descrs <- supported_plots() |> descrs <- supported_plots() |>
lapply(\(.x){ lapply(\(.x) {
.x$descr .x$descr
}) |> }) |>
unlist() unlist()
supported_plots() |> supported_plots() |>
(\(.x){ (\(.x) {
.x[match(data, descrs)] .x[match(data, descrs)]
})() })()
} }
@ -669,6 +681,7 @@ get_plot_options <- function(data) {
#' @param sec secondary variable #' @param sec secondary variable
#' @param ter tertiary variable #' @param ter tertiary variable
#' @param type plot type (derived from possible_plots() and matches custom function) #' @param type plot type (derived from possible_plots() and matches custom function)
#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support.
#' @param ... ignored for now #' @param ... ignored for now
#' #'
#' @name data-plots #' @name data-plots
@ -678,7 +691,13 @@ get_plot_options <- function(data) {
#' #'
#' @examples #' @examples
#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() #' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
create_plot <- function(data, type, pri, sec, ter = NULL, ...) { create_plot <- function(data,
type,
pri,
sec,
ter = NULL,
color.palette = "viridis",
...) {
if (!is.null(sec)) { if (!is.null(sec)) {
if (!any(sec %in% names(data))) { if (!any(sec %in% names(data))) {
sec <- NULL sec <- NULL
@ -695,13 +714,11 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
pri = pri, pri = pri,
sec = sec, sec = sec,
ter = ter, ter = ter,
color.palette = color.palette,
... ...
) )
out <- do.call( out <- do.call(type, modifyList(parameters, list(data = data)))
type,
modifyList(parameters, list(data = data))
)
code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR")
@ -758,10 +775,14 @@ get_label <- function(data, var = NULL) {
#' @examples #' @examples
#' "Lorem ipsum... you know the routine" |> line_break() #' "Lorem ipsum... you know the routine" |> line_break()
#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) #' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
line_break <- function(data, lineLength = 20, force = FALSE) { line_break <- function(data,
lineLength = 20,
force = FALSE) {
if (isTRUE(force)) { if (isTRUE(force)) {
## This eats some letters when splitting a sentence... ?? ## This eats some letters when splitting a sentence... ??
gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"),
"\\1\n",
data)
} else { } else {
paste(strwrap(data, lineLength), collapse = "\n") paste(strwrap(data, lineLength), collapse = "\n")
} }
@ -793,9 +814,9 @@ wrap_plot_list <- function(data,
if (ggplot2::is_ggplot(data[[1]])) { if (ggplot2::is_ggplot(data[[1]])) {
if (length(data) > 1) { if (length(data) > 1) {
out <- data |> out <- data |>
(\(.x){ (\(.x) {
if (rlang::is_named(.x)) { if (rlang::is_named(.x)) {
purrr::imap(.x, \(.y, .i){ purrr::imap(.x, \(.y, .i) {
.y + ggplot2::ggtitle(.i) .y + ggplot2::ggtitle(.i)
}) })
} else { } else {
@ -803,12 +824,10 @@ wrap_plot_list <- function(data,
} }
})() |> })() |>
align_axes() |> align_axes() |>
patchwork::wrap_plots( patchwork::wrap_plots(guides = guides,
guides = guides,
axes = axes, axes = axes,
axis_titles = axis_titles, axis_titles = axis_titles,
... ...)
)
if (!is.null(tag_levels)) { if (!is.null(tag_levels)) {
out <- out + patchwork::plot_annotation(tag_levels = tag_levels) out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
} }
@ -847,7 +866,9 @@ wrap_plot_list <- function(data,
#' @returns list of ggplot2 objects #' @returns list of ggplot2 objects
#' @export #' @export
#' #'
align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { align_axes <- function(...,
x.axis = TRUE,
y.axis = TRUE) {
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
if (ggplot2::is_ggplot(..1)) { if (ggplot2::is_ggplot(..1)) {
@ -865,7 +886,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) {
xr <- clean_common_axis(p, "x") xr <- clean_common_axis(p, "x")
suppressWarnings({ suppressWarnings({
purrr::map(p, \(.x){ purrr::map(p, \(.x) {
out <- .x out <- .x
if (isTRUE(x.axis)) { if (isTRUE(x.axis)) {
out <- out + ggplot2::xlim(xr) out <- out + ggplot2::xlim(xr)
@ -889,7 +910,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) {
clean_common_axis <- function(p, axis) { clean_common_axis <- function(p, axis) {
purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |>
unlist() |> unlist() |>
(\(.x){ (\(.x) {
if (is.numeric(.x)) { if (is.numeric(.x)) {
range(.x) range(.x)
} else { } else {

237
R/generate_colors.R Normal file
View file

@ -0,0 +1,237 @@
#' Generate N Colors from a Specified Color Palette
#'
#' A flexible wrapper around multiple color palette libraries, returning N
#' colors as a character vector of hex codes. Supports palettes from
#' \pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}.
#'
#' @param n \code{integer}. Number of colors to generate. Must be a positive
#' integer.
#' @param palette \code{character(1)}. Name of the color palette to use.
#' Case-insensitive. Supported options:
#' \describe{
#' \item{\strong{viridisLite}}{`"viridis"`, `"magma"`, `"plasma"`,
#' `"inferno"`, `"cividis"`, `"mako"`, `"rocket"`, `"turbo"`}
#' \item{\strong{grDevices}}{`"hcl"`, `"rainbow"`, `"heat"`,
#' `"terrain"`, `"topo"`}
#' \item{\strong{RColorBrewer}}{Any palette name from
#' \code{RColorBrewer::brewer.pal.info}, e.g. `"Set1"`, `"Blues"`,
#' `"Dark2"`. If \code{n} exceeds the palette maximum, colors are
#' interpolated via \code{\link[grDevices]{colorRampPalette}}.}
#' }
#' @param ... Additional arguments passed to the underlying palette function.
#' For example, \code{alpha}, \code{direction}, \code{begin}, \code{end}
#' are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is
#' forwarded to \code{\link[grDevices]{hcl.colors}}.
#'
#' @return A \code{character} vector of length \code{n} containing hex color
#' codes (e.g. \code{"#440154FF"}).
#'
#' @examples
#' # viridisLite palettes
#' generate_colors(5, "viridis")
#' generate_colors(5, "plasma")
#' generate_colors(5, "viridis", alpha = 0.8, direction = -1)
#'
#' # Base R grDevices
#' generate_colors(5, "rainbow")
#' generate_colors(8, "hcl", palette = "Dark 3")
#'
#' # RColorBrewer
#' generate_colors(5, "Set1")
#' generate_colors(5, "Blues")
#' generate_colors(12, "Set1") # interpolates beyond palette max of 9
#'
#' # Drop-in replacement for viridisLite::viridis()
#' # generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis")
#'
#' @seealso
#' \code{\link[viridisLite]{viridis}},
#' \code{\link[grDevices]{hcl.colors}},
#' \code{\link[RColorBrewer]{brewer.pal}}
#'
#' @importFrom viridisLite viridis
#' @importFrom grDevices hcl.colors rainbow heat.colors terrain.colors
#' topo.colors colorRampPalette
#' @importFrom RColorBrewer brewer.pal brewer.pal.info
#'
#' @export
generate_colors <- function(n, palette = "viridis", ...) {
if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
stop("`n` must be a single positive integer.")
}
# Function passthrough — call directly with n and ...
if (is.function(palette)) {
return(palette(n, ...))
}
if (!is.character(palette) || length(palette) != 1) {
stop("`palette` must be a single character string or a function.")
}
if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
stop("`n` must be a single positive integer.")
}
if (!is.character(palette) || length(palette) != 1) {
stop("`palette` must be a single character string.")
}
palette_lower <- tolower(palette)
viridis_palettes <- c(
"viridis", "magma", "plasma", "inferno",
"cividis", "mako", "rocket", "turbo"
)
if (palette_lower %in% viridis_palettes) {
viridisLite::viridis(n = n, option = palette_lower, ...)
} else if (palette_lower == "hcl") {
grDevices::hcl.colors(n = n, ...)
} else if (palette_lower == "rainbow") {
grDevices::rainbow(n = n, ...)
} else if (palette_lower == "heat") {
grDevices::heat.colors(n = n, ...)
} else if (palette_lower == "terrain") {
grDevices::terrain.colors(n = n, ...)
} else if (palette_lower == "topo") {
grDevices::topo.colors(n = n, ...)
} else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) {
max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"]
fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal()
base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette)
grDevices::colorRampPalette(base_colors)(n)
} else if (palette %in% grDevices::palette.pals()) {
grDevices::colorRampPalette(palette.colors(palette = palette))(n)
} else if (palette %in% grDevices::hcl.pals()) {
grDevices::hcl.colors(n = n, palette = palette, ...)
} else {
message(paste0(
"Unknown palette: '", palette, "'. ",
"Falling back to default R colors.\n",
"Available options:\n",
" viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n",
" grDevices : hcl, rainbow, heat, terrain, topo\n",
" grDevices HCL: use grDevices::hcl.pals() to see all options\n",
" grDevices : use grDevices::palette.pals() to see all options\n",
" RColorBrewer : use RColorBrewer::brewer.pal.info to see all options"
))
viridisLite::viridis(n = n, option = "viridis")
# grDevices::hcl.colors(n = n)
}
}
#' Create a Continuous Color Function from a Palette
#'
#' Wraps \code{\link{generate_colors}} into a function that accepts a value
#' between 0 and 1 and returns the corresponding color. Useful for mapping
#' continuous variables to colors.
#'
#' @param palette Passed directly to [generate_colors()]. Either a palette
#' name string or a function.
#' @param n \code{integer}. Resolution of the underlying color ramp — higher
#' values give smoother gradients. Defaults to 256.
#' @param ... Additional arguments passed to [generate_colors()].
#'
#' @return A function that takes a numeric vector of values in \code{[0, 1]}
#' and returns a character vector of hex colors.
#'
#' @examples
#' pal <- continuous_colors("viridis")
#' pal(0) # first color
#' pal(1) # last color
#' pal(0.5) # midpoint
#'
#' # Map a continuous variable to colors
#' values <- seq(0, 1, length.out = 10)
#' pal(values)
#'
#' # Works with any palette generate_colors() accepts
#' pal <- continuous_colors("plasma", direction = -1)
#' pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red"))
#'
#' @seealso [generate_colors()]
#' @export
continuous_colors <- function(palette = "viridis", n = 256, ...) {
colors <- generate_colors(n, palette, ...)
ramp <- grDevices::colorRamp(colors)
function(x) {
if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].")
rgb_vals <- ramp(x)
grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255)
}
}
#' Discrete and Continuous Fill Scale Using generate_colors
#'
#' Drop-in replacement for [viridis::scale_fill_viridis()] that works with
#' any palette supported by [generate_colors()].
#'
#' @param palette Passed to [generate_colors()]. Either a palette name string
#' or a function.
#' @param discrete \code{logical}. If \code{TRUE} (default), a discrete scale
#' is returned. If \code{FALSE}, a continuous scale is returned.
#' @param ... Additional arguments passed to [ggplot2::scale_fill_manual()]
#' (discrete) or [ggplot2::scale_fill_gradientn()] (continuous).
#'
#' @examples
#' library(ggplot2)
#'
#' # Discrete
#' ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) +
#' geom_col() +
#' scale_fill_generate(palette = "Set1")
#'
#' # Continuous
#' ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) +
#' geom_point(shape = 21, size = 3) +
#' scale_fill_generate(palette = "viridis", discrete = FALSE)
#'
#' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()]
#' @export
scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
if (discrete) {
ggplot2::discrete_scale(
aesthetics = "fill",
palette = function(n) generate_colors(n, palette),
...
)
} else {
ggplot2::scale_fill_gradientn(
colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
...
)
}
}
#' @rdname scale_fill_generate
#' @examples
#' ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) +
#' geom_point() +
#' scale_color_generate(palette = "Set1")
#' @export
scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) {
if (discrete) {
ggplot2::discrete_scale(
aesthetics = "colour",
palette = function(n) generate_colors(n, palette),
...
)
} else {
ggplot2::scale_color_gradientn(
colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
...
)
}
}

12
R/plot_bar.R
View file

@ -1,4 +1,5 @@
plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), max_level = 30, ...) { plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"),
color.palette = "viridis", max_level = 30, ...) {
style <- match.arg(style) style <- match.arg(style)
if (!is.null(ter)) { if (!is.null(ter)) {
@ -13,7 +14,8 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi
pri = pri, pri = pri,
sec = sec, sec = sec,
style = style, style = style,
max_level = max_level max_level = max_level,
color.palette = color.palette
) )
}) })
@ -38,8 +40,9 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi
#' #'
#' mtcars |> #' mtcars |>
#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |>
#' plot_bar_single(pri = "cyl", style = "stack") #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo")
plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30) { plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30,
color.palette = "viridis") {
style <- match.arg(style) style <- match.arg(style)
if (identical(sec, "none")) { if (identical(sec, "none")) {
@ -98,6 +101,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "
) + ) +
ggplot2::geom_bar(position = style, stat = "identity") + ggplot2::geom_bar(position = style, stat = "identity") +
ggplot2::scale_y_continuous(labels = scales::percent) + ggplot2::scale_y_continuous(labels = scales::percent) +
scale_fill_generate(palette=color.palette) +
ggplot2::ylab("Percentage") + ggplot2::ylab("Percentage") +
ggplot2::xlab(get_label(data,pri))+ ggplot2::xlab(get_label(data,pri))+
ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill)))

12
R/plot_box.R
View file

@ -20,7 +20,7 @@
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") #' plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono")
plot_box <- function(data, pri, sec, ter = NULL,...) { plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
} else { } else {
@ -31,7 +31,8 @@ plot_box <- function(data, pri, sec, ter = NULL,...) {
plot_box_single( plot_box_single(
data = .ds, data = .ds,
pri = pri, pri = pri,
sec = sec sec = sec,
color.palette=color.palette
) )
}) })
@ -48,9 +49,10 @@ plot_box <- function(data, pri, sec, ter = NULL,...) {
#' #'
#' @examples #' @examples
#' mtcars |> plot_box_single("mpg") #' mtcars |> plot_box_single("mpg")
#' mtcars |> plot_box_single("mpg","cyl") #' mtcars |> plot_box_single("mpg","cyl",color.palette="Blues")
#' stRoke::trial |> plot_box_single("age","active",color.palette="Blues")
#' gtsummary::trial |> plot_box_single("age","trt") #' gtsummary::trial |> plot_box_single("age","trt")
plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { plot_box_single <- function(data, pri, sec=NULL, seed = 2103,color.palette="viridis") {
set.seed(seed) set.seed(seed)
if (is.null(sec)) { if (is.null(sec)) {
@ -68,7 +70,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
ggplot2::xlab(get_label(data,pri))+ ggplot2::xlab(get_label(data,pri))+
ggplot2::ylab(get_label(data,sec)) + ggplot2::ylab(get_label(data,sec)) +
ggplot2::coord_flip() + ggplot2::coord_flip() +
viridis::scale_fill_viridis(discrete = discrete, option = "D") + scale_fill_generate(discrete = discrete,palette = color.palette) +
# ggplot2::theme_void() + # ggplot2::theme_void() +
ggplot2::theme_bw(base_size = 24) + ggplot2::theme_bw(base_size = 24) +
ggplot2::theme( ggplot2::theme(

14
R/plot_euler.R
View file

@ -102,7 +102,7 @@ ggeulerr <- function(
#' plot_euler("mfi_cut", "mdi_cut") #' plot_euler("mfi_cut", "mdi_cut")
#' stRoke::trial |> #' stRoke::trial |>
#' plot_euler(pri="male", sec=c("hypertension")) #' plot_euler(pri="male", sec=c("hypertension"))
plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="viridis") {
set.seed(seed = seed) set.seed(seed = seed)
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
@ -112,7 +112,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
out <- lapply(ds, \(.x){ out <- lapply(ds, \(.x){
.x[c(pri, sec)] |> .x[c(pri, sec)] |>
na.omit() |> na.omit() |>
plot_euler_single() plot_euler_single(color.palette=color.palette)
}) })
wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")))
@ -130,16 +130,12 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
#' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), #' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
#' ) |> plot_euler_single() #' ) |> plot_euler_single()
#' mtcars[c("vs", "am")] |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma")
plot_euler_single <- function(data) { plot_euler_single <- function(data,color.palette="viridis") {
# if (any("categorical" %in% data_type(data))){
# shape <- "ellipse"
# } else {
# shape <- "circle"
# }
data |> data |>
ggeulerr(shape = "circle") + ggeulerr(shape = "circle") +
scale_fill_generate(palette=color.palette) +
ggplot2::theme_void() + ggplot2::theme_void() +
ggplot2::theme( ggplot2::theme(
legend.position = "none", legend.position = "none",

42
R/plot_hbar.R
View file

@ -8,11 +8,21 @@
#' @examples #' @examples
#' mtcars |> plot_hbars(pri = "carb", sec = "cyl") #' mtcars |> plot_hbars(pri = "carb", sec = "cyl")
#' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
#' mtcars |> plot_hbars(pri = "carb", sec = NULL) #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues")
plot_hbars <- function(data, pri, sec, ter = NULL) { #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma")
out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis")
plot_hbars <- function(data,
out pri,
sec,
ter = NULL,
color.palette = "viridis") {
vertical_stacked_bars(
data = data,
score = pri,
group = sec,
strata = ter,
color.palette = color.palette
)
} }
@ -35,7 +45,9 @@ vertical_stacked_bars <- function(data,
l.color = "black", l.color = "black",
l.size = .5, l.size = .5,
draw.lines = TRUE, draw.lines = TRUE,
label.str="{n}\n{round(100 * p,0)}%") { label.str = "{n}\n{round(100 * p,0)}%",
color.palette = "viridis",
reverse = TRUE) {
if (is.null(group)) { if (is.null(group)) {
df.table <- data[c(score, group, strata)] |> df.table <- data[c(score, group, strata)] |>
dplyr::mutate("All" = 1) |> dplyr::mutate("All" = 1) |>
@ -60,15 +72,19 @@ vertical_stacked_bars <- function(data,
returnData = TRUE returnData = TRUE
) )
colors <- viridisLite::viridis(nrow(df.table)) colors <- generate_colors(n = nrow(df.table), palette = color.palette)
## Colors are reversed by default as that usually gives the best result
if (isTRUE(reverse)) {
colors <- rev(colors)
}
contrast_cut <- contrast_cut <-
sum(contrast_text(colors, threshold = .3) == "white") contrast_text(colors, threshold = .3) == "white"
score_label <- data |> get_label(var = score) score_label <- data |> get_label(var = score)
group_label <- data |> get_label(var = group) group_label <- data |> get_label(var = group)
p |> p |>
(\(.x){ (\(.x) {
.x$plot + .x$plot +
ggplot2::geom_text( ggplot2::geom_text(
data = .x$rectData[which(.x$rectData$n > data = .x$rectData[which(.x$rectData$n >
@ -78,20 +94,18 @@ vertical_stacked_bars <- function(data,
ggplot2::aes( ggplot2::aes(
x = group, x = group,
y = p_prev + 0.49 * p, y = p_prev + 0.49 * p,
color = as.numeric(score) > contrast_cut, color = contrast_cut,
# label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = paste0(sprintf("%2.0f", 100 * p),"%"),
# label = sprintf("%2.0f", 100 * p) # label = sprintf("%2.0f", 100 * p)
label = glue::glue(label.str) label = glue::glue(label.str)
) )
) + ) +
ggplot2::labs(fill = score_label) + ggplot2::labs(fill = score_label) +
ggplot2::scale_fill_manual(values = rev(colors)) + ggplot2::scale_fill_manual(values = colors) +
ggplot2::theme( ggplot2::theme(legend.position = "bottom",
legend.position = "bottom",
axis.title = ggplot2::element_text(), axis.title = ggplot2::element_text(),
) + ) +
ggplot2::xlab(group_label) + ggplot2::xlab(group_label) +
ggplot2::ylab(NULL) ggplot2::ylab(NULL)
# viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D")
})() })()
} }

3
R/plot_ridge.R
View file

@ -10,7 +10,7 @@
#' default_parsing() |> #' default_parsing() |>
#' plot_ridge(x = "mpg", y = "cyl") #' plot_ridge(x = "mpg", y = "cyl")
#' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") #' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear")
plot_ridge <- function(data, x, y, z = NULL, ...) { plot_ridge <- function(data, x, y, z = NULL, color.palette="viridis", ...) {
if (!is.null(z)) { if (!is.null(z)) {
ds <- split(data, data[z]) ds <- split(data, data[z])
} else { } else {
@ -21,6 +21,7 @@ plot_ridge <- function(data, x, y, z = NULL, ...) {
ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) + ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) +
ggridges::geom_density_ridges() + ggridges::geom_density_ridges() +
ggridges::theme_ridges() + ggridges::theme_ridges() +
scale_fill_generate(palette=color.palette) +
ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa() ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa()
}) })

112
R/plot_sankey.R
View file

@ -19,7 +19,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
## TODO: Ensure ordering x and y ## TODO: Ensure ordering x and y
## Ensure all are factors ## Ensure all are factors
data[c(pri, sec)] <- data[c(pri, sec)] |> data <- data[c(pri, sec)] |>
dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE) out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE)
@ -84,16 +84,17 @@ str_remove_last <- function(data, pattern = "\n") {
#' ## Dont know why... #' ## Dont know why...
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey("cyl", "gear", "vs", color.group = "pri") #' plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno")
#'
#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
#' # stRoke::trial |> plot_sankey("active", "male")
plot_sankey <- function(data, plot_sankey <- function(data,
pri, pri,
sec, sec,
ter = NULL, ter = NULL,
color.group = "pri", color.group = "pri",
colors = NULL, colors = NULL,
color.palette = "viridis",
default.color = "#2986cc",
box.color = "#1E4B66",
na.color = "grey80",
missing.level = "Missing") { missing.level = "Missing") {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
@ -101,12 +102,14 @@ plot_sankey <- function(data,
ds <- list(data) ds <- list(data)
} }
# browser()
out <- lapply(ds, \(.ds) { out <- lapply(ds, \(.ds) {
plot_sankey_single( plot_sankey_single(
.ds, .ds,
pri = pri, pri = pri,
sec = sec, sec = sec,
color.palette = color.palette,
color.group = color.group, color.group = color.group,
colors = colors, colors = colors,
missing.level = missing.level missing.level = missing.level
@ -144,12 +147,22 @@ plot_sankey <- function(data,
#' stRoke::trial |> #' stRoke::trial |>
#' default_parsing() |> #' default_parsing() |>
#' plot_sankey_single("diabetes", "hypertension") #' plot_sankey_single("diabetes", "hypertension")
#'
#'
#' # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma")
#' # stRoke::trial |> plot_sankey_single("active", "male")
#' # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec")
#' # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo")
plot_sankey_single <- function(data, plot_sankey_single <- function(data,
pri, pri,
sec, sec,
color.group = c("pri", "sec"), color.group = c("pri", "sec"),
colors = NULL, color.palette = "viridis",
colors=NULL,
missing.level = "Missing", missing.level = "Missing",
default.color = "#2986cc",
box.color = "#1E4B66",
na.color = "grey80",
...) { ...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
@ -157,53 +170,35 @@ plot_sankey_single <- function(data,
data[c(pri, sec)] <- with_labels(data,{ data[c(pri, sec)] <- with_labels(data,{
data[c(pri, sec)] |> data[c(pri, sec)] |>
dplyr::mutate( to_clean_levels() |>
dplyr::across(dplyr::where(is.logical), as.factor), missing_to_text_levels(missing.text=missing.level)
dplyr::across(dplyr::where(is.factor), forcats::fct_drop),
dplyr::across(dplyr::where(is.factor), \(.x) {
if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.level) else .x
}) })
)
})
## Aggregate data ## Aggregate data
data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...) data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...)
na.color <- "#2986cc" default.color = default.color
box.color <- "#1E4B66" box.color = box.color
na.color = na.color
if (is.null(colors)) { if (is.null(colors)) {
if (color.group == "sec") { if (color.group == "sec") {
if (anyNA(data_orig[[sec]])){ main.colors <- color_levels_gen(data_orig[[sec]],palette=color.palette)
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]])))
} else {
main.colors <- viridisLite::viridis(n = length(levels(data[[sec]])))
}
## Only keep colors for included levels
main.colors <- main.colors[match(levels(data[[sec]]), levels(data[[sec]]))]
secondary.colors <- rep(na.color, length(levels(data[[pri]]))) secondary.colors <- rep(default.color, length(levels(data[[pri]])))
label.colors <- Reduce(c, lapply(list( label.colors <- Reduce(c, lapply(list(
secondary.colors, rev(main.colors) secondary.colors, rev(main.colors)
), contrast_text)) ), contrast_text))
} else { } else {
if (anyNA(data_orig[[sec]])){ main.colors <- color_levels_gen(data_orig[[pri]],palette=color.palette)
main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]])))
} else {
main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
}
# main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
## Only keep colors for included levels
main.colors <- main.colors[match(levels(data[[pri]]), levels(data[[pri]]))]
secondary.colors <- rep(na.color, length(levels(data[[sec]]))) secondary.colors <- rep(default.color, length(levels(data[[sec]])))
label.colors <- Reduce(c, lapply(list( label.colors <- Reduce(c, lapply(list(
rev(main.colors), secondary.colors rev(main.colors), secondary.colors
), contrast_text)) ), contrast_text))
} }
colors <- c(na.color, main.colors, secondary.colors) colors <- c(default.color, main.colors, secondary.colors)
colors[is.na(colors)] <- "grey80" colors[is.na(colors)] <- na.color
} else { } else {
label.colors <- contrast_text(colors) label.colors <- contrast_text(colors)
} }
@ -212,8 +207,6 @@ plot_sankey_single <- function(data,
sapply(line_break) |> sapply(line_break) |>
unname() unname()
# browser()
p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
if (color.group == "sec") { if (color.group == "sec") {
@ -275,3 +268,48 @@ plot_sankey_single <- function(data,
panel.border = ggplot2::element_blank() panel.border = ggplot2::element_blank()
) )
} }
# stRoke::trial["male"] |> to_clean_levels()
to_clean_levels <- function(data,missing.text="Missing"){
if (is.data.frame(data)){
data |>
lapply(all_levels_clean) |>
dplyr::bind_cols()
} else {
data |>
all_levels_clean()
}
}
# stRoke::trial["mrs_1"] |> missing_to_text_levels()
missing_to_text_levels <- function(data,missing.text="Missing"){
data |>
dplyr::mutate(
dplyr::across(dplyr::where(is.factor), \(.x) {
if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.text) else .x
})
)
}
all_levels_clean <- function(data){
data |>
(\(.x){
if (is.logical(.x)) as.factor(.x) else .x
})() |>
(\(.x){
if (is.factor(.x)) forcats::fct_drop(.x) else .x
})()
}
# stRoke::trial$mrs_1 |> color_levels_gen()
color_levels_gen <- function(data,na.color="grey80",palette="viridis"){
out <- generate_colors(n = length(levels(to_clean_levels(data))),palette = palette)
if (anyNA(data)){
out <- c(out,na.color)
}
out
}

6
R/plot_scatter.R
View file

@ -7,7 +7,8 @@
#' #'
#' @examples #' @examples
#' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt")
plot_scatter <- function(data, pri, sec, ter = NULL) { #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb")
plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") {
if (is.null(ter)) { if (is.null(ter)) {
rempsyc::nice_scatter( rempsyc::nice_scatter(
data = data, data = data,
@ -24,6 +25,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL) {
group = ter, group = ter,
xtitle = get_label(data, var = sec), xtitle = get_label(data, var = sec),
ytitle = get_label(data, var = pri) ytitle = get_label(data, var = pri)
) )+
scale_color_generate(palette=color.palette)
} }
} }

10
R/plot_violin.R
View file

@ -1,4 +1,4 @@
#' Beatiful violin plot #' Beautiful violin plot
#' #'
#' @returns ggplot2 object #' @returns ggplot2 object
#' @export #' @export
@ -6,8 +6,9 @@
#' @name data-plots #' @name data-plots
#' #'
#' @examples #' @examples
#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl")
plot_violin <- function(data, pri, sec, ter = NULL) { #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues")
plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") {
if (!is.null(ter)) { if (!is.null(ter)) {
ds <- split(data, data[ter]) ds <- split(data, data[ter])
} else { } else {
@ -23,7 +24,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) {
response = pri, response = pri,
xtitle = get_label(data, var = sec), xtitle = get_label(data, var = sec),
ytitle = get_label(data, var = pri) ytitle = get_label(data, var = pri)
) )+
scale_fill_generate(palette=color.palette)
}) })
wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")))

72
man/colorSelectInput.Rd Normal file
View file

@ -0,0 +1,72 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/custom_SelectInput.R
\name{colorSelectInput}
\alias{colorSelectInput}
\title{A selectizeInput customized for named vectors of color names supported by
\code{\link{generate_colors}}}
\usage{
colorSelectInput(
inputId,
label,
choices,
selected = "",
previews = 4,
...,
placeholder = ""
)
}
\arguments{
\item{inputId}{passed to \code{\link[shiny]{selectizeInput}}}
\item{label}{passed to \code{\link[shiny]{selectizeInput}}}
\item{choices}{A named \code{vector} from which fields should be populated}
\item{selected}{default selection}
\item{previews}{number of preview colors. Default is 4.}
\item{...}{passed to \code{\link[shiny]{selectizeInput}}}
\item{placeholder}{passed to \code{\link[shiny]{selectizeInput}} options}
\item{onInitialize}{passed to \code{\link[shiny]{selectizeInput}} options}
}
\value{
a \code{\link[shiny]{selectizeInput}} dropdown element
}
\description{
A selectizeInput customized for named vectors of color names supported by
\code{\link{generate_colors}}
}
\examples{
if (shiny::interactive()) {
top_palettes <- c(
"Perceptual (blue-yellow)" = "viridis",
"Perceptual (fire)" = "plasma",
"Colour-blind friendly" = "Okabe-Ito",
"Qualitative (bold)" = "Dark 2",
"Qualitative (paired)" = "Paired",
"Sequential (blues)" = "Blues",
"Diverging (red-blue)" = "RdBu",
"Tableau style" = "Tableau 10",
"Pastel" = "Pastel 1",
"Rainbow" = "rainbow"
)
shinyApp(
ui = fluidPage(
titlePanel("Color Palette Select Test"),
colorSelectInput(
inputId = "palette",
label = "Color palette",
choices = top_palettes,
selected = "viridis"
),
verbatimTextOutput("selected")
),
server = function(input, output, session) {
output$selected <- renderPrint(input$palette)
}
)
}
}

44
man/continuous_colors.Rd Normal file
View file

@ -0,0 +1,44 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/generate_colors.R
\name{continuous_colors}
\alias{continuous_colors}
\title{Create a Continuous Color Function from a Palette}
\usage{
continuous_colors(palette = "viridis", n = 256, ...)
}
\arguments{
\item{palette}{Passed directly to \code{\link[=generate_colors]{generate_colors()}}. Either a palette
name string or a function.}
\item{n}{\code{integer}. Resolution of the underlying color ramp — higher
values give smoother gradients. Defaults to 256.}
\item{...}{Additional arguments passed to \code{\link[=generate_colors]{generate_colors()}}.}
}
\value{
A function that takes a numeric vector of values in \code{[0, 1]}
and returns a character vector of hex colors.
}
\description{
Wraps \code{\link{generate_colors}} into a function that accepts a value
between 0 and 1 and returns the corresponding color. Useful for mapping
continuous variables to colors.
}
\examples{
pal <- continuous_colors("viridis")
pal(0) # first color
pal(1) # last color
pal(0.5) # midpoint
# Map a continuous variable to colors
values <- seq(0, 1, length.out = 10)
pal(values)
# Works with any palette generate_colors() accepts
pal <- continuous_colors("plasma", direction = -1)
pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red"))
}
\seealso{
\code{\link[=generate_colors]{generate_colors()}}
}

53
man/data-plots.Rd
View file

@ -20,25 +20,35 @@
\usage{ \usage{
data_visuals_ui(id, tab_title = "Plots", ...) data_visuals_ui(id, tab_title = "Plots", ...)
data_visuals_server(id, data, ...) data_visuals_server(
id,
data,
palettes = c(`Perceptual (blue-yellow)` = "viridis", `Perceptual (fire)` = "plasma",
`Colour-blind friendly` = "Okabe-Ito", `Qualitative (bold)` = "Dark 2",
`Qualitative (paired)` = "Paired", `Sequential (blues)` = "Blues",
`Diverging (red-blue)` = "RdBu", `Tableau style` = "Tableau 10", Pastel = "Pastel 1",
Rainbow = "rainbow"),
...
)
create_plot(data, type, pri, sec, ter = NULL, ...) create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...)
plot_bar_single( plot_bar_single(
data, data,
pri, pri,
sec = NULL, sec = NULL,
style = c("stack", "dodge", "fill"), style = c("stack", "dodge", "fill"),
max_level = 30 max_level = 30,
color.palette = "viridis"
) )
plot_box(data, pri, sec, ter = NULL, ...) plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...)
plot_box_single(data, pri, sec = NULL, seed = 2103) plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis")
plot_hbars(data, pri, sec, ter = NULL) plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis")
plot_ridge(data, x, y, z = NULL, ...) plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...)
sankey_ready(data, pri, sec, numbers = "count", ...) sankey_ready(data, pri, sec, numbers = "count", ...)
@ -49,12 +59,16 @@ plot_sankey(
ter = NULL, ter = NULL,
color.group = "pri", color.group = "pri",
colors = NULL, colors = NULL,
color.palette = "viridis",
default.color = "#2986cc",
box.color = "#1E4B66",
na.color = "grey80",
missing.level = "Missing" missing.level = "Missing"
) )
plot_scatter(data, pri, sec, ter = NULL) plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis")
plot_violin(data, pri, sec, ter = NULL) plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis")
} }
\arguments{ \arguments{
\item{id}{Module id. (Use 'ns("id")')} \item{id}{Module id. (Use 'ns("id")')}
@ -71,6 +85,8 @@ plot_violin(data, pri, sec, ter = NULL)
\item{ter}{tertiary variable} \item{ter}{tertiary variable}
\item{color.palette}{choose color palette. See \code{\link{plot_colors}} for support.}
\item{style}{barplot style passed to geom_bar position argument. \item{style}{barplot style passed to geom_bar position argument.
One of c("stack", "dodge", "fill")} One of c("stack", "dodge", "fill")}
} }
@ -120,7 +136,7 @@ Beautiful sankey plot with option to split by a tertiary group
Beautiful violin plot Beautiful violin plot
Beatiful violin plot Beautiful violin plot
} }
\examples{ \examples{
create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
@ -130,7 +146,7 @@ mtcars |>
mtcars |> mtcars |>
dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> dplyr::mutate(cyl = factor(cyl), am = factor(am)) |>
plot_bar_single(pri = "cyl", style = "stack") plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo")
mtcars |> plot_box(pri = "mpg", sec = "gear") mtcars |> plot_box(pri = "mpg", sec = "gear")
mtcars |> plot_box(pri = "mpg", sec="cyl") mtcars |> plot_box(pri = "mpg", sec="cyl")
mtcars |> mtcars |>
@ -140,11 +156,14 @@ mtcars |>
default_parsing() |> default_parsing() |>
plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono")
mtcars |> plot_box_single("mpg") mtcars |> plot_box_single("mpg")
mtcars |> plot_box_single("mpg","cyl") mtcars |> plot_box_single("mpg","cyl",color.palette="Blues")
stRoke::trial |> plot_box_single("age","active",color.palette="Blues")
gtsummary::trial |> plot_box_single("age","trt") gtsummary::trial |> plot_box_single("age","trt")
mtcars |> plot_hbars(pri = "carb", sec = "cyl") mtcars |> plot_hbars(pri = "carb", sec = "cyl")
mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
mtcars |> plot_hbars(pri = "carb", sec = NULL) mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues")
mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma")
mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis")
mtcars |> mtcars |>
default_parsing() |> default_parsing() |>
plot_ridge(x = "mpg", y = "cyl") plot_ridge(x = "mpg", y = "cyl")
@ -169,9 +188,9 @@ mtcars |>
## Dont know why... ## Dont know why...
mtcars |> mtcars |>
default_parsing() |> default_parsing() |>
plot_sankey("cyl", "gear", "vs", color.group = "pri") plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno")
# stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
mtcars |> plot_scatter(pri = "mpg", sec = "wt") mtcars |> plot_scatter(pri = "mpg", sec = "wt")
mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb")
mtcars |> plot_violin(pri = "mpg", sec = "cyl")
mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues")
} }

63
man/generate_colors.Rd Normal file
View file

@ -0,0 +1,63 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/generate_colors.R
\name{generate_colors}
\alias{generate_colors}
\title{Generate N Colors from a Specified Color Palette}
\usage{
generate_colors(n, palette = "viridis", ...)
}
\arguments{
\item{n}{\code{integer}. Number of colors to generate. Must be a positive
integer.}
\item{palette}{\code{character(1)}. Name of the color palette to use.
Case-insensitive. Supported options:
\describe{
\item{\strong{viridisLite}}{\code{"viridis"}, \code{"magma"}, \code{"plasma"},
\code{"inferno"}, \code{"cividis"}, \code{"mako"}, \code{"rocket"}, \code{"turbo"}}
\item{\strong{grDevices}}{\code{"hcl"}, \code{"rainbow"}, \code{"heat"},
\code{"terrain"}, \code{"topo"}}
\item{\strong{RColorBrewer}}{Any palette name from
\code{RColorBrewer::brewer.pal.info}, e.g. \code{"Set1"}, \code{"Blues"},
\code{"Dark2"}. If \code{n} exceeds the palette maximum, colors are
interpolated via \code{\link[grDevices]{colorRampPalette}}.}
}}
\item{...}{Additional arguments passed to the underlying palette function.
For example, \code{alpha}, \code{direction}, \code{begin}, \code{end}
are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is
forwarded to \code{\link[grDevices]{hcl.colors}}.}
}
\value{
A \code{character} vector of length \code{n} containing hex color
codes (e.g. \code{"#440154FF"}).
}
\description{
A flexible wrapper around multiple color palette libraries, returning N
colors as a character vector of hex codes. Supports palettes from
\pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}.
}
\examples{
# viridisLite palettes
generate_colors(5, "viridis")
generate_colors(5, "plasma")
generate_colors(5, "viridis", alpha = 0.8, direction = -1)
# Base R grDevices
generate_colors(5, "rainbow")
generate_colors(8, "hcl", palette = "Dark 3")
# RColorBrewer
generate_colors(5, "Set1")
generate_colors(5, "Blues")
generate_colors(12, "Set1") # interpolates beyond palette max of 9
# Drop-in replacement for viridisLite::viridis()
# generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis")
}
\seealso{
\code{\link[viridisLite]{viridis}},
\code{\link[grDevices]{hcl.colors}},
\code{\link[RColorBrewer]{brewer.pal}}
}

2
man/plot_euler.Rd
View file

@ -4,7 +4,7 @@
\alias{plot_euler} \alias{plot_euler}
\title{Easily plot euler diagrams} \title{Easily plot euler diagrams}
\usage{ \usage{
plot_euler(data, pri, sec, ter = NULL, seed = 2103) plot_euler(data, pri, sec, ter = NULL, seed = 2103, color.palette = "viridis")
} }
\arguments{ \arguments{
\item{data}{data} \item{data}{data}

4
man/plot_euler_single.Rd
View file

@ -4,7 +4,7 @@
\alias{plot_euler_single} \alias{plot_euler_single}
\title{Easily plot single euler diagrams} \title{Easily plot single euler diagrams}
\usage{ \usage{
plot_euler_single(data) plot_euler_single(data, color.palette = "viridis")
} }
\value{ \value{
ggplot2 object ggplot2 object
@ -19,5 +19,5 @@ data.frame(
C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
) |> plot_euler_single() ) |> plot_euler_single()
mtcars[c("vs", "am")] |> plot_euler_single() mtcars[c("vs", "am")] |> plot_euler_single("magma")
} }

10
man/plot_sankey_single.Rd
View file

@ -9,8 +9,12 @@ plot_sankey_single(
pri, pri,
sec, sec,
color.group = c("pri", "sec"), color.group = c("pri", "sec"),
color.palette = "viridis",
colors = NULL, colors = NULL,
missing.level = "Missing", missing.level = "Missing",
default.color = "#2986cc",
box.color = "#1E4B66",
na.color = "grey80",
... ...
) )
} }
@ -44,4 +48,10 @@ mtcars |>
stRoke::trial |> stRoke::trial |>
default_parsing() |> default_parsing() |>
plot_sankey_single("diabetes", "hypertension") plot_sankey_single("diabetes", "hypertension")
# stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma")
# stRoke::trial |> plot_sankey_single("active", "male")
# stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec")
# stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo")
} }

45
man/scale_fill_generate.Rd Normal file
View file

@ -0,0 +1,45 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/generate_colors.R
\name{scale_fill_generate}
\alias{scale_fill_generate}
\alias{scale_color_generate}
\title{Discrete and Continuous Fill Scale Using generate_colors}
\usage{
scale_fill_generate(palette = "viridis", discrete = TRUE, ...)
scale_color_generate(palette = "viridis", discrete = TRUE, ...)
}
\arguments{
\item{palette}{Passed to \code{\link[=generate_colors]{generate_colors()}}. Either a palette name string
or a function.}
\item{discrete}{\code{logical}. If \code{TRUE} (default), a discrete scale
is returned. If \code{FALSE}, a continuous scale is returned.}
\item{...}{Additional arguments passed to \code{\link[ggplot2:scale_manual]{ggplot2::scale_fill_manual()}}
(discrete) or \code{\link[ggplot2:scale_gradient]{ggplot2::scale_fill_gradientn()}} (continuous).}
}
\description{
Drop-in replacement for \code{\link[viridis:scale_viridis]{viridis::scale_fill_viridis()}} that works with
any palette supported by \code{\link[=generate_colors]{generate_colors()}}.
}
\examples{
library(ggplot2)
# Discrete
ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) +
geom_col() +
scale_fill_generate(palette = "Set1")
# Continuous
ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) +
geom_point(shape = 21, size = 3) +
scale_fill_generate(palette = "viridis", discrete = FALSE)
ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) +
geom_point() +
scale_color_generate(palette = "Set1")
}
\seealso{
\code{\link[=scale_color_generate]{scale_color_generate()}}, \code{\link[=generate_colors]{generate_colors()}}, \code{\link[=continuous_colors]{continuous_colors()}}
}

4
man/vertical_stacked_bars.Rd
View file

@ -13,7 +13,9 @@ vertical_stacked_bars(
l.color = "black", l.color = "black",
l.size = 0.5, l.size = 0.5,
draw.lines = TRUE, draw.lines = TRUE,
label.str = "{n}\\n{round(100 * p,0)}\%" label.str = "{n}\\n{round(100 * p,0)}\%",
color.palette = "viridis",
reverse = TRUE
) )
} }
\arguments{ \arguments{

146
tests/testthat/test-plot_colors.R Normal file
View file

@ -0,0 +1,146 @@
library(testthat)
# ── Helpers ───────────────────────────────────────────────────────────────────
is_hex_color <- function(x) {
all(grepl("^#[0-9A-Fa-f]{6}([0-9A-Fa-f]{2})?$", x))
}
# ── Input validation ──────────────────────────────────────────────────────────
test_that("n must be a single positive integer", {
expect_error(generate_colors(0), "`n` must be a single positive integer")
expect_error(generate_colors(-1), "`n` must be a single positive integer")
expect_error(generate_colors(1.5), "`n` must be a single positive integer")
expect_error(generate_colors(c(2, 3)), "`n` must be a single positive integer")
expect_error(generate_colors("5"), "`n` must be a single positive integer")
})
test_that("palette must be a single character string or function", {
expect_error(generate_colors(5, 123), "`palette` must be a single character string")
expect_error(generate_colors(5, c("a", "b")), "`palette` must be a single character string")
})
test_that("unknown palette falls back to hcl.colors with a message", {
expect_message(
result <- generate_colors(5, "notapalette"),
"Unknown palette: 'notapalette'"
)
expect_equal(length(result), 5)
expect_true(is_hex_color(result))
})
# ── Return type and length ────────────────────────────────────────────────────
test_that("output is a character vector of correct length for each palette family", {
palettes <- c("viridis", "plasma", "rainbow", "heat", "terrain", "topo", "Set1", "Blues")
for (pal in palettes) {
result <- generate_colors(5, pal)
expect_true(is.character(result), label = paste0("is.character [", pal, "]"))
expect_equal(length(result), 5, label = paste0("length == 5 [", pal, "]"))
}
})
test_that("output colors are valid hex codes", {
palettes <- c("viridis", "magma", "rainbow", "hcl", "Set1", "Blues")
for (pal in palettes) {
result <- generate_colors(5, pal)
expect_true(is_hex_color(result), label = paste0("hex check [", pal, "]"))
}
})
test_that("n = 1 works for all palette families", {
expect_equal(length(generate_colors(1, "viridis")), 1)
expect_equal(length(generate_colors(1, "rainbow")), 1)
expect_equal(length(generate_colors(1, "Set1")), 1)
})
# ── viridisLite ───────────────────────────────────────────────────────────────
test_that("all viridisLite palettes return correct length", {
viridis_palettes <- c("viridis", "magma", "plasma", "inferno",
"cividis", "mako", "rocket", "turbo")
for (pal in viridis_palettes) {
expect_equal(length(generate_colors(6, pal)), 6, label = paste0("length [", pal, "]"))
}
})
test_that("viridisLite palette names are case-insensitive", {
expect_equal(generate_colors(5, "VIRIDIS"), generate_colors(5, "viridis"))
expect_equal(generate_colors(5, "Plasma"), generate_colors(5, "plasma"))
})
test_that("extra args are forwarded to viridisLite (direction)", {
fwd <- generate_colors(5, "viridis", direction = 1)
rev <- generate_colors(5, "viridis", direction = -1)
expect_false(identical(fwd, rev))
})
# ── grDevices ─────────────────────────────────────────────────────────────────
test_that("grDevices palettes return correct length", {
for (pal in c("hcl", "rainbow", "heat", "terrain", "topo")) {
expect_equal(length(generate_colors(7, pal)), 7, label = paste0("length [", pal, "]"))
}
})
test_that("grDevices palette names are case-insensitive", {
expect_equal(generate_colors(5, "Rainbow"), generate_colors(5, "rainbow"))
expect_equal(generate_colors(5, "HEAT"), generate_colors(5, "heat"))
})
# ── RColorBrewer ──────────────────────────────────────────────────────────────
test_that("RColorBrewer returns exactly n colors for any n >= 1", {
expect_equal(length(generate_colors(1, "Set1")), 1) # below brewer min, slices
expect_equal(length(generate_colors(2, "Set1")), 2) # below brewer min, slices
expect_equal(length(generate_colors(3, "Set1")), 3) # at brewer min
expect_equal(length(generate_colors(9, "Set1")), 9) # at brewer max
expect_equal(length(generate_colors(15, "Set1")), 15) # above brewer max, interpolates
})
test_that("RColorBrewer n < 3 does not warn or error", {
expect_no_warning(generate_colors(1, "Set1"))
expect_no_warning(generate_colors(2, "Blues"))
})
test_that("RColorBrewer output is valid hex for all n", {
expect_true(is_hex_color(generate_colors(1, "Blues")))
expect_true(is_hex_color(generate_colors(9, "Blues")))
expect_true(is_hex_color(generate_colors(20, "Blues")))
})
test_that("RColorBrewer sequential and diverging palettes work", {
expect_equal(length(generate_colors(5, "Blues")), 5)
expect_equal(length(generate_colors(5, "RdBu")), 5)
})
# ── Function passthrough ──────────────────────────────────────────────────────
test_that("palette accepts a function directly", {
result <- generate_colors(5, viridisLite::viridis)
expect_equal(length(result), 5)
expect_true(is_hex_color(result))
})
test_that("palette accepts an anonymous function", {
result <- generate_colors(5, \(n) rep("#FF0000FF", n))
expect_equal(result, rep("#FF0000FF", 5))
})
test_that("error message mentions function as valid input type", {
expect_error(generate_colors(5, 123), "single character string or a function")
})
# ── Fallback ──────────────────────────────────────────────────────────────────
test_that("fallback message includes available options", {
expect_message(generate_colors(5, "notapalette"), "viridisLite")
expect_message(generate_colors(5, "notapalette"), "RColorBrewer")
})
test_that("fallback returns correct length and valid hex colors", {
result <- suppressMessages(generate_colors(8, "notapalette"))
expect_equal(length(result), 8)
expect_true(is_hex_color(result))
})