From 7b0692fd1764b9adbd552ca4cade7d21e92233b9 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:41:09 +0200 Subject: [PATCH 1/6] fix: as tibble to allow single variable plotting --- R/plot_likert.R | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/R/plot_likert.R b/R/plot_likert.R index 625bb844..c18c57a1 100644 --- a/R/plot_likert.R +++ b/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(), From 46c6ed03ae9d9af7f7e0d081b67c4dcdc711e753 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:41:36 +0200 Subject: [PATCH 2/6] fix: adjusted text size and text color --- R/plot_hbar.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/R/plot_hbar.R b/R/plot_hbar.R index 0a0ec320..d93ef4c9 100644 --- a/R/plot_hbar.R +++ b/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) })() From d397532aedad42a95576314e1caff3cf9ba81bb8 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:41:53 +0200 Subject: [PATCH 3/6] fix: default colors as function --- R/generate_colors.R | 86 ++++++++++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 29 deletions(-) diff --git a/R/generate_colors.R b/R/generate_colors.R index ae9fa869..898c0a94 100644 --- a/R/generate_colors.R +++ b/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,16 +120,20 @@ generate_colors <- function(n, palette = "viridis", ...) { 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" - )) + 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) } @@ -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" + ) +} From de52a56b1f9b2efd4e31505a85a6ac44d4506607 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:42:22 +0200 Subject: [PATCH 4/6] new version ready --- CITATION.cff | 2 +- DESCRIPTION | 2 +- NEWS.md | 6 ++ R/app_version.R | 2 +- R/data_plots.R | 113 ++--------------------------------- R/hosted_version.R | 2 +- R/plot_bar.R | 18 ------ R/sysdata.rda | Bin 2704 -> 2770 bytes SESSION.md | 14 +++-- man/data-plots.Rd | 13 +--- man/vertical_stacked_bars.Rd | 2 +- 11 files changed, 27 insertions(+), 147 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 5578f1a5..ae7ae538 100644 --- a/CITATION.cff +++ b/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 diff --git a/DESCRIPTION b/DESCRIPTION index 3a60d461..23174866 100644 --- a/DESCRIPTION +++ b/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")), diff --git a/NEWS.md b/NEWS.md index 7c2bbc32..5773bef8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# FreesearchR 26.3.6 + +*FIX* Plot single variable in Likert plot. + +*FIX* Horisontal stacked plot crashed. Fixed! + # FreesearchR 26.3.5 *FIX* Labelled categorical variables were not handled correctly importing from REDCap resulting in lost labels. Fixed! diff --git a/R/app_version.R b/R/app_version.R index bdf15ee5..ac06a8a2 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.5' +app_version <- function()'26.3.6' diff --git a/R/data_plots.R b/R/data_plots.R index 1ae13694..439b0ccf 100644 --- a/R/data_plots.R +++ b/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 ) diff --git a/R/hosted_version.R b/R/hosted_version.R index 19c31921..f7e99a89 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.5-260330' +hosted_version <- function()'v26.3.6-260331' diff --git a/R/plot_bar.R b/R/plot_bar.R index 909c9edd..f820cc6b 100644 --- a/R/plot_bar.R +++ b/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 diff --git a/R/sysdata.rda b/R/sysdata.rda index e57187506ab34278de0c95073a5e1f6f763aa4ac..be267dbfe3b40f25930e615ab562574760211f60 100644 GIT binary patch literal 2770 zcmV;@3N7_QT4*^jL0KkKSFs-&^=8&O$Mp@ z0HSJ7BzjDyZ4)Wv$e1Unz>NS641-LK3^hEO5>x;NgFpZSKmY&$000tcA{0~8O+;zr zfY4^37=R2w10x8?4KWg#4^!0BMn*tr0MGyp0001KrXT?lku*&6)yuId4LASyB=_+6AuW8oP|xcXdv47x%ra+Ev<i zQvIBGa3RY~eC)tU1575pz9iOlkWIR%D1eZNpZ?HH+Y7X1EUZD4cYPcRMyh7&=8Oby zLJ%(RH5AG<3ohFc3HPTq2m%;eG+(TzPUmRHY%t>4wJDpEGPdq)i{W}aRqAkA zFwcK9*5^4T%>#E^5u;|!)>UpKZZ=U6z^3mX!$mowVx^kunN&$xC`+;g1Q!icOCdxo z78LMta|@0$4wWl%^KAxM96lyoO;I@GGOTFDTU(ijx`#(|%Ay-7La|Lx4U&;llDs=9 zgrs+8xGs>%2IU&^gXqT`Y~DdH3rpN+Fzj17M9ZfPyYQxnJs_}jly`L?isOI;hy;Q% zBA6jaf=H#Z-c^?E+}M|Z-hd*V06|6opb#V^H>fHi)l~!$L-zm?*?^!G^kogNuqZm& z_zhg50A+$9ubSJPeEBZn^=rXUbe&Qj7K~UTiYXYyQYyuYixoiyMPyY}6^M~kQAROE z7AQp^s|AWGF%VP{Po3ZNI?o>!RP#?&85Hx{!fnm=d9CwthK>q=vztnaB6GW!T)ef- zlWba8?#rEPjwNt-9x2OFb)}kiwq0#OGG?tYhOzRF-R%>mqAyQ8aPLkfOzW)1fRYISFvE2jxw5W6Wi^?+@C+NHD?*|HM+t*7D;X;i zr5WB$-BJT@buz+YTGmCA5HmMsLm8GauQGfsiEQ%o#1!V{fpe~I=lMXfRXDy7GJ#}#B4!Y$yoEd4gv}?RpZa`p? z3aCVwB)Eebv?MdYUNh4?tL14I(=lWUO zDb`lpGKq%p#hNJw)fQq~LaQZ24(Z(zQ%u$n)ctOZkhi}vCPY~jCMG6Y9zWxw1qZl* zo<_hJ$O@o>6SK18CKRH;ve0L-VTS)E%{}QVz9jTezF#k&+9r!yH7i$g5H29(u&kph zB36hX;M4|~B=JCG5_tS6dR3Ly8r4x{+7!TGf#^U3f&zyHNoy7pg2`kpSz#riWF$Lm z3n3*vZ==1EEGGPU+{0GD#%kqK+7@5Gm<$CJbk-q7wiMDU;-`ZGu^4|!b%;MU!<;&L zO)gS>FDDXlwuLrs;*60NAwha?xtEu@cz{8ld9LR76-lUu(mjIP*6eQ7+KE@QqDz?O=DNbZ@I_qf3JcsiaL=Tj*WuTeh_*s3oPSq*70>_E8r{CPxN|`BtfB6wXa4nViiCJwfGJ`wAJvSX*hBIXnjrcZs`lv7)Jzx*sDK|E69S%B8u@V81tZZU2S0f0`#OrywzfhCS9<# zMq}aOVzv~6xxGBJb5&z^sWm9k-Y~uP&t?d?j3_R2?8u*}Y8Wz;mXcZ{pneLQ(H#rT54u1u)rpMklL!|oAUNJThuuP7nK-MI0S1*HI?|`#@}U_O zU8SL+C~g)D4$K@aoFUWn9hAOK9Hf*BAz5o9etK)UyUW$~@aw)e5YJb^&^%qt#-oLf zm^kt=9c|^_q9!zo5@K%on%`PtXvu8W;!&31NID(FlVDN!&(pvznT@o@PT=mbPf%Ew z%=-{^Tfjh-`1CN)Pj?6Mglc3z(GI^OXrqq$suD2{UEx`g7Wt~)#JZ)oDT!26o6R(0 zpO)|3=4`E7^zNB_$e{6UjOPZV-ToPS1nLS!AZ~q2pq{E16M%RixZT3sa}Zm5wku%Y zmT(Y(ia6tHC>)3p8%EZ-V~MZHpJ7lH$PmwFiH0xfSu7~i1x7~8<8c_4GKzuOL3i0V-#dn!r#PDSAg4y#2y zziREl(6?y!(Mx7sx9OFL0{3vVM)DlKnL9%5D+ee+G>= z$H1JWFxRszY3mYmMLYXFb7^F<)JqZz`ua6?z=hV54x+#Hn5OL2_C)g4aeav69%@X{w{4{cE&q zcs_=_LR#;LLtIP29#r^)$@hmZkDGu(AT=wvrQp%(At-)jcV9-Yf<-C8m}rY z3{19Hyo47sA`z|7$sXHSUd5{%89x3}?^XiU5H==!mO91s^Tv&QcI)SzWoZ)5TYxFWnY(!x>;%l@&?I)o^rat1&BycBZSuq&U?$!m?CJHmYGvM^$h|v(*TSRz#}G_0}V7y8Z^Qs5@?9?RQ)6#ra&~v05kvqW}pF(8&d?U zaW5!v5V*%cEV65TAb{ z+}4v4@*ypkFwYLKi4a~XEoTH&t1wwFKV7{32MbvN~M4QcKj^a1LXAiHw{TFGfylry7X+&-v5*0l>+w_N;N2% zV>kGhx$gyk2`4X^lcz^+Td^?G#tEWLPQtR@wZgU1MlL)CE{UU3>CFjtr4O}2{W^29 zt8JrhGKhu+Gwy1lf#K#Es%4c#m6C+JAV5KI)ikmcL{VcCM>1+Ln`adnsjRv-)QKjT ztFm#MwPR_Dwykqe?@;LOcT_`LC}F9o;qFo@u3KhY8d*~=aYj`&M>d{$ImW|pw%clN zh>cL=R@4n{LYKw{U7BUzeG_?yq#XqP+>#yu2m%CvgbRoSNTsW8O?(=&5F1cc6J${l zf*=G52@R?$ptY?PL__x#LDPyL7Hmo!&%%f|?q@h!$N+0W5a-{I2VZZEhbOC2B7>w| z<0TYDV!;&^U@TBnSgQssM2f1YDk>yZiYpLNMI=xZQ9(gPL`7n;QBR@d^}5e56;$-k zqKu2`wIth{?diAE#u_*(0?utJD2dMQYdO5N&68|eSninTTH}da9ggYCQFW!7cD7w@ zK{7!tKx-5bsnS8gn0Sb7Ei|IjL1F182Dg+WeamAb6CA!QJ(GepaTxPqpFm8yhCumAv3$f6M-RuF*7(&*GV zEylUa#5030U0f-|$%gGTwvBe&4mWFTg(rws>In?s2r z3=t745u3SAO(!Zd7{DgbmXQ$(*Hqb;E^~FWmwfJ_lXYtqqgkuY`Q+aFIm^Y)t4pW= z2^k0+W=&GN-)<@Lgj1Mvd z^Q0hlKqkrNOiW?uWGft``2LLTDdfuAhEX$kV$BqTYN%pcLaQZ24*B00Q%u$n)ckIY zA#am0CPY~jCMG6ZKTZ@-dx#0o5!{MS*3Y&u+sF`+GF_B&zqP#X|Y~ z{yw0ZEojuOUC2PVgOb9sjHroPAcKQY8eo&c10a**c+&cGYeDd`$;w{yg9Fk426ze? z>X_KDZ78%-l#!w`(4-_iO9IGAeP`@%WQz#*Ft)(*vzp?iwpEutzO)Pl6mhIVi)<;T zCx!7~RwEDDPl=s~q0Kt{SF&w&N%DOB$;R3g-tH*L6oy(PD$cuE(#mWc!c;Mn68)V(K}i39_vKD3bSIKNj>;Q4VvvG8i0`7H2X=QgpWlh!R`y8nd;~^Yo4mk z@bY|JLcMH9KJ|tu4)Q*I8e`c7c9Ag0%h}$=#)zR_&%i+<&{$RCBVCj<$?Nb7^V)Rz zpYM+NkIAA)Tk%Kb6~{5+b`#5cs-i+64U43t7)_&F>Lt9zOxW`Ftg21Gn0*J^)#g-5 z0?$R)8+{VZJaXQ>rj)0I-Ag(%bVbO6;d)-BqQAQpWI;s%IKPSi0b46l||M2b-C zQv6X>35IXhEjR^;gJ}k=wY+y{*=P+~y2f=yWDAVmI9fZ$-!$8aG^&fi1{D4kCYN3B znpXr{vcSNZviikmUF{Y*-JiVcn_$t#36QPymXUUP>$!RtqwC+!=vqRG^Yo9W#$vKV z#h{_qq8oEgZXniF92!h(`;z5eZz<%Z>1iO#a3qeyw38)-AB?>F!l;nhL?Yf?9CULE z5%?c!M=Ljnl0H3#7#!VQ#qgzW{77@?Y!lz5G>Djg4*-d%5U5BJJnt8Vsfd4hSx~|H zPQ};pQygq;J9`#11Qm7YlKQMNue)ka9ZDsNrWRGD=r~G!tGNhNnk4d8t)|XbG7N>Y z7cNASH9efYU5j|mT?j?%K$c~l6%`dZaCr!3k~2geLJN(=EpA#1R_%(|H|3oI z5HzEw7jmF+;6!RRwaXk$T^IEf&^VCPiS1nbNdUnv2}LLrk0A#mi7`Hu(N|jgznoKrzn~1|(jozp6%tKOvBhyM{=Qx*@^Ezx4cYSKI z_Svw1DbTo=b=z{OAS-tI#4RDm<&$=oaaUR4lF&D;Y-++zgubPxJl(_=o7gt#4=FSu zW~?&Cj$$ofqfXzROe~aIjARw`_AypGg|;MeE55@NTbepjI7REaTBxBGohdbv4;j>e zl^O_WR1>C0hP)EJShqr#uY2T6YTWZ2)-Gbi_#B9oQ--OR2&RV;#+s>r!@D-yvn`D+ zn=Gjl8!M7oS*I&qdaHT`q>&|>8@~4tB?jG4OhT1BTUz6V6jMpfywgEXFu5u43=Ric zdYBcQLLst929#Zm)$qdd8x%fJ^BE!bc6IYfCdAy16(a-Ii#zItHx%t!Z>0^&CPW`g z9g1Aa)?Sq(3zshrG4Msgv=B31TogHrsOrLgId1Ysk`=8qY@VY%m`hIITouXqM⁢ zO$|#Ct6@bs2--@qIx7;0-%OzTi4Y{_taS9W;|=E98(8mXA7DNt3{1g=frj}1i@744 KC`bh~8;5{P73&xP diff --git a/SESSION.md b/SESSION.md index f232def3..ae10ad0a 100644 --- a/SESSION.md +++ b/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) | diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 8f6534f4..6da5a230 100644 --- a/man/data-plots.Rd +++ b/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") diff --git a/man/vertical_stacked_bars.Rd b/man/vertical_stacked_bars.Rd index 495588fe..75335365 100644 --- a/man/vertical_stacked_bars.Rd +++ b/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, From 1d0fc4f4ad91b39473dcdc02655766409b07d281 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:51:23 +0200 Subject: [PATCH 5/6] new render --- app_docker/app.R | 258 ++++++++++++------------------------ inst/apps/FreesearchR/app.R | 258 ++++++++++++------------------------ 2 files changed, 170 insertions(+), 346 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index 31c047b8..a2b1dc19 100644 --- a/app_docker/app.R +++ b/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,16 +3877,20 @@ generate_colors <- function(n, palette = "viridis", ...) { 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" - )) + 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) } @@ -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()) ############################################################################## ######### diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 860dcd05..e64d7b30 100644 --- a/inst/apps/FreesearchR/app.R +++ b/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,16 +3877,20 @@ generate_colors <- function(n, palette = "viridis", ...) { 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" - )) + 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) } @@ -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()) ############################################################################## ######### From dda744a99a1690030a5530cad1006b922c92c7ee Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:52:11 +0200 Subject: [PATCH 6/6] typo --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 5773bef8..04fa782b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ *FIX* Plot single variable in Likert plot. -*FIX* Horisontal stacked plot crashed. Fixed! +*FIX* Horizontal stacked plot crashed. Fixed! # FreesearchR 26.3.5