updated renv

DESCRIPTION

@@ -108,6 +108,7 @@ Collate:
     'data_plots.R'
     'datagrid-infos-mod.R'
     'footer_ui.R'
+    'generate_colors.R'
     'helpers.R'
     'hosted_version.R'
     'html_dependency_freesearchr.R'

NAMESPACE

@@ -21,8 +21,10 @@ export(class_icons)
 export(clean_common_axis)
 export(clean_date)
 export(clean_sep)
+export(colorSelectInput)
 export(columnSelectInput)
 export(compare_missings)
+export(continuous_colors)
 export(contrast_text)
 export(corr_pairs_validate)
 export(correlation_pairs)
@@ -59,6 +61,7 @@ export(factor_new_levels_labels)
 export(factorize)
 export(file_export)
 export(format_writer)
+export(generate_colors)
 export(get_data_packages)
 export(get_fun_options)
 export(get_label)
@@ -139,6 +142,8 @@ export(remove_nested_list)
 export(repeated_instruments)
 export(restore_labels)
 export(sankey_ready)
+export(scale_color_generate)
+export(scale_fill_generate)
 export(selectInputIcon)
 export(separate_string)
 export(set_column_label)
@@ -174,9 +179,17 @@ export(winbox_update_factor)
 export(with_labels)
 export(wrap_plot_list)
 export(write_quarto)
+importFrom(RColorBrewer,brewer.pal)
+importFrom(RColorBrewer,brewer.pal.info)
 importFrom(classInt,classIntervals)
 importFrom(data.table,as.data.table)
 importFrom(data.table,data.table)
+importFrom(grDevices,colorRampPalette)
+importFrom(grDevices,hcl.colors)
+importFrom(grDevices,heat.colors)
+importFrom(grDevices,rainbow)
+importFrom(grDevices,terrain.colors)
+importFrom(grDevices,topo.colors)
 importFrom(graphics,abline)
 importFrom(graphics,axis)
 importFrom(graphics,hist)
@@ -239,3 +252,4 @@ importFrom(toastui,renderDatagrid)
 importFrom(toastui,renderDatagrid2)
 importFrom(utils,data)
 importFrom(utils,type.convert)
+importFrom(viridisLite,viridis)

NEWS.md

@@ -1,8 +1,10 @@
 # FreesearchR 26.3.4
 
+*NEW* Color select for plotting across all plots for even more option. Ten palettes have been chosen, to provide varied and interpretable options. The selector will always show a preview of four colors.
+
 *NEW* Added app version check against latest release on GitHub. Only runs if internet connection present. No other polling.
 
-*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size.
+*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size. And fixed support for dichotomous data.
 
 # FreesearchR 26.3.3
 

R/custom_SelectInput.R

@@ -20,8 +20,7 @@
 #' @importFrom shiny selectizeInput
 #' @export
 #'
-columnSelectInput <- function(
-  inputId,
+columnSelectInput <- function(inputId,
                               label,
                               data,
                               selected = "",
@@ -30,20 +29,27 @@ columnSelectInput <- function(
                               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)
+                              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>';
+        }
+      }"
+      )
     )
   )
 }

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(
+        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,
+      rv <- shiny::reactiveValues(plot.params = NULL,
                                   plot = NULL,
-        code = 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,
-        {
+      ### 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) {
-            tryCatch(
-              {
+          tryCatch({
             parameters <- list(
               type = rv$plot.params()[["fun"]],
               pri = input$primary,
               sec = input$secondary,
-                  ter = input$tertiary
+              ter = input$tertiary,
+              color.palette = input$color_palette
             )
 
             ## 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"]])
+            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"
-                    )
-                  )
+            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) {
+          }, # warning = function(warn) {
           #   showNotification(paste0(warn), type = "warning")
           # },
           error = function(err) {
             showNotification(paste0(err), type = "err")
+          })
         }
-            )
-          }
-        },
-        ignoreInit = TRUE
-      )
+      }, ignoreInit = TRUE)
 
       output$code_plot <- shiny::renderUI({
         shiny::req(rv$code)
         prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code))
       })
 
