typo

CITATION.cff

@@ -8,7 +8,7 @@ message: 'To cite package "FreesearchR" in publications use:'
 type: software
 license: AGPL-3.0-or-later
 title: 'FreesearchR: Easy data analysis for clinicians'
-version: 26.3.5
+version: 26.3.6
 doi: 10.5281/zenodo.14527429
 identifiers:
 - type: url

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: FreesearchR
 Title: Easy data analysis for clinicians
-Version: 26.3.5
+Version: 26.3.6
 Authors@R: c(
     person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-7559-1154")),

NEWS.md

@@ -1,3 +1,9 @@
+# FreesearchR 26.3.6
+
+*FIX* Plot single variable in Likert plot.
+
+*FIX* Horizontal stacked plot crashed. Fixed!
+
 # FreesearchR 26.3.5
 
 *FIX* Labelled categorical variables were not handled correctly importing from REDCap resulting in lost labels. Fixed!

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'26.3.5'
+app_version <- function()'26.3.6'

R/data_plots.R

@@ -117,18 +117,7 @@ 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"
-                                ),
+                                palettes,
                                 ...) {
   shiny::moduleServer(
     id = id,
@@ -150,100 +139,6 @@ data_visuals_server <- function(id,
                                       title = i18n$t("Download"))
       })
 
