mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
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.
This commit is contained in:
parent
2d062e0ac5
commit
6c850847b7
21 changed files with 1110 additions and 251 deletions
|
|
@ -20,30 +20,36 @@
|
|||
#' @importFrom shiny selectizeInput
|
||||
#' @export
|
||||
#'
|
||||
columnSelectInput <- function(
|
||||
inputId,
|
||||
label,
|
||||
data,
|
||||
selected = "",
|
||||
...,
|
||||
col_subset = NULL,
|
||||
placeholder = "",
|
||||
onInitialize,
|
||||
none_label = "No variable selected",
|
||||
maxItems = NULL
|
||||
) {
|
||||
datar <- if (is.reactive(data)) data else reactive(data)
|
||||
col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset)
|
||||
columnSelectInput <- function(inputId,
|
||||
label,
|
||||
data,
|
||||
selected = "",
|
||||
...,
|
||||
col_subset = NULL,
|
||||
placeholder = "",
|
||||
onInitialize,
|
||||
none_label = "No variable selected",
|
||||
maxItems = NULL) {
|
||||
datar <- if (is.reactive(data))
|
||||
data
|
||||
else
|
||||
reactive(data)
|
||||
col_subsetr <- if (is.reactive(col_subset))
|
||||
col_subset
|
||||
else
|
||||
reactive(col_subset)
|
||||
|
||||
labels <- Map(function(col) {
|
||||
json <- sprintf(
|
||||
IDEAFilter:::strip_leading_ws('
|
||||
IDEAFilter:::strip_leading_ws(
|
||||
'
|
||||
{
|
||||
"name": "%s",
|
||||
"label": "%s",
|
||||
"dataclass": "%s",
|
||||
"datatype": "%s"
|
||||
}'),
|
||||
}'
|
||||
),
|
||||
col,
|
||||
attr(datar()[[col]], "label") %||% "",
|
||||
IDEAFilter:::get_dataFilter_class(datar()[[col]]),
|
||||
|
|
@ -52,12 +58,25 @@ columnSelectInput <- function(
|
|||
}, col = 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 <- 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 {
|
||||
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(
|
||||
|
|
@ -66,8 +85,9 @@ columnSelectInput <- function(
|
|||
choices = choices,
|
||||
selected = selected,
|
||||
...,
|
||||
options = c(
|
||||
list(render = I("{
|
||||
options = c(list(
|
||||
render = I(
|
||||
"{
|
||||
// format the way that options are rendered
|
||||
option: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
|
|
@ -95,9 +115,10 @@ columnSelectInput <- function(
|
|||
escape(item.data.name) +
|
||||
'</div>';
|
||||
}
|
||||
}")),
|
||||
if (!is.null(maxItems)) list(maxItems = maxItems)
|
||||
)
|
||||
}"
|
||||
)
|
||||
), if (!is.null(maxItems))
|
||||
list(maxItems = maxItems))
|
||||
)
|
||||
}
|
||||
|
||||
|
|
@ -150,7 +171,10 @@ vectorSelectInput <- function(inputId,
|
|||
...,
|
||||
placeholder = "",
|
||||
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(
|
||||
IDEAFilter:::strip_leading_ws('
|
||||
|
|
@ -170,8 +194,9 @@ vectorSelectInput <- function(inputId,
|
|||
choices = choices_new,
|
||||
selected = selected,
|
||||
...,
|
||||
options = c(
|
||||
list(render = I("{
|
||||
options = c(list(
|
||||
render = I(
|
||||
"{
|
||||
// format the way that options are rendered
|
||||
option: function(item, escape) {
|
||||
item.data = JSON.parse(item.label);
|
||||
|
|
@ -190,7 +215,123 @@ vectorSelectInput <- function(inputId,
|
|||
escape(item.data.name) +
|
||||
'</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>';
|
||||
}
|
||||
}"
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
|
|
|||
265
R/data_plots.R
265
R/data_plots.R
|
|
@ -22,11 +22,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
title = "Create plot",
|
||||
icon = bsicons::bs_icon("graph-up"),
|
||||
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::uiOutput(outputId = ns("type")),
|
||||
shiny::uiOutput(outputId = ns("secondary")),
|
||||
shiny::uiOutput(outputId = ns("tertiary")),
|
||||
shiny::uiOutput(outputId = ns("color_palette")),
|
||||
shiny::br(),
|
||||
shiny::actionButton(
|
||||
inputId = ns("act_plot"),
|
||||
|
|
@ -72,14 +77,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
shiny::selectInput(
|
||||
inputId = ns("plot_type"),
|
||||
label = i18n$t("File format"),
|
||||
choices = list(
|
||||
"png",
|
||||
"tiff",
|
||||
"eps",
|
||||
"pdf",
|
||||
"jpeg",
|
||||
"svg"
|
||||
)
|
||||
choices = list("png", "tiff", "eps", "pdf", "jpeg", "svg")
|
||||
),
|
||||
shiny::br(),
|
||||
# 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(
|
||||
href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html",
|
||||
"View notes in new tab",
|
||||
target = "_blank",
|
||||
rel = "noopener noreferrer"
|
||||
))
|
||||
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",
|
||||
"View notes in new tab",
|
||||
target = "_blank",
|
||||
rel = "noopener noreferrer"
|
||||
)
|
||||
)
|
||||
),
|
||||
shiny::plotOutput(ns("plot"), height = "70vh"),
|
||||
shiny::tags$br(),
|
||||
|
|
@ -116,21 +117,37 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
#' @export
|
||||
data_visuals_server <- function(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"
|
||||
),
|
||||
...) {
|
||||
shiny::moduleServer(
|
||||
id = id,
|
||||
module = function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
rv <- shiny::reactiveValues(
|
||||
plot.params = NULL,
|
||||
plot = NULL,
|
||||
code = NULL
|
||||
)
|
||||
rv <- shiny::reactiveValues(plot.params = NULL,
|
||||
plot = NULL,
|
||||
code = NULL)
|
||||
|
||||
shiny::observe({
|
||||
bslib::accordion_panel_update(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"))
|
||||
bslib::accordion_panel_update(
|
||||
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
|
||||
|
|
@ -259,12 +276,10 @@ data_visuals_server <- function(id,
|
|||
plot_data <- data()[input$primary]
|
||||
}
|
||||
|
||||
plots <- possible_plots(
|
||||
data = plot_data
|
||||
)
|
||||
plots <- possible_plots(data = plot_data)
|
||||
|
||||
plots_named <- get_plot_options(plots) |>
|
||||
lapply(\(.x){
|
||||
lapply(\(.x) {
|
||||
stats::setNames(.x$descr, .x$note)
|
||||
})
|
||||
|
||||
|
|
@ -284,23 +299,19 @@ data_visuals_server <- function(id,
|
|||
output$secondary <- shiny::renderUI({
|
||||
shiny::req(input$type)
|
||||
|
||||
cols <- c(
|
||||
rv$plot.params()[["secondary.extra"]],
|
||||
all_but(
|
||||
colnames(subset_types(
|
||||
data(),
|
||||
rv$plot.params()[["secondary.type"]]
|
||||
)),
|
||||
input$primary
|
||||
)
|
||||
)
|
||||
cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames(
|
||||
subset_types(data(), rv$plot.params()[["secondary.type"]])
|
||||
), input$primary))
|
||||
|
||||
columnSelectInput(
|
||||
inputId = ns("secondary"),
|
||||
data = data,
|
||||
selected = cols[1],
|
||||
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"]],
|
||||
maxItems = rv$plot.params()[["secondary.max"]],
|
||||
col_subset = cols,
|
||||
|
|
@ -319,10 +330,7 @@ data_visuals_server <- function(id,
|
|||
col_subset = c(
|
||||
"none",
|
||||
all_but(
|
||||
colnames(subset_types(
|
||||
data(),
|
||||
rv$plot.params()[["tertiary.type"]]
|
||||
)),
|
||||
colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])),
|
||||
input$primary,
|
||||
input$secondary
|
||||
)
|
||||
|
|
@ -331,64 +339,59 @@ data_visuals_server <- function(id,
|
|||
)
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$act_plot,
|
||||
{
|
||||
if (NROW(data()) > 0) {
|
||||
tryCatch(
|
||||
{
|
||||
parameters <- list(
|
||||
type = rv$plot.params()[["fun"]],
|
||||
pri = input$primary,
|
||||
sec = input$secondary,
|
||||
ter = input$tertiary
|
||||
)
|
||||
### Color option
|
||||
output$color_palette <- shiny::renderUI({
|
||||
# shiny::req(input$type)
|
||||
colorSelectInput(
|
||||
inputId = ns("color_palette"),
|
||||
label = i18n$t("Choose color palette"),
|
||||
choices = palettes
|
||||
)
|
||||
})
|
||||
|
||||
## If the dictionary holds additional arguments to pass to the
|
||||
## plotting function, these are included
|
||||
if (!is.null(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.."), {
|
||||
rv$plot <- rlang::exec(
|
||||
create_plot,
|
||||
!!!append_list(
|
||||
data(),
|
||||
parameters,
|
||||
"data"
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})")
|
||||
},
|
||||
# warning = function(warn) {
|
||||
# showNotification(paste0(warn), type = "warning")
|
||||
# },
|
||||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
shiny::observeEvent(input$act_plot, {
|
||||
if (NROW(data()) > 0) {
|
||||
tryCatch({
|
||||
parameters <- list(
|
||||
type = rv$plot.params()[["fun"]],
|
||||
pri = input$primary,
|
||||
sec = input$secondary,
|
||||
ter = input$tertiary,
|
||||
color.palette = input$color_palette
|
||||
)
|
||||
}
|
||||
},
|
||||
ignoreInit = TRUE
|
||||
)
|
||||
|
||||
## If the dictionary holds additional arguments to pass to the
|
||||
## plotting function, these are included
|
||||
if (!is.null(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.."),
|
||||
{
|
||||
rv$plot <- rlang::exec(create_plot,
|
||||
!!!append_list(data(), parameters, "data"))
|
||||
})
|
||||
|
||||
rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})")
|
||||
}, # warning = function(warn) {
|
||||
# showNotification(paste0(warn), type = "warning")
|
||||
# },
|
||||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
})
|
||||
}
|
||||
}, ignoreInit = TRUE)
|
||||
|
||||
output$code_plot <- shiny::renderUI({
|
||||
shiny::req(rv$code)
|
||||
prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code))
|
||||
})
|
||||
|
||||
shiny::observeEvent(
|
||||
list(
|
||||
data()
|
||||
),
|
||||
{
|
||||
shiny::req(data())
|
||||
shiny::observeEvent(list(data()), {
|
||||
shiny::req(data())
|
||||
|
||||
rv$plot <- NULL
|
||||
}
|
||||
)
|
||||
rv$plot <- NULL
|
||||
})
|
||||
|
||||
output$plot <- shiny::renderPlot({
|
||||
# shiny::req(rv$plot)
|
||||
|
|
@ -428,16 +431,15 @@ data_visuals_server <- function(id,
|
|||
width = input$width,
|
||||
height = input$height_slide,
|
||||
dpi = 300,
|
||||
units = "mm", scale = 2
|
||||
units = "mm",
|
||||
scale = 2
|
||||
)
|
||||
})
|
||||
}
|
||||
)
|
||||
|
||||
|
||||
shiny::observe(
|
||||
return(rv$plot)
|
||||
)
|
||||
shiny::observe(return(rv$plot))
|
||||
}
|
||||
)
|
||||
}
|
||||
|
|
@ -500,9 +502,11 @@ supported_plots <- function() {
|
|||
list(
|
||||
plot_bar_rel = list(
|
||||
fun = "plot_bar",
|
||||
fun.args =list(style="fill"),
|
||||
fun.args = list(style = "fill"),
|
||||
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"),
|
||||
secondary.type = c("dichotomous", "categorical"),
|
||||
secondary.multi = FALSE,
|
||||
|
|
@ -511,9 +515,11 @@ supported_plots <- function() {
|
|||
),
|
||||
plot_bar_abs = list(
|
||||
fun = "plot_bar",
|
||||
fun.args =list(style="dodge"),
|
||||
fun.args = list(style = "dodge"),
|
||||
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"),
|
||||
secondary.type = c("dichotomous", "categorical"),
|
||||
secondary.multi = FALSE,
|
||||
|
|
@ -523,7 +529,9 @@ supported_plots <- function() {
|
|||
plot_hbars = list(
|
||||
fun = "plot_hbars",
|
||||
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"),
|
||||
secondary.type = c("dichotomous", "categorical"),
|
||||
secondary.multi = FALSE,
|
||||
|
|
@ -533,7 +541,9 @@ supported_plots <- function() {
|
|||
plot_violin = list(
|
||||
fun = "plot_violin",
|
||||
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"),
|
||||
secondary.type = c("dichotomous", "categorical"),
|
||||
secondary.multi = FALSE,
|
||||
|
|
@ -581,7 +591,9 @@ supported_plots <- function() {
|
|||
plot_euler = list(
|
||||
fun = "plot_euler",
|
||||
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"),
|
||||
secondary.type = c("dichotomous"),
|
||||
secondary.multi = TRUE,
|
||||
|
|
@ -622,7 +634,7 @@ possible_plots <- function(data) {
|
|||
out <- type
|
||||
} else {
|
||||
out <- supported_plots() |>
|
||||
lapply(\(.x){
|
||||
lapply(\(.x) {
|
||||
if (type %in% .x$primary.type) {
|
||||
.x$descr
|
||||
}
|
||||
|
|
@ -650,12 +662,12 @@ possible_plots <- function(data) {
|
|||
#' get_plot_options()
|
||||
get_plot_options <- function(data) {
|
||||
descrs <- supported_plots() |>
|
||||
lapply(\(.x){
|
||||
lapply(\(.x) {
|
||||
.x$descr
|
||||
}) |>
|
||||
unlist()
|
||||
supported_plots() |>
|
||||
(\(.x){
|
||||
(\(.x) {
|
||||
.x[match(data, descrs)]
|
||||
})()
|
||||
}
|
||||
|
|
@ -669,6 +681,7 @@ get_plot_options <- function(data) {
|
|||
#' @param sec secondary variable
|
||||
#' @param ter tertiary variable
|
||||
#' @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
|
||||
#'
|
||||
#' @name data-plots
|
||||
|
|
@ -678,7 +691,13 @@ get_plot_options <- function(data) {
|
|||
#'
|
||||
#' @examples
|
||||
#' 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 (!any(sec %in% names(data))) {
|
||||
sec <- NULL
|
||||
|
|
@ -695,13 +714,11 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
|
|||
pri = pri,
|
||||
sec = sec,
|
||||
ter = ter,
|
||||
color.palette = color.palette,
|
||||
...
|
||||
)
|
||||
|
||||
out <- do.call(
|
||||
type,
|
||||
modifyList(parameters, list(data = data))
|
||||
)
|
||||
out <- do.call(type, modifyList(parameters, list(data = data)))
|
||||
|
||||
code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR")
|
||||
|
||||
|
|
@ -758,10 +775,14 @@ get_label <- function(data, var = NULL) {
|
|||
#' @examples
|
||||
#' "Lorem ipsum... you know the routine" |> line_break()
|
||||
#' 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)) {
|
||||
## 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 {
|
||||
paste(strwrap(data, lineLength), collapse = "\n")
|
||||
}
|
||||
|
|
@ -793,9 +814,9 @@ wrap_plot_list <- function(data,
|
|||
if (ggplot2::is_ggplot(data[[1]])) {
|
||||
if (length(data) > 1) {
|
||||
out <- data |>
|
||||
(\(.x){
|
||||
(\(.x) {
|
||||
if (rlang::is_named(.x)) {
|
||||
purrr::imap(.x, \(.y, .i){
|
||||
purrr::imap(.x, \(.y, .i) {
|
||||
.y + ggplot2::ggtitle(.i)
|
||||
})
|
||||
} else {
|
||||
|
|
@ -803,12 +824,10 @@ wrap_plot_list <- function(data,
|
|||
}
|
||||
})() |>
|
||||
align_axes() |>
|
||||
patchwork::wrap_plots(
|
||||
guides = guides,
|
||||
axes = axes,
|
||||
axis_titles = axis_titles,
|
||||
...
|
||||
)
|
||||
patchwork::wrap_plots(guides = guides,
|
||||
axes = axes,
|
||||
axis_titles = axis_titles,
|
||||
...)
|
||||
if (!is.null(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
|
||||
#' @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://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
|
||||
if (ggplot2::is_ggplot(..1)) {
|
||||
|
|
@ -865,7 +886,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) {
|
|||
xr <- clean_common_axis(p, "x")
|
||||
|
||||
suppressWarnings({
|
||||
purrr::map(p, \(.x){
|
||||
purrr::map(p, \(.x) {
|
||||
out <- .x
|
||||
if (isTRUE(x.axis)) {
|
||||
out <- out + ggplot2::xlim(xr)
|
||||
|
|
@ -889,7 +910,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) {
|
|||
clean_common_axis <- function(p, axis) {
|
||||
purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |>
|
||||
unlist() |>
|
||||
(\(.x){
|
||||
(\(.x) {
|
||||
if (is.numeric(.x)) {
|
||||
range(.x)
|
||||
} else {
|
||||
|
|
|
|||
237
R/generate_colors.R
Normal file
237
R/generate_colors.R
Normal 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
12
R/plot_bar.R
|
|
@ -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)
|
||||
|
||||
if (!is.null(ter)) {
|
||||
|
|
@ -13,7 +14,8 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi
|
|||
pri = pri,
|
||||
sec = sec,
|
||||
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 |>
|
||||
#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |>
|
||||
#' plot_bar_single(pri = "cyl", style = "stack")
|
||||
plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30) {
|
||||
#' 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,
|
||||
color.palette = "viridis") {
|
||||
style <- match.arg(style)
|
||||
|
||||
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::scale_y_continuous(labels = scales::percent) +
|
||||
scale_fill_generate(palette=color.palette) +
|
||||
ggplot2::ylab("Percentage") +
|
||||
ggplot2::xlab(get_label(data,pri))+
|
||||
ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill)))
|
||||
|
|
|
|||
12
R/plot_box.R
12
R/plot_box.R
|
|
@ -20,7 +20,7 @@
|
|||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' 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)) {
|
||||
ds <- split(data, data[ter])
|
||||
} else {
|
||||
|
|
@ -31,7 +31,8 @@ plot_box <- function(data, pri, sec, ter = NULL,...) {
|
|||
plot_box_single(
|
||||
data = .ds,
|
||||
pri = pri,
|
||||
sec = sec
|
||||
sec = sec,
|
||||
color.palette=color.palette
|
||||
)
|
||||
})
|
||||
|
||||
|
|
@ -48,9 +49,10 @@ plot_box <- function(data, pri, sec, ter = NULL,...) {
|
|||
#'
|
||||
#' @examples
|
||||
#' 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")
|
||||
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)
|
||||
|
||||
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::ylab(get_label(data,sec)) +
|
||||
ggplot2::coord_flip() +
|
||||
viridis::scale_fill_viridis(discrete = discrete, option = "D") +
|
||||
scale_fill_generate(discrete = discrete,palette = color.palette) +
|
||||
# ggplot2::theme_void() +
|
||||
ggplot2::theme_bw(base_size = 24) +
|
||||
ggplot2::theme(
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ ggeulerr <- function(
|
|||
#' plot_euler("mfi_cut", "mdi_cut")
|
||||
#' stRoke::trial |>
|
||||
#' 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)
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
|
|
@ -112,7 +112,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
|||
out <- lapply(ds, \(.x){
|
||||
.x[c(pri, sec)] |>
|
||||
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)}")))
|
||||
|
|
@ -130,16 +130,12 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
|||
#' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
|
||||
#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
#' ) |> plot_euler_single()
|
||||
#' mtcars[c("vs", "am")] |> plot_euler_single()
|
||||
plot_euler_single <- function(data) {
|
||||
# if (any("categorical" %in% data_type(data))){
|
||||
# shape <- "ellipse"
|
||||
# } else {
|
||||
# shape <- "circle"
|
||||
# }
|
||||
#' mtcars[c("vs", "am")] |> plot_euler_single("magma")
|
||||
plot_euler_single <- function(data,color.palette="viridis") {
|
||||
|
||||
data |>
|
||||
ggeulerr(shape = "circle") +
|
||||
scale_fill_generate(palette=color.palette) +
|
||||
ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
legend.position = "none",
|
||||
|
|
|
|||
|
|
@ -8,11 +8,21 @@
|
|||
#' @examples
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = "cyl")
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = NULL)
|
||||
plot_hbars <- function(data, pri, sec, ter = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter)
|
||||
|
||||
out
|
||||
#' 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")
|
||||
plot_hbars <- function(data,
|
||||
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.size = .5,
|
||||
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)) {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
dplyr::mutate("All" = 1) |>
|
||||
|
|
@ -60,15 +72,19 @@ vertical_stacked_bars <- function(data,
|
|||
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 <-
|
||||
sum(contrast_text(colors, threshold = .3) == "white")
|
||||
contrast_text(colors, threshold = .3) == "white"
|
||||
|
||||
score_label <- data |> get_label(var = score)
|
||||
group_label <- data |> get_label(var = group)
|
||||
|
||||
p |>
|
||||
(\(.x){
|
||||
(\(.x) {
|
||||
.x$plot +
|
||||
ggplot2::geom_text(
|
||||
data = .x$rectData[which(.x$rectData$n >
|
||||
|
|
@ -78,20 +94,18 @@ vertical_stacked_bars <- function(data,
|
|||
ggplot2::aes(
|
||||
x = group,
|
||||
y = p_prev + 0.49 * p,
|
||||
color = as.numeric(score) > contrast_cut,
|
||||
color = contrast_cut,
|
||||
# label = paste0(sprintf("%2.0f", 100 * p),"%"),
|
||||
# label = sprintf("%2.0f", 100 * p)
|
||||
label = glue::glue(label.str)
|
||||
)
|
||||
) +
|
||||
ggplot2::labs(fill = score_label) +
|
||||
ggplot2::scale_fill_manual(values = rev(colors)) +
|
||||
ggplot2::theme(
|
||||
legend.position = "bottom",
|
||||
axis.title = ggplot2::element_text(),
|
||||
ggplot2::scale_fill_manual(values = colors) +
|
||||
ggplot2::theme(legend.position = "bottom",
|
||||
axis.title = ggplot2::element_text(),
|
||||
) +
|
||||
ggplot2::xlab(group_label) +
|
||||
ggplot2::ylab(NULL)
|
||||
# viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D")
|
||||
})()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
#' default_parsing() |>
|
||||
#' plot_ridge(x = "mpg", y = "cyl")
|
||||
#' 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)) {
|
||||
ds <- split(data, data[z])
|
||||
} 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))) +
|
||||
ggridges::geom_density_ridges() +
|
||||
ggridges::theme_ridges() +
|
||||
scale_fill_generate(palette=color.palette) +
|
||||
ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa()
|
||||
})
|
||||
|
||||
|
|
|
|||
112
R/plot_sankey.R
112
R/plot_sankey.R
|
|
@ -19,7 +19,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
|
|||
## TODO: Ensure ordering x and y
|
||||
|
||||
## 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))
|
||||
|
||||
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...
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_sankey("cyl", "gear", "vs", color.group = "pri")
|
||||
#'
|
||||
#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
|
||||
#' # stRoke::trial |> plot_sankey("active", "male")
|
||||
#' plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno")
|
||||
plot_sankey <- function(data,
|
||||
pri,
|
||||
sec,
|
||||
ter = NULL,
|
||||
color.group = "pri",
|
||||
colors = NULL,
|
||||
color.palette = "viridis",
|
||||
default.color = "#2986cc",
|
||||
box.color = "#1E4B66",
|
||||
na.color = "grey80",
|
||||
missing.level = "Missing") {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
|
|
@ -101,12 +102,14 @@ plot_sankey <- function(data,
|
|||
ds <- list(data)
|
||||
}
|
||||
|
||||
# browser()
|
||||
|
||||
out <- lapply(ds, \(.ds) {
|
||||
plot_sankey_single(
|
||||
.ds,
|
||||
pri = pri,
|
||||
sec = sec,
|
||||
color.palette = color.palette,
|
||||
color.group = color.group,
|
||||
colors = colors,
|
||||
missing.level = missing.level
|
||||
|
|
@ -144,12 +147,22 @@ plot_sankey <- function(data,
|
|||
#' stRoke::trial |>
|
||||
#' default_parsing() |>
|
||||
#' 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,
|
||||
pri,
|
||||
sec,
|
||||
color.group = c("pri", "sec"),
|
||||
colors = NULL,
|
||||
color.palette = "viridis",
|
||||
colors=NULL,
|
||||
missing.level = "Missing",
|
||||
default.color = "#2986cc",
|
||||
box.color = "#1E4B66",
|
||||
na.color = "grey80",
|
||||
...) {
|
||||
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)] |>
|
||||
dplyr::mutate(
|
||||
dplyr::across(dplyr::where(is.logical), as.factor),
|
||||
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
|
||||
})
|
||||
)
|
||||
to_clean_levels() |>
|
||||
missing_to_text_levels(missing.text=missing.level)
|
||||
})
|
||||
|
||||
|
||||
## Aggregate data
|
||||
data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...)
|
||||
|
||||
na.color <- "#2986cc"
|
||||
box.color <- "#1E4B66"
|
||||
default.color = default.color
|
||||
box.color = box.color
|
||||
na.color = na.color
|
||||
|
||||
if (is.null(colors)) {
|
||||
if (color.group == "sec") {
|
||||
if (anyNA(data_orig[[sec]])){
|
||||
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]]))]
|
||||
main.colors <- color_levels_gen(data_orig[[sec]],palette=color.palette)
|
||||
|
||||
secondary.colors <- rep(na.color, length(levels(data[[pri]])))
|
||||
secondary.colors <- rep(default.color, length(levels(data[[pri]])))
|
||||
label.colors <- Reduce(c, lapply(list(
|
||||
secondary.colors, rev(main.colors)
|
||||
), contrast_text))
|
||||
} else {
|
||||
if (anyNA(data_orig[[sec]])){
|
||||
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]]))]
|
||||
main.colors <- color_levels_gen(data_orig[[pri]],palette=color.palette)
|
||||
|
||||
secondary.colors <- rep(na.color, length(levels(data[[sec]])))
|
||||
secondary.colors <- rep(default.color, length(levels(data[[sec]])))
|
||||
label.colors <- Reduce(c, lapply(list(
|
||||
rev(main.colors), secondary.colors
|
||||
), contrast_text))
|
||||
}
|
||||
colors <- c(na.color, main.colors, secondary.colors)
|
||||
colors[is.na(colors)] <- "grey80"
|
||||
colors <- c(default.color, main.colors, secondary.colors)
|
||||
colors[is.na(colors)] <- na.color
|
||||
} else {
|
||||
label.colors <- contrast_text(colors)
|
||||
}
|
||||
|
|
@ -212,8 +207,6 @@ plot_sankey_single <- function(data,
|
|||
sapply(line_break) |>
|
||||
unname()
|
||||
|
||||
# browser()
|
||||
|
||||
p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
|
||||
|
||||
if (color.group == "sec") {
|
||||
|
|
@ -275,3 +268,48 @@ plot_sankey_single <- function(data,
|
|||
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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -7,7 +7,8 @@
|
|||
#'
|
||||
#' @examples
|
||||
#' 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)) {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
|
|
@ -24,6 +25,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL) {
|
|||
group = ter,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
)
|
||||
)+
|
||||
scale_color_generate(palette=color.palette)
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#' Beatiful violin plot
|
||||
#' Beautiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
|
|
@ -6,8 +6,9 @@
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
plot_violin <- function(data, pri, sec, ter = NULL) {
|
||||
#' mtcars |> plot_violin(pri = "mpg", sec = "cyl")
|
||||
#' 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)) {
|
||||
ds <- split(data, data[ter])
|
||||
} else {
|
||||
|
|
@ -23,7 +24,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) {
|
|||
response = pri,
|
||||
xtitle = get_label(data, var = sec),
|
||||
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)}")))
|
||||
|
|
|
|||
72
man/colorSelectInput.Rd
Normal file
72
man/colorSelectInput.Rd
Normal 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
44
man/continuous_colors.Rd
Normal 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()}}
|
||||
}
|
||||
|
|
@ -20,25 +20,35 @@
|
|||
\usage{
|
||||
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(
|
||||
data,
|
||||
pri,
|
||||
sec = NULL,
|
||||
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", ...)
|
||||
|
||||
|
|
@ -49,12 +59,16 @@ plot_sankey(
|
|||
ter = NULL,
|
||||
color.group = "pri",
|
||||
colors = NULL,
|
||||
color.palette = "viridis",
|
||||
default.color = "#2986cc",
|
||||
box.color = "#1E4B66",
|
||||
na.color = "grey80",
|
||||
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{
|
||||
\item{id}{Module id. (Use 'ns("id")')}
|
||||
|
|
@ -71,6 +85,8 @@ plot_violin(data, pri, sec, ter = NULL)
|
|||
|
||||
\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.
|
||||
One of c("stack", "dodge", "fill")}
|
||||
}
|
||||
|
|
@ -120,7 +136,7 @@ Beautiful sankey plot with option to split by a tertiary group
|
|||
|
||||
Beautiful violin plot
|
||||
|
||||
Beatiful violin plot
|
||||
Beautiful violin plot
|
||||
}
|
||||
\examples{
|
||||
create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
|
||||
|
|
@ -130,7 +146,7 @@ mtcars |>
|
|||
|
||||
mtcars |>
|
||||
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="cyl")
|
||||
mtcars |>
|
||||
|
|
@ -140,11 +156,14 @@ mtcars |>
|
|||
default_parsing() |>
|
||||
plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono")
|
||||
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")
|
||||
mtcars |> plot_hbars(pri = "carb", sec = "cyl")
|
||||
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 |>
|
||||
default_parsing() |>
|
||||
plot_ridge(x = "mpg", y = "cyl")
|
||||
|
|
@ -169,9 +188,9 @@ mtcars |>
|
|||
## Dont know why...
|
||||
mtcars |>
|
||||
default_parsing() |>
|
||||
plot_sankey("cyl", "gear", "vs", color.group = "pri")
|
||||
|
||||
# stRoke::trial |> plot_sankey("mrs_1", "mrs_6")
|
||||
plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno")
|
||||
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
63
man/generate_colors.Rd
Normal 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}}
|
||||
}
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
\alias{plot_euler}
|
||||
\title{Easily plot euler diagrams}
|
||||
\usage{
|
||||
plot_euler(data, pri, sec, ter = NULL, seed = 2103)
|
||||
plot_euler(data, pri, sec, ter = NULL, seed = 2103, color.palette = "viridis")
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
\alias{plot_euler_single}
|
||||
\title{Easily plot single euler diagrams}
|
||||
\usage{
|
||||
plot_euler_single(data)
|
||||
plot_euler_single(data, color.palette = "viridis")
|
||||
}
|
||||
\value{
|
||||
ggplot2 object
|
||||
|
|
@ -19,5 +19,5 @@ data.frame(
|
|||
C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE),
|
||||
D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
) |> plot_euler_single()
|
||||
mtcars[c("vs", "am")] |> plot_euler_single()
|
||||
mtcars[c("vs", "am")] |> plot_euler_single("magma")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -9,8 +9,12 @@ plot_sankey_single(
|
|||
pri,
|
||||
sec,
|
||||
color.group = c("pri", "sec"),
|
||||
color.palette = "viridis",
|
||||
colors = NULL,
|
||||
missing.level = "Missing",
|
||||
default.color = "#2986cc",
|
||||
box.color = "#1E4B66",
|
||||
na.color = "grey80",
|
||||
...
|
||||
)
|
||||
}
|
||||
|
|
@ -44,4 +48,10 @@ mtcars |>
|
|||
stRoke::trial |>
|
||||
default_parsing() |>
|
||||
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
45
man/scale_fill_generate.Rd
Normal 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()}}
|
||||
}
|
||||
|
|
@ -13,7 +13,9 @@ vertical_stacked_bars(
|
|||
l.color = "black",
|
||||
l.size = 0.5,
|
||||
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{
|
||||
|
|
|
|||
146
tests/testthat/test-plot_colors.R
Normal file
146
tests/testthat/test-plot_colors.R
Normal 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))
|
||||
})
|
||||
Loading…
Add table
Add a link
Reference in a new issue