-      shiny::observeEvent(
-        list(
-          data()
-        ),
-        {
+      shiny::observeEvent(list(data()), {
         shiny::req(data())
 
         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,
+        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 {

R/generate_colors.R

@@ -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)),
+      ...
+    )
+  }
+}

R/hosted_version.R

@@ -1 +1 @@
-hosted_version <- function()'v26.3.4-260323'
+hosted_version <- function()'v26.3.4-260324'

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)))

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(

R/plot_euler.R

@@ -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",

R/plot_hbar.R

@@ -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",
+        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")
     })()
 }

R/plot_ridge.R

@@ -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()
   })
 

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
+}

R/plot_scatter.R

@@ -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)
   }
 }

R/plot_violin.R

@@ -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)}")))

SESSION.md

@@ -11,11 +11,11 @@
 |collate     |en_US.UTF-8                                |
 |ctype       |en_US.UTF-8                                |
 |tz          |Europe/Copenhagen                          |
-|date        |2026-03-23                                 |
+|date        |2026-03-24                                 |
 |rstudio     |2026.01.1+403 Apple Blossom (desktop)      |
 |pandoc      |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
 |quarto      |1.7.30 @ /usr/local/bin/quarto             |
-|FreesearchR |26.3.4.260323                              |
+|FreesearchR |26.3.4.260324                              |
                                                                                 
                                                                                 
 --------------------------------------------------------------------------------
@@ -44,7 +44,6 @@
 |cardx             |0.3.2         |2026-02-05 |CRAN (R 4.5.2) |
 |caTools           |1.18.3        |2024-09-04 |CRAN (R 4.5.0) |
 |cellranger        |1.1.0         |2016-07-27 |CRAN (R 4.5.0) |
-|cffr              |1.2.1         |2026-01-12 |CRAN (R 4.5.2) |
 |checkmate         |2.3.4         |2026-02-03 |CRAN (R 4.5.2) |
 |class             |7.3-23        |2025-01-01 |CRAN (R 4.5.0) |
 |classInt          |0.4-11        |2025-01-08 |CRAN (R 4.5.0) |
@@ -54,7 +53,6 @@
 |colorspace        |2.1-2         |2025-09-22 |CRAN (R 4.5.0) |
 |commonmark        |2.0.0         |2025-07-07 |CRAN (R 4.5.0) |
 |crayon            |1.5.3         |2024-06-20 |CRAN (R 4.5.0) |
-|curl              |7.0.0         |2025-08-19 |CRAN (R 4.5.0) |
 |data.table        |1.18.2.1      |2026-01-27 |CRAN (R 4.5.2) |
 |datamods          |1.5.3         |2024-10-02 |CRAN (R 4.5.0) |
 |datawizard        |1.3.0         |2025-10-11 |CRAN (R 4.5.0) |
@@ -113,7 +111,6 @@
 |iterators         |1.0.14        |2022-02-05 |CRAN (R 4.5.0) |
 |jquerylib         |0.1.4         |2021-04-26 |CRAN (R 4.5.0) |
 |jsonlite          |2.0.0         |2025-03-27 |CRAN (R 4.5.0) |
-|jsonvalidate      |1.5.0         |2025-02-07 |CRAN (R 4.5.0) |
 |KernSmooth        |2.23-26       |2025-01-01 |CRAN (R 4.5.0) |
 |keyring           |1.4.1         |2025-06-15 |CRAN (R 4.5.0) |
 |knitr             |1.51          |2025-12-20 |CRAN (R 4.5.2) |
@@ -127,6 +124,7 @@
 |MASS              |7.3-65        |2025-02-28 |CRAN (R 4.5.0) |
 |Matrix            |1.7-4         |2025-08-28 |CRAN (R 4.5.0) |
 |memoise           |2.0.1         |2021-11-26 |CRAN (R 4.5.0) |