-      # ## --- New attempt
-      #
-      # rv$plot.params <- shiny::reactive({
-      #   get_plot_options(input$type) |> purrr::pluck(1)
-      # })
-      #
-      # c(output,
-      #            list(shiny::renderUI({
-      #   columnSelectInput(
-      #     inputId = ns("primary"),
-      #     data = data,
-      #     placeholder = "Select variable",
-      #     label = "Response variable",
-      #     multiple = FALSE
-      #   )
-      # }),
-      # shiny::renderUI({
-      #   shiny::req(input$primary)
-      #   # browser()
-      #
-      #   if (!input$primary %in% names(data())) {
-      #     plot_data <- data()[1]
-      #   } else {
-      #     plot_data <- data()[input$primary]
-      #   }
-      #
-      #   plots <- possible_plots(
-      #     data = plot_data
-      #   )
-      #
-      #   plots_named <- get_plot_options(plots) |>
-      #     lapply(\(.x){
-      #       stats::setNames(.x$descr, .x$note)
-      #     })
-      #
-      #   vectorSelectInput(
-      #     inputId = ns("type"),
-      #     selected = NULL,
-      #     label = shiny::h4("Plot type"),
-      #     choices = Reduce(c, plots_named),
-      #     multiple = FALSE
-      #   )
-      # }),
-      # 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
-      #     )
-      #   )
-      #
-      #   columnSelectInput(
-      #     inputId = ns("secondary"),
-      #     data = data,
-      #     selected = cols[1],
-      #     placeholder = "Please select",
-      #     label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable",
-      #     multiple = rv$plot.params()[["secondary.multi"]],
-      #     maxItems = rv$plot.params()[["secondary.max"]],
-      #     col_subset = cols,
-      #     none_label = "No variable"
-      #   )
-      # }),
-      # shiny::renderUI({
-      #   shiny::req(input$type)
-      #   columnSelectInput(
-      #     inputId = ns("tertiary"),
-      #     data = data,
-      #     placeholder = "Please select",
-      #     label = "Grouping variable",
-      #     multiple = FALSE,
-      #     col_subset = c(
-      #       "none",
-      #       all_but(
-      #         colnames(subset_types(
-      #           data(),
-      #           rv$plot.params()[["tertiary.type"]]
-      #         )),
-      #         input$primary,
-      #         input$secondary
-      #       )
-      #     ),
-      #     none_label = "No stratification"
-      #   )
-      # })
-      # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE)
-
-
       output$primary <- shiny::renderUI({
         shiny::req(data())
         columnSelectInput(
@@ -258,13 +153,12 @@ data_visuals_server <- function(id,
 
       # shiny::observeEvent(data, {
       #   if (is.null(data()) | NROW(data()) == 0) {
-      #     shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE)
+      #     shiny::updateActionButton(inputId = "act_plot", disabled = TRUE)
       #   } else {
-      #     shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE)
+      #     shiny::updateActionButton(inputId = "act_plot", disabled = FALSE)
       #   }
       # })
 
-
       output$type <- shiny::renderUI({
         shiny::req(input$primary)
         shiny::req(data())
@@ -610,6 +504,7 @@ supported_plots <- function() {
       primary.type = c("dichotomous", "categorical"),
       secondary.type = c("dichotomous", "categorical"),
       secondary.multi = TRUE,
+      secondary.extra = NULL,
       tertiary.type = c("dichotomous", "categorical"),
       secondary.extra = NULL
     )

R/generate_colors.R

@@ -56,7 +56,8 @@
 #'
 #' @export
 generate_colors <- function(n, palette = "viridis", ...) {
-  if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
+  if (!is.numeric(n) ||
+      length(n) != 1 || n < 1 || n != as.integer(n)) {
     stop("`n` must be a single positive integer.")
   }
 
@@ -69,7 +70,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
     stop("`palette` must be a single character string or a function.")
   }
 
-  if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
+  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) {
@@ -78,10 +80,14 @@ generate_colors <- function(n, palette = "viridis", ...) {
 
   palette_lower <- tolower(palette)
 
-  viridis_palettes <- c(
-    "viridis", "magma", "plasma", "inferno",
-    "cividis", "mako", "rocket", "turbo"
-  )
+  viridis_palettes <- c("viridis",
+                        "magma",
+                        "plasma",
+                        "inferno",
+                        "cividis",
+                        "mako",
+                        "rocket",
+                        "turbo")
 
   if (palette_lower %in% viridis_palettes) {
     viridisLite::viridis(n = n, option = palette_lower, ...)
@@ -114,8 +120,11 @@ generate_colors <- function(n, palette = "viridis", ...) {
     grDevices::hcl.colors(n = n, palette = palette, ...)
 
   } else {
-    message(paste0(
-      "Unknown palette: '", palette, "'. ",
+    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",
@@ -123,7 +132,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
         "  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)
   }
@@ -166,7 +176,9 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
   ramp   <- grDevices::colorRamp(colors)
 
   function(x) {
-    if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].")
+    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)
   }
@@ -200,18 +212,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
 #'
 #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()]
 #' @export
-scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
+scale_fill_generate <- function(palette = "viridis",
+                                discrete = TRUE,
+                                ...) {
   if (discrete) {
     ggplot2::discrete_scale(
       aesthetics = "fill",
-      palette    = function(n) generate_colors(n, palette),
+      palette    = function(n)
+        generate_colors(n, palette),
       ...
     )
   } else {
-    ggplot2::scale_fill_gradientn(
-      colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
-      ...
-    )
+    ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
   }
 }
 
@@ -221,17 +233,33 @@ scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
 #'   geom_point() +
 #'   scale_color_generate(palette = "Set1")
 #' @export
-scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) {
+scale_color_generate <- function(palette = "viridis",
+                                 discrete = TRUE,
+                                 ...) {
   if (discrete) {
     ggplot2::discrete_scale(
       aesthetics = "colour",
-      palette    = function(n) generate_colors(n, palette),
+      palette    = function(n)
+        generate_colors(n, palette),
       ...
     )
   } else {
-    ggplot2::scale_color_gradientn(
-      colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
-      ...
-    )
+    ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
   }
 }
+
+
+color_choices <- function() {
+  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"
+  )
+}

R/hosted_version.R

@@ -1 +1 @@
-hosted_version <- function()'v26.3.5-260330'
+hosted_version <- function()'v26.3.6-260331'

R/plot_bar.R

@@ -56,30 +56,12 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "
 
 
   if (nrow(p_data) > max_level) {
-    # browser()
     p_data <- sort_by(
       p_data,
       p_data[["Freq"]],
       decreasing = TRUE
     ) |>
       head(max_level)
-    # if (is.null(sec)){
-    #   p_data <- sort_by(
-    #     p_data,
-    #     p_data[["Freq"]],
-    #     decreasing=TRUE) |>
-    #     head(max_level)
-    # } else {
-    #   split(p_data,p_data[[sec]]) |>
-    #     lapply(\(.x){
-    #       # browser()
-    #     sort_by(
-    #       .x,
-    #       .x[["Freq"]],
-    #       decreasing=TRUE) |>
-    #       head(max_level)
-    #   }) |> dplyr::bind_rows()
-    # }
   }
 
   ## Shortens long level names

R/plot_hbar.R

@@ -10,7 +10,7 @@
 #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
 #' 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 |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis")
 plot_hbars <- function(data,
                        pri,
                        sec,
@@ -41,7 +41,7 @@ vertical_stacked_bars <- function(data,
                                   score = "full_score",
                                   group = "pase_0_q",
                                   strata = NULL,
-                                  t.size = 10,
+                                  t.size = 8,
                                   l.color = "black",
                                   l.size = .5,
                                   draw.lines = TRUE,
@@ -77,12 +77,12 @@ vertical_stacked_bars <- function(data,
   if (isTRUE(reverse)) {
     colors <- rev(colors)
   }
-  contrast_cut <-
-    contrast_text(colors, threshold = .3) == "white"
 
   score_label <- data |> get_label(var = score)
   group_label <- data |> get_label(var = group)
 
+  # browser()
+
   p |>
     (\(.x) {
       .x$plot +
@@ -94,7 +94,7 @@ vertical_stacked_bars <- function(data,
           ggplot2::aes(
             x = group,
             y = p_prev + 0.49 * p,
-            color = contrast_cut,
+            color = contrast_text(colors[as.numeric(score)], threshold = .3),
             # label = paste0(sprintf("%2.0f", 100 * p),"%"),
             # label = sprintf("%2.0f", 100 * p)
             label = glue::glue(label.str)
@@ -103,8 +103,7 @@ vertical_stacked_bars <- function(data,
         ggplot2::labs(fill = score_label) +
         ggplot2::scale_fill_manual(values = colors) +
         ggplot2::theme(legend.position = "bottom",
-                       axis.title = ggplot2::element_text(),
-        ) +
+                       axis.title = ggplot2::element_text(),) +
         ggplot2::xlab(group_label) +
         ggplot2::ylab(NULL)
     })()

R/plot_likert.R

@@ -22,18 +22,24 @@ plot_likert <- function(data,
     ds <- list(data)
   }
   out <- lapply(ds, \(.x) {
-    .x[c(pri, sec)] |>
-      # na.omit() |>
-      plot_likert_single(color.palette = color.palette)
+    plot_likert_single(
+      data = .x,
+      include = tidyselect::any_of(c(pri, sec)),
+      color.palette = color.palette
+    )
   })
 
   wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")))
 }
 
 
-plot_likert_single <- function(data, color.palette = "viridis") {
-  ggstats::gglikert(data = data) +
-    scale_fill_generate(palette=color.palette)+
+plot_likert_single <- function(data,
+                               include = dplyr::everything(),
+                               color.palette = "viridis") {
+  data |>
+    dplyr::as_tibble() |>
+    ggstats::gglikert(include = include) +
+    scale_fill_generate(palette = color.palette) +
     ggplot2::theme(
       # legend.position = "none",
       # panel.grid.major = element_blank(),

SESSION.md

@@ -4,18 +4,18 @@
 |setting     |value                                      |
 |:-----------|:------------------------------------------|
 |version     |R version 4.5.2 (2025-10-31)               |
-|os          |macOS Tahoe 26.3                           |
+|os          |macOS Tahoe 26.4                           |
 |system      |aarch64, darwin20                          |
 |ui          |RStudio                                    |
 |language    |(EN)                                       |
 |collate     |en_US.UTF-8                                |
 |ctype       |en_US.UTF-8                                |
 |tz          |Europe/Copenhagen                          |
-|date        |2026-03-30                                 |
+|date        |2026-03-31                                 |
 |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.5.260330                              |
+|FreesearchR |26.3.6.260331                              |
                                                                                 
                                                                                 
 --------------------------------------------------------------------------------
@@ -84,7 +84,7 @@
 |foreach           |1.5.2         |2022-02-02 |CRAN (R 4.5.0) |
 |foreign           |0.8-91        |2026-01-29 |CRAN (R 4.5.2) |
 |Formula           |1.2-5         |2023-02-24 |CRAN (R 4.5.0) |
-|FreesearchR       |26.3.5        |NA         |NA             |
+|FreesearchR       |26.3.6        |NA         |NA             |
 |fs                |1.6.7         |2026-03-06 |CRAN (R 4.5.2) |
 |gdtools           |0.5.0         |2026-02-09 |CRAN (R 4.5.2) |
 |generics          |0.1.4         |2025-05-09 |CRAN (R 4.5.0) |
@@ -150,6 +150,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) |
+|polyglotr         |1.7.1         |NA         |NA             |
 |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) |
@@ -187,10 +188,12 @@
 |rprojroot         |2.1.1         |2025-08-26 |CRAN (R 4.5.0) |
 |rsconnect         |1.7.0         |2025-12-06 |CRAN (R 4.5.2) |
 |rstudioapi        |0.18.0        |2026-01-16 |CRAN (R 4.5.2) |
+|rvest             |1.0.5         |NA         |NA             |
 |S7                |0.2.1         |2025-11-14 |CRAN (R 4.5.2) |
 |sass              |0.4.10        |2025-04-11 |CRAN (R 4.5.0) |
 |scales            |1.4.0         |2025-04-24 |CRAN (R 4.5.0) |
 |see               |0.13.0        |2026-01-30 |CRAN (R 4.5.2) |
+|selectr           |0.5-1         |NA         |NA             |
 |sessioninfo       |1.2.3         |2025-02-05 |CRAN (R 4.5.0) |
 |shiny             |1.13.0        |2026-02-20 |CRAN (R 4.5.2) |
 |shiny.i18n        |0.3.0         |2023-01-16 |CRAN (R 4.5.0) |
@@ -211,10 +214,13 @@
 |tidyselect        |1.2.1         |2024-03-11 |CRAN (R 4.5.0) |
 |timechange        |0.4.0         |2026-01-29 |CRAN (R 4.5.2) |
 |toastui           |0.4.0         |2025-04-03 |CRAN (R 4.5.0) |
+|triebeard         |0.4.1         |NA         |NA             |
 |tweenr            |2.0.3         |2024-02-26 |CRAN (R 4.5.0) |
 |twosamples        |2.0.1         |2023-06-23 |CRAN (R 4.5.0) |
 |tzdb              |0.5.0         |2025-03-15 |CRAN (R 4.5.0) |
+|urltools          |1.7.3.1       |NA         |NA             |
 |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) |
 |vctrs             |0.7.1         |2026-01-23 |CRAN (R 4.5.2) |
 |viridis           |0.6.5         |2024-01-29 |CRAN (R 4.5.0) |

app_docker/app.R

@@ -1,7 +1,7 @@
 
 
 ########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp1OaGW3/file656737f80bdf.R 
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpRQAQCo/file4ab639355bd6.R 
 ########
 
 i18n_path <- here::here("translations")
@@ -64,7 +64,7 @@ i18n$set_translation_language("en")
 #### Current file: /Users/au301842/FreesearchR/R//app_version.R 
 ########
 
-app_version <- function()'26.3.5'
+app_version <- function()'26.3.6'
 
 
 ########
@@ -2254,18 +2254,7 @@ 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"
-                                ),
+                                palettes,
                                 ...) {
   shiny::moduleServer(
     id = id,
@@ -2287,100 +2276,6 @@ data_visuals_server <- function(id,
                                       title = i18n$t("Download"))
       })
 
-      # ## --- New attempt
-      #
-      # rv$plot.params <- shiny::reactive({
-      #   get_plot_options(input$type) |> purrr::pluck(1)
-      # })
-      #
-      # c(output,
-      #            list(shiny::renderUI({
-      #   columnSelectInput(
-      #     inputId = ns("primary"),
-      #     data = data,
-      #     placeholder = "Select variable",
-      #     label = "Response variable",
-      #     multiple = FALSE
-      #   )
-      # }),
-      # shiny::renderUI({
-      #   shiny::req(input$primary)
-      #   # browser()
-      #
-      #   if (!input$primary %in% names(data())) {
-      #     plot_data <- data()[1]
-      #   } else {
-      #     plot_data <- data()[input$primary]
-      #   }
-      #
-      #   plots <- possible_plots(
-      #     data = plot_data
-      #   )
-      #
-      #   plots_named <- get_plot_options(plots) |>
-      #     lapply(\(.x){
-      #       stats::setNames(.x$descr, .x$note)
-      #     })
-      #
-      #   vectorSelectInput(
-      #     inputId = ns("type"),
-      #     selected = NULL,
-      #     label = shiny::h4("Plot type"),
-      #     choices = Reduce(c, plots_named),
-      #     multiple = FALSE
-      #   )
-      # }),
-      # 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
-      #     )
-      #   )
-      #
-      #   columnSelectInput(
-      #     inputId = ns("secondary"),
-      #     data = data,
-      #     selected = cols[1],
-      #     placeholder = "Please select",
-      #     label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable",
-      #     multiple = rv$plot.params()[["secondary.multi"]],
-      #     maxItems = rv$plot.params()[["secondary.max"]],
-      #     col_subset = cols,
-      #     none_label = "No variable"
-      #   )
-      # }),
-      # shiny::renderUI({
-      #   shiny::req(input$type)
-      #   columnSelectInput(
-      #     inputId = ns("tertiary"),
-      #     data = data,
-      #     placeholder = "Please select",
-      #     label = "Grouping variable",
-      #     multiple = FALSE,
-      #     col_subset = c(
-      #       "none",
-      #       all_but(
-      #         colnames(subset_types(
-      #           data(),
-      #           rv$plot.params()[["tertiary.type"]]
-      #         )),
-      #         input$primary,
-      #         input$secondary
-      #       )
-      #     ),
-      #     none_label = "No stratification"
-      #   )
-      # })
-      # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE)
-
-
       output$primary <- shiny::renderUI({
         shiny::req(data())
         columnSelectInput(
@@ -2395,13 +2290,12 @@ data_visuals_server <- function(id,
 
       # shiny::observeEvent(data, {
       #   if (is.null(data()) | NROW(data()) == 0) {
-      #     shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE)
+      #     shiny::updateActionButton(inputId = "act_plot", disabled = TRUE)
       #   } else {
-      #     shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE)
+      #     shiny::updateActionButton(inputId = "act_plot", disabled = FALSE)
       #   }
       # })
 
-
       output$type <- shiny::renderUI({
         shiny::req(input$primary)
         shiny::req(data())
@@ -2747,6 +2641,7 @@ supported_plots <- function() {
       primary.type = c("dichotomous", "categorical"),
       secondary.type = c("dichotomous", "categorical"),
       secondary.multi = TRUE,
+      secondary.extra = NULL,
       tertiary.type = c("dichotomous", "categorical"),
       secondary.extra = NULL
     )
@@ -3918,7 +3813,8 @@ footer_ui <- function(i18n) {
 #'
 #' @export
 generate_colors <- function(n, palette = "viridis", ...) {
-  if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
+  if (!is.numeric(n) ||
+      length(n) != 1 || n < 1 || n != as.integer(n)) {
     stop("`n` must be a single positive integer.")
   }
 
@@ -3931,7 +3827,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
     stop("`palette` must be a single character string or a function.")
   }
 
-  if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
+  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) {
@@ -3940,10 +3837,14 @@ generate_colors <- function(n, palette = "viridis", ...) {
 
   palette_lower <- tolower(palette)
 
-  viridis_palettes <- c(
-    "viridis", "magma", "plasma", "inferno",
-    "cividis", "mako", "rocket", "turbo"
-  )
+  viridis_palettes <- c("viridis",
+                        "magma",
+                        "plasma",
+                        "inferno",
+                        "cividis",
+                        "mako",
+                        "rocket",
+                        "turbo")
 
   if (palette_lower %in% viridis_palettes) {
     viridisLite::viridis(n = n, option = palette_lower, ...)
@@ -3976,8 +3877,11 @@ generate_colors <- function(n, palette = "viridis", ...) {
     grDevices::hcl.colors(n = n, palette = palette, ...)
 
   } else {
-    message(paste0(
-      "Unknown palette: '", palette, "'. ",
+    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",
@@ -3985,7 +3889,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
         "  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)
   }
@@ -4028,7 +3933,9 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
   ramp   <- grDevices::colorRamp(colors)
 
   function(x) {
-    if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].")
+    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)
   }
@@ -4062,18 +3969,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
 #'
 #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()]
 #' @export
-scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
+scale_fill_generate <- function(palette = "viridis",
+                                discrete = TRUE,
+                                ...) {
   if (discrete) {
     ggplot2::discrete_scale(
       aesthetics = "fill",
-      palette    = function(n) generate_colors(n, palette),
+      palette    = function(n)
+        generate_colors(n, palette),
       ...
     )
   } else {
-    ggplot2::scale_fill_gradientn(
-      colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
-      ...
-    )
+    ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
   }
 }
 
@@ -4083,22 +3990,38 @@ scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
 #'   geom_point() +
 #'   scale_color_generate(palette = "Set1")
 #' @export
-scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) {
+scale_color_generate <- function(palette = "viridis",
+                                 discrete = TRUE,
+                                 ...) {
   if (discrete) {
     ggplot2::discrete_scale(
       aesthetics = "colour",
-      palette    = function(n) generate_colors(n, palette),
+      palette    = function(n)
+        generate_colors(n, palette),
       ...
     )
   } else {
-    ggplot2::scale_color_gradientn(
-      colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
-      ...
-    )
+    ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
   }
 }
 
 
+color_choices <- function() {
+  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"
+  )
+}
+
+
 ########
 #### Current file: /Users/au301842/FreesearchR/R//helpers.R 
 ########
@@ -5002,7 +4925,7 @@ apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()
 #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R 
 ########
 
-hosted_version <- function()'v26.3.5-260330'
+hosted_version <- function()'v26.3.6-260331'
 
 
 ########
@@ -7041,30 +6964,12 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "
 
 
   if (nrow(p_data) > max_level) {
-    # browser()
     p_data <- sort_by(
       p_data,
       p_data[["Freq"]],
       decreasing = TRUE
     ) |>
       head(max_level)
-    # if (is.null(sec)){
-    #   p_data <- sort_by(
-    #     p_data,
-    #     p_data[["Freq"]],
-    #     decreasing=TRUE) |>
-    #     head(max_level)
-    # } else {
-    #   split(p_data,p_data[[sec]]) |>
-    #     lapply(\(.x){
-    #       # browser()
-    #     sort_by(
-    #       .x,
-    #       .x[["Freq"]],
-    #       decreasing=TRUE) |>
-    #       head(max_level)
-    #   }) |> dplyr::bind_rows()
-    # }
   }
 
   ## Shortens long level names
@@ -7388,7 +7293,7 @@ plot_euler_single <- function(data,color.palette="viridis") {
 #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
 #' 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 |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis")
 plot_hbars <- function(data,
                        pri,
                        sec,
@@ -7419,7 +7324,7 @@ vertical_stacked_bars <- function(data,
                                   score = "full_score",
                                   group = "pase_0_q",
                                   strata = NULL,
-                                  t.size = 10,
+                                  t.size = 8,
                                   l.color = "black",
                                   l.size = .5,
                                   draw.lines = TRUE,
@@ -7455,12 +7360,12 @@ vertical_stacked_bars <- function(data,
   if (isTRUE(reverse)) {
     colors <- rev(colors)
   }
-  contrast_cut <-
-    contrast_text(colors, threshold = .3) == "white"
 
   score_label <- data |> get_label(var = score)
   group_label <- data |> get_label(var = group)
 
+  # browser()
+
   p |>
     (\(.x) {
       .x$plot +
@@ -7472,7 +7377,7 @@ vertical_stacked_bars <- function(data,
           ggplot2::aes(
             x = group,
             y = p_prev + 0.49 * p,
-            color = contrast_cut,
+            color = contrast_text(colors[as.numeric(score)], threshold = .3),
             # label = paste0(sprintf("%2.0f", 100 * p),"%"),
             # label = sprintf("%2.0f", 100 * p)
             label = glue::glue(label.str)
@@ -7481,8 +7386,7 @@ vertical_stacked_bars <- function(data,
         ggplot2::labs(fill = score_label) +
         ggplot2::scale_fill_manual(values = colors) +
         ggplot2::theme(legend.position = "bottom",
-                       axis.title = ggplot2::element_text(),
-        ) +
+                       axis.title = ggplot2::element_text(),) +
         ggplot2::xlab(group_label) +
         ggplot2::ylab(NULL)
     })()
@@ -7517,18 +7421,24 @@ plot_likert <- function(data,
     ds <- list(data)
   }
   out <- lapply(ds, \(.x) {
-    .x[c(pri, sec)] |>
-      # na.omit() |>
-      plot_likert_single(color.palette = color.palette)
+    plot_likert_single(
+      data = .x,
+      include = tidyselect::any_of(c(pri, sec)),
+      color.palette = color.palette
+    )
   })
 
   wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")))
 }
 
 
-plot_likert_single <- function(data, color.palette = "viridis") {
-  ggstats::gglikert(data = data) +
-    scale_fill_generate(palette=color.palette)+
+plot_likert_single <- function(data,
+                               include = dplyr::everything(),
+                               color.palette = "viridis") {
+  data |>
+    dplyr::as_tibble() |>
+    ggstats::gglikert(include = include) +
+    scale_fill_generate(palette = color.palette) +
     ggplot2::theme(
       # legend.position = "none",
       # panel.grid.major = element_blank(),
@@ -16164,7 +16074,9 @@ server <- function(input, output, session) {
   #########
   ##############################################################################
 
-  pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data))
+  pl <- data_visuals_server("visuals",
+                            data = shiny::reactive(rv$list$data),
+                            palettes = color_choices())
 
   ##############################################################################
   #########

inst/apps/FreesearchR/app.R

@@ -1,7 +1,7 @@
 
 
 ########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpgCu9u6/file55d839c4d43b.R 
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpRQAQCo/file4ab61747a8d7.R 
 ########
 
 i18n_path <- system.file("translations", package = "FreesearchR")
@@ -64,7 +64,7 @@ i18n$set_translation_language("en")
 #### Current file: /Users/au301842/FreesearchR/R//app_version.R 
 ########
 
-app_version <- function()'26.3.5'
+app_version <- function()'26.3.6'
 
 
 ########
@@ -2254,18 +2254,7 @@ 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"
-                                ),
+                                palettes,
                                 ...) {
   shiny::moduleServer(
     id = id,
@@ -2287,100 +2276,6 @@ data_visuals_server <- function(id,
                                       title = i18n$t("Download"))
       })
 
-      # ## --- New attempt
-      #
-      # rv$plot.params <- shiny::reactive({
-      #   get_plot_options(input$type) |> purrr::pluck(1)
-      # })
-      #
-      # c(output,
-      #            list(shiny::renderUI({
-      #   columnSelectInput(
-      #     inputId = ns("primary"),
-      #     data = data,
-      #     placeholder = "Select variable",
-      #     label = "Response variable",
-      #     multiple = FALSE
-      #   )
-      # }),
-      # shiny::renderUI({
-      #   shiny::req(input$primary)
-      #   # browser()
-      #
-      #   if (!input$primary %in% names(data())) {
-      #     plot_data <- data()[1]
-      #   } else {
-      #     plot_data <- data()[input$primary]
-      #   }
-      #
-      #   plots <- possible_plots(
-      #     data = plot_data
-      #   )
-      #
-      #   plots_named <- get_plot_options(plots) |>
-      #     lapply(\(.x){
-      #       stats::setNames(.x$descr, .x$note)
-      #     })
-      #
-      #   vectorSelectInput(
-      #     inputId = ns("type"),
-      #     selected = NULL,
-      #     label = shiny::h4("Plot type"),
-      #     choices = Reduce(c, plots_named),
-      #     multiple = FALSE
-      #   )
-      # }),
-      # 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
-      #     )
-      #   )
-      #
-      #   columnSelectInput(
-      #     inputId = ns("secondary"),
-      #     data = data,
-      #     selected = cols[1],
-      #     placeholder = "Please select",
-      #     label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable",
-      #     multiple = rv$plot.params()[["secondary.multi"]],
-      #     maxItems = rv$plot.params()[["secondary.max"]],
-      #     col_subset = cols,
-      #     none_label = "No variable"
-      #   )
-      # }),
-      # shiny::renderUI({
-      #   shiny::req(input$type)
-      #   columnSelectInput(
-      #     inputId = ns("tertiary"),
-      #     data = data,
-      #     placeholder = "Please select",
-      #     label = "Grouping variable",
-      #     multiple = FALSE,
-      #     col_subset = c(
-      #       "none",
-      #       all_but(
-      #         colnames(subset_types(
-      #           data(),
-      #           rv$plot.params()[["tertiary.type"]]
-      #         )),
-      #         input$primary,
-      #         input$secondary
-      #       )
-      #     ),
-      #     none_label = "No stratification"
-      #   )
-      # })
-      # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE)
-
-
       output$primary <- shiny::renderUI({
         shiny::req(data())
         columnSelectInput(
@@ -2395,13 +2290,12 @@ data_visuals_server <- function(id,
 
       # shiny::observeEvent(data, {
       #   if (is.null(data()) | NROW(data()) == 0) {
-      #     shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE)
+      #     shiny::updateActionButton(inputId = "act_plot", disabled = TRUE)
       #   } else {
-      #     shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE)
+      #     shiny::updateActionButton(inputId = "act_plot", disabled = FALSE)
       #   }
       # })
 
-
       output$type <- shiny::renderUI({
         shiny::req(input$primary)
         shiny::req(data())
@@ -2747,6 +2641,7 @@ supported_plots <- function() {
       primary.type = c("dichotomous", "categorical"),
       secondary.type = c("dichotomous", "categorical"),
       secondary.multi = TRUE,
+      secondary.extra = NULL,
       tertiary.type = c("dichotomous", "categorical"),
       secondary.extra = NULL
     )
@@ -3918,7 +3813,8 @@ footer_ui <- function(i18n) {
 #'
 #' @export
 generate_colors <- function(n, palette = "viridis", ...) {
-  if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
+  if (!is.numeric(n) ||
+      length(n) != 1 || n < 1 || n != as.integer(n)) {
     stop("`n` must be a single positive integer.")
   }
 
@@ -3931,7 +3827,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
     stop("`palette` must be a single character string or a function.")
   }
 
-  if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) {
+  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) {
@@ -3940,10 +3837,14 @@ generate_colors <- function(n, palette = "viridis", ...) {
 
   palette_lower <- tolower(palette)
 
-  viridis_palettes <- c(
-    "viridis", "magma", "plasma", "inferno",
-    "cividis", "mako", "rocket", "turbo"
-  )
+  viridis_palettes <- c("viridis",
+                        "magma",
+                        "plasma",
+                        "inferno",
+                        "cividis",
+                        "mako",
+                        "rocket",
+                        "turbo")
 
   if (palette_lower %in% viridis_palettes) {
     viridisLite::viridis(n = n, option = palette_lower, ...)
@@ -3976,8 +3877,11 @@ generate_colors <- function(n, palette = "viridis", ...) {
     grDevices::hcl.colors(n = n, palette = palette, ...)
 
   } else {
-    message(paste0(
-      "Unknown palette: '", palette, "'. ",
+    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",
@@ -3985,7 +3889,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
         "  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)
   }
@@ -4028,7 +3933,9 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
   ramp   <- grDevices::colorRamp(colors)
 
   function(x) {
-    if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].")
+    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)
   }
@@ -4062,18 +3969,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
 #'
 #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()]
 #' @export
-scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
+scale_fill_generate <- function(palette = "viridis",
+                                discrete = TRUE,
+                                ...) {
   if (discrete) {
     ggplot2::discrete_scale(
       aesthetics = "fill",
-      palette    = function(n) generate_colors(n, palette),
+      palette    = function(n)
+        generate_colors(n, palette),
       ...
     )
   } else {
-    ggplot2::scale_fill_gradientn(
-      colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
-      ...
-    )
+    ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
   }
 }
 
@@ -4083,22 +3990,38 @@ scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
 #'   geom_point() +
 #'   scale_color_generate(palette = "Set1")
 #' @export
-scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) {
+scale_color_generate <- function(palette = "viridis",
+                                 discrete = TRUE,
+                                 ...) {
   if (discrete) {
     ggplot2::discrete_scale(
       aesthetics = "colour",
-      palette    = function(n) generate_colors(n, palette),
+      palette    = function(n)
+        generate_colors(n, palette),
       ...
     )
   } else {
-    ggplot2::scale_color_gradientn(
-      colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
-      ...
-    )
+    ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
   }
 }
 
 
+color_choices <- function() {
+  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"
+  )
+}
+
+
 ########
 #### Current file: /Users/au301842/FreesearchR/R//helpers.R 
 ########
@@ -5002,7 +4925,7 @@ apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()
 #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R 
 ########
 
-hosted_version <- function()'v26.3.5-260330'
+hosted_version <- function()'v26.3.6-260331'
 
 
 ########
@@ -7041,30 +6964,12 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "
 
 
   if (nrow(p_data) > max_level) {
-    # browser()
     p_data <- sort_by(
       p_data,
       p_data[["Freq"]],
       decreasing = TRUE
     ) |>
       head(max_level)
-    # if (is.null(sec)){
-    #   p_data <- sort_by(
-    #     p_data,
-    #     p_data[["Freq"]],
-    #     decreasing=TRUE) |>
-    #     head(max_level)
-    # } else {
-    #   split(p_data,p_data[[sec]]) |>
-    #     lapply(\(.x){
-    #       # browser()
-    #     sort_by(
-    #       .x,
-    #       .x[["Freq"]],
-    #       decreasing=TRUE) |>
-    #       head(max_level)
-    #   }) |> dplyr::bind_rows()
-    # }
   }
 
   ## Shortens long level names
@@ -7388,7 +7293,7 @@ plot_euler_single <- function(data,color.palette="viridis") {
 #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
 #' 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 |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis")
 plot_hbars <- function(data,
                        pri,
                        sec,
@@ -7419,7 +7324,7 @@ vertical_stacked_bars <- function(data,
                                   score = "full_score",
                                   group = "pase_0_q",
                                   strata = NULL,
-                                  t.size = 10,
+                                  t.size = 8,
                                   l.color = "black",
                                   l.size = .5,
                                   draw.lines = TRUE,
@@ -7455,12 +7360,12 @@ vertical_stacked_bars <- function(data,
   if (isTRUE(reverse)) {
     colors <- rev(colors)
   }
-  contrast_cut <-
-    contrast_text(colors, threshold = .3) == "white"
 
   score_label <- data |> get_label(var = score)
   group_label <- data |> get_label(var = group)
 
+  # browser()
+
   p |>
     (\(.x) {
       .x$plot +
@@ -7472,7 +7377,7 @@ vertical_stacked_bars <- function(data,
           ggplot2::aes(
             x = group,
             y = p_prev + 0.49 * p,
-            color = contrast_cut,
+            color = contrast_text(colors[as.numeric(score)], threshold = .3),
             # label = paste0(sprintf("%2.0f", 100 * p),"%"),
             # label = sprintf("%2.0f", 100 * p)
             label = glue::glue(label.str)
@@ -7481,8 +7386,7 @@ vertical_stacked_bars <- function(data,
         ggplot2::labs(fill = score_label) +
         ggplot2::scale_fill_manual(values = colors) +
         ggplot2::theme(legend.position = "bottom",
-                       axis.title = ggplot2::element_text(),
-        ) +
+                       axis.title = ggplot2::element_text(),) +
         ggplot2::xlab(group_label) +
         ggplot2::ylab(NULL)
     })()
@@ -7517,18 +7421,24 @@ plot_likert <- function(data,
     ds <- list(data)
   }
   out <- lapply(ds, \(.x) {
-    .x[c(pri, sec)] |>
-      # na.omit() |>
-      plot_likert_single(color.palette = color.palette)
+    plot_likert_single(
+      data = .x,
+      include = tidyselect::any_of(c(pri, sec)),
+      color.palette = color.palette
+    )
   })
 
   wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")))
 }
 
 
-plot_likert_single <- function(data, color.palette = "viridis") {
-  ggstats::gglikert(data = data) +
-    scale_fill_generate(palette=color.palette)+
+plot_likert_single <- function(data,
+                               include = dplyr::everything(),
+                               color.palette = "viridis") {
+  data |>
+    dplyr::as_tibble() |>
+    ggstats::gglikert(include = include) +
+    scale_fill_generate(palette = color.palette) +
     ggplot2::theme(
       # legend.position = "none",
       # panel.grid.major = element_blank(),
@@ -16164,7 +16074,9 @@ server <- function(input, output, session) {
   #########
   ##############################################################################
 
-  pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data))
+  pl <- data_visuals_server("visuals",
+                            data = shiny::reactive(rv$list$data),
+                            palettes = color_choices())
 
   ##############################################################################
   #########

man/data-plots.Rd

@@ -21,16 +21,7 @@
 \usage{
 data_visuals_ui(id, tab_title = "Plots", ...)
 
-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"),
-  ...
-)
+data_visuals_server(id, data, palettes, ...)
 
 create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...)
 
@@ -170,7 +161,7 @@ mtcars |> plot_hbars(pri = "carb", sec = "cyl")
 mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am")
 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 |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis")
 mtcars |> plot_likert(pri = "carb", sec = "cyl")
 mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am")
 mtcars |> plot_likert(pri = "cyl",color.palette="Blues")

man/vertical_stacked_bars.Rd

@@ -9,7 +9,7 @@ vertical_stacked_bars(
   score = "full_score",
   group = "pase_0_q",
   strata = NULL,
-  t.size = 10,
+  t.size = 8,
   l.color = "black",
   l.size = 0.5,
   draw.lines = TRUE,