+|mgcv              |1.9-4         |2025-11-07 |CRAN (R 4.5.0) |
 |mime              |0.13          |2025-03-17 |CRAN (R 4.5.0) |
 |minqa             |1.2.8         |2024-08-17 |CRAN (R 4.5.0) |
 |mvtnorm           |1.3-2         |2024-11-04 |CRAN (R 4.5.2) |
@@ -150,6 +148,7 @@
 |pkgload           |1.5.0         |2026-02-03 |CRAN (R 4.5.2) |
 |plyr              |1.8.9         |2023-10-02 |CRAN (R 4.5.0) |
 |polyclip          |1.10-7        |2024-07-23 |CRAN (R 4.5.0) |
+|polylabelr        |1.0.0         |2026-01-19 |CRAN (R 4.5.2) |
 |pracma            |2.4.6         |2025-10-22 |CRAN (R 4.5.0) |
 |processx          |3.8.6         |2025-02-21 |CRAN (R 4.5.0) |
 |promises          |1.5.0         |2025-11-01 |CRAN (R 4.5.0) |
@@ -162,7 +161,6 @@
 |R6                |2.6.1         |2025-02-15 |CRAN (R 4.5.0) |
 |ragg              |1.5.1         |2026-03-06 |CRAN (R 4.5.2) |
 |rankinPlot        |1.1.0         |2023-01-30 |CRAN (R 4.5.0) |
-|rappdirs          |0.3.4         |2026-01-17 |CRAN (R 4.5.2) |
 |rbibutils         |2.4.1         |2026-01-21 |CRAN (R 4.5.2) |
 |RColorBrewer      |1.1-3         |2022-04-03 |CRAN (R 4.5.0) |
 |Rcpp              |1.1.1         |2026-01-10 |CRAN (R 4.5.2) |
@@ -216,9 +214,7 @@
 |twosamples        |2.0.1         |2023-06-23 |CRAN (R 4.5.0) |
 |tzdb              |0.5.0         |2025-03-15 |CRAN (R 4.5.0) |
 |usethis           |3.2.1         |2025-09-06 |CRAN (R 4.5.0) |
-|utf8              |1.2.6         |2025-06-08 |CRAN (R 4.5.0) |
 |uuid              |1.2-2         |2026-01-23 |CRAN (R 4.5.2) |
-|V8                |8.0.1         |2025-10-10 |CRAN (R 4.5.0) |
 |vctrs             |0.7.1         |2026-01-23 |CRAN (R 4.5.2) |
 |viridis           |0.6.5         |2024-01-29 |CRAN (R 4.5.0) |
 |viridisLite       |0.4.3         |2026-02-04 |CRAN (R 4.5.2) |

app_docker/Dockerfile

@@ -1,5 +1,5 @@
 FROM rocker/tidyverse:4.5.2
-RUN apt-get update -y && apt-get install -y  cmake make libcurl4-openssl-dev libicu-dev libssl-dev pandoc zlib1g-dev libsecret-1-dev libxml2-dev libx11-dev libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev libharfbuzz-dev libjpeg-dev libpng-dev libtiff-dev libwebp-dev libfftw3-dev && rm -rf /var/lib/apt/lists/*
+RUN apt-get update -y && apt-get install -y  cmake make libcurl4-openssl-dev libicu-dev libuv1-dev libssl-dev pandoc zlib1g-dev libsecret-1-dev libxml2-dev libx11-dev libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev libharfbuzz-dev libjpeg-dev libpng-dev libtiff-dev libwebp-dev libfftw3-dev && rm -rf /var/lib/apt/lists/*
 RUN mkdir -p /usr/local/lib/R/etc/ /usr/lib/R/etc/
 RUN echo "options(renv.config.pak.enabled = FALSE, repos = c(CRAN = 'https://cran.rstudio.com/'), download.file.method = 'libcurl', Ncpus = 4)" | tee /usr/local/lib/R/etc/Rprofile.site | tee /usr/lib/R/etc/Rprofile.site
 RUN R -e 'install.packages("remotes")'

app_docker/renv.lock

@@ -35,12 +35,12 @@
     },
     "DHARMa": {
       "Package": "DHARMa",
-      "Version": "0.4.7",
+      "Version": "0.4.6",
       "Source": "Repository",
       "Title": "Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models",
-      "Date": "2024-10-16",
-      "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"), person(\"Melina\", \"de Souza leite\", role = \"ctb\"))",
-      "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB', 'GLMMadaptive', and 'spaMM'; phylogenetic  linear models from 'phylolm' (classes 'phylolm' and 'phyloglm'); generalized additive  models ('gam' from 'mgcv'); 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial, phylogenetic and temporal autocorrelation.",
+      "Date": "2022-09-08",
+      "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"))",
+      "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB' 'GLMMadaptive' and 'spaMM', generalized additive models ('gam' from 'mgcv'), 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial and temporal autocorrelation.",
       "Depends": [
         "R (>= 3.0.2)"
       ],
@@ -59,7 +59,7 @@
       ],
       "Suggests": [
         "knitr",
-        "testthat (>= 3.0.0)",
+        "testthat",
         "rmarkdown",
         "KernSmooth",
         "sfsmisc",
@@ -68,8 +68,7 @@
         "mgcViz (>= 0.1.9)",
         "spaMM (>= 3.2.0)",
         "GLMMadaptive",
-        "glmmTMB (>= 1.1.2.3)",
-        "phylolm (>= 2.6.5)"
+        "glmmTMB (>= 1.1.2.3)"
       ],
       "Enhances": [
         "phyr",
@@ -81,12 +80,11 @@
       "URL": "http://florianhartig.github.io/DHARMa/",
       "LazyData": "TRUE",
       "BugReports": "https://github.com/florianhartig/DHARMa/issues",
-      "RoxygenNote": "7.3.2",
+      "RoxygenNote": "7.2.1",
       "VignetteBuilder": "knitr",
       "Encoding": "UTF-8",
-      "Config/testthat/edition": "3",
       "NeedsCompilation": "no",
-      "Author": "Florian Hartig [aut, cre] (<https://orcid.org/0000-0002-6255-9059>), Lukas Lohse [ctb], Melina de Souza leite [ctb]",
+      "Author": "Florian Hartig [aut, cre] (<https://orcid.org/0000-0002-6255-9059>), Lukas Lohse [ctb]",
       "Maintainer": "Florian Hartig <florian.hartig@biologie.uni-regensburg.de>",
       "Repository": "CRAN"
     },
@@ -2347,7 +2345,7 @@
     },
     "datamods": {
       "Package": "datamods",
-      "Version": "1.5.3",
+      "Version": "1.5.2",
       "Source": "Repository",
       "Title": "Modules to Import and Manipulate Data in 'Shiny'",
       "Authors@R": "c(person(given = \"Victor\", family = \"Perrier\", role = c(\"aut\", \"cre\", \"cph\"), email = \"victor.perrier@dreamrs.fr\"), person(given = \"Fanny\", family = \"Meyer\", role = \"aut\"), person(given = \"Samra\", family = \"Goumri\", role = \"aut\"), person(given = \"Zauad Shahreer\", family = \"Abeer\", role = \"aut\", email = \"shahreyar.abeer@gmail.com\"), person(given = \"Eduard\", family = \"Szöcs\", role = \"ctb\", email = \"eduardszoecs@gmail.com\") )",
@@ -8359,7 +8357,7 @@
     },
     "shinybusy": {
       "Package": "shinybusy",
-      "Version": "0.3.3",
+      "Version": "0.3.2",
       "Source": "Repository",
       "Title": "Busy Indicators and Notifications for 'Shiny' Applications",
       "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))",
@@ -8372,8 +8370,8 @@
         "jsonlite",
         "htmlwidgets"
       ],
-      "RoxygenNote": "7.3.1",
-      "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/",
+      "RoxygenNote": "7.2.3",
+      "URL": "https://github.com/dreamRs/shinybusy",
       "BugReports": "https://github.com/dreamRs/shinybusy/issues",
       "Suggests": [
         "testthat",

app_docker/translations/translation_da.csv

@@ -89,7 +89,6 @@
 "No variables have a correlation measure above the threshold.","Ingen variabler er korrelerede over den angivne tærskelværdi."
 "and","og"
 "from each pair","fra hvert par"
-"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Kun variabler, der ikke er klassificerede som tekst er tilgængelige. Gå til fanen ""Forbered"" for at ændre klassifikationer."
 "Plot","Tegn"
 "Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""."
 "Plot height (mm)","Højde af grafik (mm)"
@@ -108,9 +107,7 @@
 "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.."
 "#Plotting\n","#Tegner\n"
 "Stacked horizontal bars","Stablede horisontale søjler"
-"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","En klassisk visualisering af fordelingen af observationer på en ordinal kategorisk skala. Typisk brugt til modified Rankin Scale og kendes også som 'Grotta bars'"
 "Violin plot","Violin-diagram"
-"A modern alternative to the classic boxplot to visualise data distribution","Moderne alternativ til den klassiske box-plot og velegnet til at visualisere fordelingen af observationer"
 "Sankey plot","Sankey-diagram"
 "A way of visualising change between groups","Visualiserer ændring mellem grupper for samme type observationer"
 "Scatter plot","Punkt-diagram"
@@ -118,7 +115,6 @@
 "Box plot","Kasse-diagram"
 "A classic way to plot data distribution by groups","Klassik måde at visualisere fordeling"
 "Euler diagram","Eulerdiagram"
-"Generate area-proportional Euler diagrams to display set relationships","Generer proportionelt Euler-diagram for at vise forhold mellem forskellige kategoriske observationer"
 "Documentation","Dokumentation"
 "Data is only stored for analyses and deleted when the app is closed.","Data opbevares alene til brug i analyser og slettes så snart appen lukkes."
 "Feedback","Feedback"
@@ -232,9 +228,7 @@
 "Split text","Opdel tekst"
 "Apply split","Anvend opdeling"
 "Stacked relative barplot","Stablet relativt søjlediagram"
-"Create relative stacked barplots to show the distribution of categorical levels","Opret relative stablede søjlediagrammer for at vise fordelingen af kategoriske niveauer"
 "Side-by-side barplot","Side om side barplot"
-"Create side-by-side barplot to show the distribution of categorical levels","Opret et side-om-side søjlediagram for at vise fordelingen af kategoriske niveauer"
 "Select table theme","Vælg tema"
 "Letters","Bogstaver"
 "Words","Ord"
@@ -328,3 +322,4 @@
 "Sample data","Sample data"
 "Settings","Settings"
 "Create new factor","Create new factor"
+"Choose color palette","Choose color palette"

app_docker/translations/translation_sw.csv

@@ -89,7 +89,6 @@
 "No variables have a correlation measure above the threshold.","Hakuna vigezo vyenye kipimo cha uhusiano kilicho juu ya kizingiti."
 "and","na"
 "from each pair","kutoka kwa kila jozi"
-"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Vigezo visivyo vya maandishi pekee ndivyo vinavyopatikana kwa ajili ya kupanga. Nenda kwenye ""Data"" ili kupanga upya data ili kupanga."
 "Plot","Kipande cha habari"
 "Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""."
 "Plot height (mm)","Urefu wa kiwanja (mm)"
@@ -108,9 +107,7 @@
 "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.."
 "#Plotting\n","#Upangaji\n"
 "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio"
-"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","Njia ya kitamaduni ya kuibua usambazaji wa mizani ya kawaida kama vile Mizani ya Nafasi iliyorekebishwa na inayojulikana kama baa za Grotta"
 "Violin plot","Hadithi ya violin"
-"A modern alternative to the classic boxplot to visualise data distribution","Njia mbadala ya kisasa ya mpangilio wa kisanduku wa kawaida ili kuibua usambazaji wa data"
 "Sankey plot","Njama ya Sankey"
 "A way of visualising change between groups","Njia ya kuibua mabadiliko kati ya vikundi"
 "Scatter plot","Njama ya kutawanya"
@@ -118,7 +115,6 @@
 "Box plot","Kipande cha sanduku"
 "A classic way to plot data distribution by groups","Njia ya kawaida ya kupanga usambazaji wa data kwa vikundi"
 "Euler diagram","Mchoro wa Euler"
-"Generate area-proportional Euler diagrams to display set relationships","Tengeneza michoro ya Euler inayolingana na eneo ili kuonyesha uhusiano uliowekwa"
 "Documentation","Nyaraka"
 "Data is only stored for analyses and deleted when the app is closed.","Data huhifadhiwa kwa ajili ya uchambuzi na kufutwa tu wakati programu imefungwa."
 "Feedback","Maoni"
@@ -232,9 +228,7 @@
 "No character variables with accepted delimiters detected.","Hakuna vigezo vya herufi vilivyo na vidhibiti vinavyokubalika vilivyogunduliwa."
 "Apply split","Tumia mgawanyiko"
 "Stacked relative barplot","Kipande cha baruni kilichopangwa kwa mirundiko"
-"Create relative stacked barplots to show the distribution of categorical levels","Unda viwanja vya baruni vilivyopangwa ili kuonyesha usambazaji wa viwango vya kategoria"
 "Side-by-side barplot","Kipande cha baruni cha kando kwa kando"
-"Create side-by-side barplot to show the distribution of categorical levels","Unda mpangilio wa barufa kando ili kuonyesha usambazaji wa viwango vya kategoria"
 "Select table theme","Chagua mandhari ya jedwali"
 "Letters","Barua"
 "Words","Maneno"
@@ -328,3 +322,4 @@
 "Sample data","Sample data"
 "Settings","Settings"
 "Create new factor","Create new factor"
+"Choose color palette","Choose color palette"

inst/translations/translation_da.csv

@@ -89,7 +89,6 @@
 "No variables have a correlation measure above the threshold.","Ingen variabler er korrelerede over den angivne tærskelværdi."
 "and","og"
 "from each pair","fra hvert par"
-"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Kun variabler, der ikke er klassificerede som tekst er tilgængelige. Gå til fanen ""Forbered"" for at ændre klassifikationer."
 "Plot","Tegn"
 "Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""."
 "Plot height (mm)","Højde af grafik (mm)"
@@ -108,9 +107,7 @@
 "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.."
 "#Plotting\n","#Tegner\n"
 "Stacked horizontal bars","Stablede horisontale søjler"
-"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","En klassisk visualisering af fordelingen af observationer på en ordinal kategorisk skala. Typisk brugt til modified Rankin Scale og kendes også som 'Grotta bars'"
 "Violin plot","Violin-diagram"
-"A modern alternative to the classic boxplot to visualise data distribution","Moderne alternativ til den klassiske box-plot og velegnet til at visualisere fordelingen af observationer"
 "Sankey plot","Sankey-diagram"
 "A way of visualising change between groups","Visualiserer ændring mellem grupper for samme type observationer"
 "Scatter plot","Punkt-diagram"
@@ -118,7 +115,6 @@
 "Box plot","Kasse-diagram"
 "A classic way to plot data distribution by groups","Klassik måde at visualisere fordeling"
 "Euler diagram","Eulerdiagram"
-"Generate area-proportional Euler diagrams to display set relationships","Generer proportionelt Euler-diagram for at vise forhold mellem forskellige kategoriske observationer"
 "Documentation","Dokumentation"
 "Data is only stored for analyses and deleted when the app is closed.","Data opbevares alene til brug i analyser og slettes så snart appen lukkes."
 "Feedback","Feedback"
@@ -232,9 +228,7 @@
 "Split text","Opdel tekst"
 "Apply split","Anvend opdeling"
 "Stacked relative barplot","Stablet relativt søjlediagram"
-"Create relative stacked barplots to show the distribution of categorical levels","Opret relative stablede søjlediagrammer for at vise fordelingen af kategoriske niveauer"
 "Side-by-side barplot","Side om side barplot"
-"Create side-by-side barplot to show the distribution of categorical levels","Opret et side-om-side søjlediagram for at vise fordelingen af kategoriske niveauer"
 "Select table theme","Vælg tema"
 "Letters","Bogstaver"
 "Words","Ord"
@@ -328,3 +322,4 @@
 "Sample data","Sample data"
 "Settings","Settings"
 "Create new factor","Create new factor"
+"Choose color palette","Choose color palette"

inst/translations/translation_sw.csv

@@ -89,7 +89,6 @@
 "No variables have a correlation measure above the threshold.","Hakuna vigezo vyenye kipimo cha uhusiano kilicho juu ya kizingiti."
 "and","na"
 "from each pair","kutoka kwa kila jozi"
-"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Vigezo visivyo vya maandishi pekee ndivyo vinavyopatikana kwa ajili ya kupanga. Nenda kwenye ""Data"" ili kupanga upya data ili kupanga."
 "Plot","Kipande cha habari"
 "Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""."
 "Plot height (mm)","Urefu wa kiwanja (mm)"
@@ -108,9 +107,7 @@
 "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.."
 "#Plotting\n","#Upangaji\n"
 "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio"
-"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","Njia ya kitamaduni ya kuibua usambazaji wa mizani ya kawaida kama vile Mizani ya Nafasi iliyorekebishwa na inayojulikana kama baa za Grotta"
 "Violin plot","Hadithi ya violin"
-"A modern alternative to the classic boxplot to visualise data distribution","Njia mbadala ya kisasa ya mpangilio wa kisanduku wa kawaida ili kuibua usambazaji wa data"
 "Sankey plot","Njama ya Sankey"
 "A way of visualising change between groups","Njia ya kuibua mabadiliko kati ya vikundi"
 "Scatter plot","Njama ya kutawanya"
@@ -118,7 +115,6 @@
 "Box plot","Kipande cha sanduku"
 "A classic way to plot data distribution by groups","Njia ya kawaida ya kupanga usambazaji wa data kwa vikundi"
 "Euler diagram","Mchoro wa Euler"
-"Generate area-proportional Euler diagrams to display set relationships","Tengeneza michoro ya Euler inayolingana na eneo ili kuonyesha uhusiano uliowekwa"
 "Documentation","Nyaraka"
 "Data is only stored for analyses and deleted when the app is closed.","Data huhifadhiwa kwa ajili ya uchambuzi na kufutwa tu wakati programu imefungwa."
 "Feedback","Maoni"
@@ -232,9 +228,7 @@
 "No character variables with accepted delimiters detected.","Hakuna vigezo vya herufi vilivyo na vidhibiti vinavyokubalika vilivyogunduliwa."
 "Apply split","Tumia mgawanyiko"
 "Stacked relative barplot","Kipande cha baruni kilichopangwa kwa mirundiko"
-"Create relative stacked barplots to show the distribution of categorical levels","Unda viwanja vya baruni vilivyopangwa ili kuonyesha usambazaji wa viwango vya kategoria"
 "Side-by-side barplot","Kipande cha baruni cha kando kwa kando"
-"Create side-by-side barplot to show the distribution of categorical levels","Unda mpangilio wa barufa kando ili kuonyesha usambazaji wa viwango vya kategoria"
 "Select table theme","Chagua mandhari ya jedwali"
 "Letters","Barua"
 "Words","Maneno"
@@ -328,3 +322,4 @@
 "Sample data","Sample data"
 "Settings","Settings"
 "Create new factor","Create new factor"
+"Choose color palette","Choose color palette"

man/colorSelectInput.Rd

@@ -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)
+    }
+  )
+}
+}

man/continuous_colors.Rd

@@ -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()}}
+}

man/data-plots.Rd

@@ -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")
 }

man/generate_colors.Rd

@@ -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}}
+}

man/plot_euler.Rd

@@ -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}

man/plot_euler_single.Rd

@@ -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")
 }

man/plot_sankey_single.Rd

@@ -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")
 }

man/scale_fill_generate.Rd

@@ -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()}}
+}

man/vertical_stacked_bars.Rd

@@ -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{

renv.lock

@@ -35,12 +35,12 @@
     },
     "DHARMa": {
       "Package": "DHARMa",
-      "Version": "0.4.7",
+      "Version": "0.4.6",
       "Source": "Repository",
       "Title": "Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models",
-      "Date": "2024-10-16",
-      "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"), person(\"Melina\", \"de Souza leite\", role = \"ctb\"))",
-      "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB', 'GLMMadaptive', and 'spaMM'; phylogenetic  linear models from 'phylolm' (classes 'phylolm' and 'phyloglm'); generalized additive  models ('gam' from 'mgcv'); 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial, phylogenetic and temporal autocorrelation.",
+      "Date": "2022-09-08",
+      "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"))",
+      "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB' 'GLMMadaptive' and 'spaMM', generalized additive models ('gam' from 'mgcv'), 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial and temporal autocorrelation.",
       "Depends": [
         "R (>= 3.0.2)"
       ],
@@ -59,7 +59,7 @@
       ],
       "Suggests": [
         "knitr",
-        "testthat (>= 3.0.0)",
+        "testthat",
         "rmarkdown",
         "KernSmooth",
         "sfsmisc",
@@ -68,8 +68,7 @@
         "mgcViz (>= 0.1.9)",
         "spaMM (>= 3.2.0)",
         "GLMMadaptive",
-        "glmmTMB (>= 1.1.2.3)",
-        "phylolm (>= 2.6.5)"
+        "glmmTMB (>= 1.1.2.3)"
       ],
       "Enhances": [
         "phyr",
@@ -81,12 +80,11 @@
       "URL": "http://florianhartig.github.io/DHARMa/",
       "LazyData": "TRUE",
       "BugReports": "https://github.com/florianhartig/DHARMa/issues",
-      "RoxygenNote": "7.3.2",
+      "RoxygenNote": "7.2.1",
       "VignetteBuilder": "knitr",
       "Encoding": "UTF-8",
-      "Config/testthat/edition": "3",
       "NeedsCompilation": "no",
-      "Author": "Florian Hartig [aut, cre] (<https://orcid.org/0000-0002-6255-9059>), Lukas Lohse [ctb], Melina de Souza leite [ctb]",
+      "Author": "Florian Hartig [aut, cre] (<https://orcid.org/0000-0002-6255-9059>), Lukas Lohse [ctb]",
       "Maintainer": "Florian Hartig <florian.hartig@biologie.uni-regensburg.de>",
       "Repository": "CRAN"
     },
@@ -2347,7 +2345,7 @@
     },
     "datamods": {
       "Package": "datamods",
-      "Version": "1.5.3",
+      "Version": "1.5.2",
       "Source": "Repository",
       "Title": "Modules to Import and Manipulate Data in 'Shiny'",
       "Authors@R": "c(person(given = \"Victor\", family = \"Perrier\", role = c(\"aut\", \"cre\", \"cph\"), email = \"victor.perrier@dreamrs.fr\"), person(given = \"Fanny\", family = \"Meyer\", role = \"aut\"), person(given = \"Samra\", family = \"Goumri\", role = \"aut\"), person(given = \"Zauad Shahreer\", family = \"Abeer\", role = \"aut\", email = \"shahreyar.abeer@gmail.com\"), person(given = \"Eduard\", family = \"Szöcs\", role = \"ctb\", email = \"eduardszoecs@gmail.com\") )",
@@ -8359,7 +8357,7 @@
     },
     "shinybusy": {
       "Package": "shinybusy",
-      "Version": "0.3.3",
+      "Version": "0.3.2",
       "Source": "Repository",
       "Title": "Busy Indicators and Notifications for 'Shiny' Applications",
       "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))",
@@ -8372,8 +8370,8 @@
         "jsonlite",
         "htmlwidgets"
       ],
-      "RoxygenNote": "7.3.1",
-      "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/",
+      "RoxygenNote": "7.2.3",
+      "URL": "https://github.com/dreamRs/shinybusy",
       "BugReports": "https://github.com/dreamRs/shinybusy/issues",
       "Suggests": [
         "testthat",

tests/testthat/test-plot_colors.R

@@ -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))
+})