From 32f299880d442a7c71bfbffe0f5bd6ebfe37f036 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 11 Mar 2026 10:17:42 +0100 Subject: [PATCH 01/62] fix: keeps labels modifying factors and creates new factors correctly --- CITATION.cff | 2 +- DESCRIPTION | 3 +- NAMESPACE | 5 + NEWS.md | 8 ++ R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/missings-module.R | 22 +-- R/sysdata.rda | Bin 2707 -> 2838 bytes R/update-factor-ext.R | 11 +- R/utils-labels.R | 114 +++++++++++++++ SESSION.md | 20 ++- app_docker/app.R | 159 +++++++++++++++++---- app_docker/translations/translation_da.csv | 2 +- app_docker/translations/translation_sw.csv | 2 +- inst/apps/FreesearchR/app.R | 159 +++++++++++++++++---- inst/translations/translation_da.csv | 2 +- inst/translations/translation_sw.csv | 2 +- man/apply_labels.Rd | 21 +++ man/extract_labels.Rd | 17 +++ man/label_report.Rd | 19 +++ man/restore_labels.Rd | 20 +++ man/with_labels.Rd | 21 +++ tests/testthat/test-utils-labels.R | 143 ++++++++++++++++++ 23 files changed, 676 insertions(+), 80 deletions(-) create mode 100644 R/utils-labels.R create mode 100644 man/apply_labels.Rd create mode 100644 man/extract_labels.Rd create mode 100644 man/label_report.Rd create mode 100644 man/restore_labels.Rd create mode 100644 man/with_labels.Rd create mode 100644 tests/testthat/test-utils-labels.R diff --git a/CITATION.cff b/CITATION.cff index aec07b9e..6d5ebe92 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.1 +version: 26.3.2 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index 1a810014..1c5d410d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.3.1 +Version: 26.3.2 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), @@ -139,6 +139,7 @@ Collate: 'ui_elements.R' 'update-factor-ext.R' 'update-variables-ext.R' + 'utils-labels.R' 'validation.R' 'visual_summary.R' 'wide2long.R' diff --git a/NAMESPACE b/NAMESPACE index 420954d7..e7e642c1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ export(all_but) export(allowed_operations) export(append_column) export(append_list) +export(apply_labels) export(argsstring2list) export(baseline_table) export(class_icons) @@ -53,6 +54,7 @@ export(default_parsing) export(detect_delimiter) export(drop_empty_event) export(expression_string) +export(extract_labels) export(factor_new_levels_labels) export(factorize) export(file_export) @@ -85,6 +87,7 @@ export(is_identical_to_previous) export(is_splittable) export(is_valid_redcap_url) export(is_valid_token) +export(label_report) export(launch_FreesearchR) export(limit_data_size) export(limit_log) @@ -134,6 +137,7 @@ export(remove_empty_attr) export(remove_empty_cols) export(remove_nested_list) export(repeated_instruments) +export(restore_labels) export(sankey_ready) export(selectInputIcon) export(separate_string) @@ -167,6 +171,7 @@ export(visual_summary_ui) export(wide2long) export(winbox_create_column) export(winbox_update_factor) +export(with_labels) export(wrap_plot_list) export(write_quarto) importFrom(classInt,classIntervals) diff --git a/NEWS.md b/NEWS.md index e11b622b..6f50a612 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# FreesearchR 26.3.2 + +*FIX* Updating factor levels always created new factor. + +*FIX* Label stripping behavior updating factors is fixed. + +*NEW* New with_labels() function (and helpers) added to allow easy preservation of labels. + # FreesearchR 26.3.1 *FIX* ~~Include font files for static loading without dependency on Google.~~ Kept webfonts from google as local fonts are not working for now. diff --git a/R/app_version.R b/R/app_version.R index 1a1ca529..a87c4470 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.1' +app_version <- function()'26.3.2' diff --git a/R/hosted_version.R b/R/hosted_version.R index b4e35b45..771bd124 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.1-260302' +hosted_version <- function()'v26.3.2-260311' diff --git a/R/missings-module.R b/R/missings-module.R index 25d250ee..8b9c1f50 100644 --- a/R/missings-module.R +++ b/R/missings-module.R @@ -351,29 +351,17 @@ compare_missings <- function(data, #' ## missings_logic_across() |> #' ## gtsummary::tbl_summary() missings_logic_across <- function(data, exclude = NULL) { - # This function includes a approach way to preserve variable labels + # This function includes a way to preserve variable labels + with_labels(data,{ names(data) |> lapply(\(.x) { - # browser() - # Saving original labels - lab <- REDCapCAST::get_attr(data[[.x]], attr = "label") if (!.x %in% exclude) { - out <- is.na(data[[.x]]) + is.na(data[[.x]]) } else { - out <- data[[.x]] - } - if (!is.na(lab)) { - # Restoring original labels, if not NA - REDCapCAST::set_attr( - data = out, - label = lab, - attr = "label", - overwrite = TRUE - ) - } else { - out + data[[.x]] } }) |> dplyr::bind_cols(.name_repair = "unique_quiet") |> setNames(names(data)) + }) } diff --git a/R/sysdata.rda b/R/sysdata.rda index c3a997792d79a7772ab823f7407ed73345fdeffe..e7ce41066e6125ce50acf9792d07bde50c433502 100644 GIT binary patch literal 2838 zcmV+x3+ePiT4*^jL0KkKSq}>Kv;Z5Gf5QL&Xaz!l|KNXb-@w2B|L{Nn00;;H;0(VP zyxy2^4+E$Yk3a_^f%CqCi3i9UQ1H~m6A05mFp~+QV?{j*JkwOr*&qW!qee`{2C3j8 z36(vmlS#3uJfq4000001kN^Wy$)J>?4^g9K2198BAOVm8k%0ptkOZ1YNh#`&)b%us zpQQk39-slEBPM_V0iXcNh?_+8n9-r3GGGHyfCOYFnoS+%fZ05U-Y7DNxe_sid>n*HyLfA6<%vHyqL_xaW#XwC)n z&i6#kK2@MgN*Rl4f#Z@23V*!c9Gsi!}9 zX(V$r<&Fa7YrN{M|2M@L3-Knb*0OCI!_r@i-U|-7CSRSk&!VlYt6_&0%i|{ojSBoQ z>uhjYxLcz_$%cI#lXeDh>!?0wpT2Lc&~K#Eo>dayO>wcxT5p%f<9aF2Q z_2^}8sM%ASvs9;q5jRm1m^Fh#Q$;wNA0={RyN#s6-We~HE=-$QwLzB68J`Zv68#%$ zu)>S+)w%VoEf8Gs0Lu{q>2{tg_3-DK0BuACPJn_75kv?Q5*t*2D%oWUs)yc3_ zs49xVMnP0j5r`@>C<-hTMNwD_B8sXCqA2?QpT_N;JgU5YeDop<1s^p4<9!`;`Wu|X zM=JqmMWsa<(Yvd9&YJ5&a)sT6yWFpAZpU_YX~w(ShLUNCBm=5qU^a$b7M`a^4b;h5 z5h#E)iF)OmaW~q@wi`~l*I3)FZm|x{Q8`MGp&*dRjKdJgS`u_lv?Mq#lW#2>piL0Y z8O$9RPQ;b9Mgl5GZ890WPSz7l;=SeC2X(#Jwl6OdV#z8F_nC%8vk>i!fVNa?3<<0d z)Ys>wLU2*CUkQW4D`nY6qJP0V%7}|@AfHj~3hA4}KK)hI328fF_6;wpbD3-Qp zwRG4*_ibA=WwT0@uH10xn6b>v>hl7p5T2o4B!R8lXDCxv@}Sc)StXED zYYy(FVo{2=>Fr>kWeHb9iM?sI?V{U{Nv)iEyj_N->#K}c1gpNe)*ait>b%2QMwHM< z0|rR~*_5ud_jhF2oV;~h$(!xX2BPmU#U_wqG?0*tu^0_IK52G|-`&@nOZun*aRp#P zWB@`T=1E-4w5=;f+z9~5F|2~K*b*Rn&%KH9+Nj4MC54jMlu}V9WyCA&HGg0P*Ju=y z2tpAdsulJdl;fPmAZy&xOG*V{ORTnY=Mg6eDP=7|PTtvQ%Jq&iKNb zX0uENem7GBQkJB#6pBgUn3!8XPEkSc0w=`pxIkke5l~|Z-QAc57K%d4V9#cgCq13~ z26klP53OOZFD~yCO%$c5)U~7K$s`QK6H>ymjHrmUX+eX7P)0Pt3ZA#80)$EH+FOa9 zWIbG<^1`kzfp4Kf4cG!6JPUz~7ZE^GlvIrhz=ES~2|^8Ln>cWQNT)Kg!LraQ9x2+o zMJa5emp-<&1xFe&g;u3wG>?X`Jw^r~j9=GF*oqxBc%3sBDJ$|kxN!%Kg*Us3APW-8 zs0~Q!WT!?cdWtYC%SX3DlPoF?Cx4~hS{BhO3qTeUHo{gw765^g5RYvNZLPCEt-($j~^kp>I2qYc>#k9jK zt;^jnrwEDn8ZnbOW^(}~q*8K%$kcSAV1hwa1YLdPthi41oB%-}vb1nPAhWetN+7M5 z)?uHkfBqAQ$45D;`g=V7zsPa=1$_uzU?&iui82(R2!BNLr2LxMb zaJc(#%Atea-_mrg&~W7hkfY{T#;rH+r$b}7|2MyfUNXRiu+m;b%hO=Ega!bk=vfYp zQ=Zq5sn-dK6>&AHm78TcN?Xd=w;bp~&Iv}typpz}gHDZoJOfo&-^FDytAa;vu~P#6 z9@H8!;3h%K`>@0XjWXm-X|?6{km~a`iui7v;$i(g>Q!q5C?pA9w~Rv^!&CW{_Kfm? z-DT~&60f@u8cJP`lU{7&RPXI> zE^IHhLkg@yHbL5XcCq7H{K!S|YJ{{c7eca?G7ljQ5RBCa)PEMu{WpI4nU%`lQy6mkjR6SUD|bmS-kgmy`<28Q7=!lsqnb||GAsw83yyp)cTok; z=VnO1A->6-5(zP_S21gskumH*h~jM_(B$LeQ}WN$e3cH87m+>8tPau!36MoiK_)(e z6)U8ip4776Lp#53M!{egYI&EauYlU zqnW|9B-dBG7Va82ZQUOds40fLw9aoGVpTX!zVBsWrJBol%CNq^#;*60u)PN&$Lld= z`YX<3j9$zoy=4fv=7)n#NtKjY0JAy>Xe(xAi$4DYS%M?HH0ru-gzP4Ul+0^tGCKkV%H8aK@qput+@F67+2iX(*O2iibD olSR^xYtii%N(M??%dc?%fP3h8>qdxZ^dJ0P$rRy2Ks+nj&=-tQ!vFvP literal 2707 zcmV;E3T*X4T4*^jL0KkKSr~8qkpLO%f5iX)Xaz!l|KNXb-@w2B|L{Nn00IaB;0zxZ zIgD-|4gjfap-B`M-yc;}6#HPQ6g4scLsJQ+Mw$~K$V{ebq|n6EKpGyS)Hb7O2Brum zfS8&Tc&3^*pa3)g00000H9R2{spR|6c{~T^EL_^Cn&HX69|G3SS0i1ZRN~io87DJ27CsIOq)Jq($-;qYz>UY z1g~Tmzd4iO@f9c$JTufvQIfx}3~i?P9>=GJ!$~EEY1x*sVlTkl?~|aF0`Ms))S_i9 z$Dq6(@K$Y^Il9?Auy%#I(+w+O7B2Fty8KxR)NK;Ifkd-BHz!SIaNOXmEqvTqsasT~ z?ltaGLvK=vsoeJzC06cC%#DmM8)lk7gGkM{xx55pqcr6oC#9U6=SX^6%d6*1JLR${ zoWY#gJFCPUZrXbsH}sGH&_j70z- zNJwzffQxHTB8Y#G0UWUu0~cmdkJ<_j&!>#jx*!JZ5e@FPd%J#(&5a&ixGD}qPRdkb zqY)8{1V}1~h$9%W1ymJa#Rdv2QBe^EM1sh$L{&v#DHKIPR7HHgpMlFejq0xNlR6Ov z1?sf`-Oi3UdK;VJw#N9tS;1*hMrhjV@px;S>`{)?2~}wwgFw>OBq*a)NDz|YAQ4PP zB;DC+wLt9Ci*3Yo1Y}<3sIoRjq0oe7UNV%Fh#+jDK|3{K=n^3hdu|f6D1vkZ5KB&` z@f^JqaSfW@$9~koONH4;sv<=UBQ}K1i+efE?+`q`b21FP+Jgxxo#tVJ;Z9r_*3vIq zELLnds{Z{e8>582n+)`K$-T^qGPhej2q?hI`$mT{CRMv(ar>TeZQxh4a(_swYkwU>1sMiBmHh zZCcT{2moY@Agu9{B<(${PQz6g;0a|Vu_&;jOv{K=Ppwq8G%?v!p+I67MSeJ-8DIl^ z3YC+r!dDV^{e0!jm^U%D3FgfQuVNEkxrUO0~Mo3bYq_Gr> z3DQhVEuTJ7LFbYQ-!uV?kVQd=PF%A9u~bMUH9;OK8wK1~IpEz4(zVcA3^Ht^G*Yx< zS}xKM8iHi7tfML;D?|`*Y6}`*%Fd7oM4jS17B;a4t59DOvl*a%h#+ymK;yFKV8Ohl zr6{Qy1%VLCq68qt%j}(5N(={kJ)2 zTSTla0u_X*08&Ow2_ZRZ$)xl0%zQNAHK7#YrKKoFeyRx&+*f2qd%^jvaLDZ$E? ztt(pwii+a|uQ<-6wAS~k^xx;0-BiFykG2`aOakR5}bngAgH2=az@ zy*^%XA66ECgaD5FwSa^Gj{n-r=_@?-(PiCO_z6U1y{%$BJf7cg{5A9m@MW`5inw$5 zx=Qvj8+WlFZzJ32VUOMF^&DIung50fe}0#?omRwfdxA1(rmG+1fu2KO&+?6?NHR zx2|i`vh7RIX-aj@=`*#ML|BR?Mky;9?z_{H=pdyrUD+09iPkq^eZcx76s%Fnvh`-R z%v7x1Jv5@yh-lp8_ULO7OEjYu5kh_gEsm;da-~oiXD&r~^b~dnp@S*GQ4HS{45V|h z?HIu7jO!(hA;x0^8>)9F8-4Eqa#hlTh!(k=HB>i`e95ZPX-QFdBv0<8R+&mBAFqH!>I5G4w>Y-~AsIoL4-7namczB!W%=pf{5Ca1A9WaD2qw?d7SlJK#Lm^oYrU_vl+&z+(sJQ)_LEu@c3d;Bz8$N^&G{~3Jx_2IlW4& zD{9Ur`pSjGxvbH4M1ZU{QXyFlpDUZ7xq(ttmA5SeQrO*#IUFg9bLV@(Y1Mm1jWOsa z1T58>`=zu@)(KC`<(Y+YixHY&ub+{MspKoEBZ#c_7^1t;=#bYJuF0`cLM=HY?0LB| zuIB_(aSdf*O0qgOagnw?qeYT!vZR^~85rMZSjCC;oWx2g;fiM06wu;W(~6hd&3kLl zc6OG0^<+fjJu@Zu8fX{C6}nCrk_uSe4Y3H|t8YhNWdd zcwjoP>C%e9=49v-fkg!tvNcamrAdpZEv%)B(W1)cNwGE~UPM}W(N_GBm4!O1%Op1F znGk%K?8$Q}Uztd@#ZALxcp|}C2pO*JY8yqAZnl1#u;+}3QncrhPl&%gvuWk^!CX(a zHWlSOsA^b@TM8v`jby5mrCAil+bN<}lc*%pw#A~6VN}XaTFZl2`vLPHEL92|6gQ9j NUC9*TLO@}^_C&cj?4 #' ## gtsummary::tbl_summary() missings_logic_across <- function(data, exclude = NULL) { - # This function includes a approach way to preserve variable labels + # This function includes a way to preserve variable labels + with_labels(data,{ names(data) |> lapply(\(.x) { - # browser() - # Saving original labels - lab <- REDCapCAST::get_attr(data[[.x]], attr = "label") if (!.x %in% exclude) { - out <- is.na(data[[.x]]) + is.na(data[[.x]]) } else { - out <- data[[.x]] - } - if (!is.na(lab)) { - # Restoring original labels, if not NA - REDCapCAST::set_attr( - data = out, - label = lab, - attr = "label", - overwrite = TRUE - ) - } else { - out + data[[.x]] } }) |> dplyr::bind_cols(.name_repair = "unique_quiet") |> setNames(names(data)) + }) } @@ -11435,7 +11423,7 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t("Create a new variable (otherwise replaces the one selected)"), + label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), value = FALSE, status = "primary", outline = TRUE, @@ -11566,15 +11554,18 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { parameters <- list( variable = variable, new_variable = isTRUE(input$new_var) | - any(grid[["Var1_toset"]] == "New label"), + any(grid[["Var1_toset"]] != "New label"), new_levels = as.character(grid[["Var1"]]), new_labels = as.character(grid[["Var1_toset"]]), ignore = "New label" ) data <- tryCatch({ - rlang::exec(factor_new_levels_labels, - !!!modifyList(parameters, val = list(data = data))) + with_labels(data,{ + rlang::exec(factor_new_levels_labels, + !!!modifyList(parameters, val = list(data = data))) + }) + }, error = function(err) { showNotification(paste( "We encountered the following error creating the new factor:", @@ -12546,6 +12537,126 @@ clean_date <- function(data) { # +######## +#### Current file: /Users/au301842/FreesearchR/R//utils-labels.R +######## + +# ============================================================================= +# Column Label Utilities +# +# Coded with help from Claude to save time. +# Could be seperated for its own package. +# ============================================================================= + +#' Extract column labels from a data frame +#' +#' @param df A data frame. +#' @return A named character vector of label strings (only labelled columns included). +#' @export +extract_labels <- function(df) { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + + labels <- vapply(df, function(col) { + lbl <- attr(col, "label") + if (is.null(lbl)) NA_character_ else as.character(lbl) + }, FUN.VALUE = character(1)) + + labels[!is.na(labels)] +} + + +#' Apply a named label vector to a data frame +#' +#' @param df A data frame. +#' @param labels A named character vector (names = column names, values = labels). +#' Typically the output of [extract_labels()]. Labels for absent columns are +#' silently ignored. +#' @return `df` with `"label"` attributes set on matching columns. +#' @export +apply_labels <- function(df, labels) { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + if (!is.character(labels) || is.null(names(labels))) { + stop("`labels` must be a named character vector.", call. = FALSE) + } + + for (col in intersect(names(labels), names(df))) { + attr(df[[col]], "label") <- labels[[col]] + } + + df +} + + +#' Restore column labels using a reference data frame +#' +#' Convenience wrapper around [extract_labels()] + [apply_labels()]. Labels are +#' matched by column name; new columns in `df_modified` are left unchanged. +#' +#' @param df_modified A data frame whose columns should receive labels. +#' @param df_reference A data frame carrying the authoritative `"label"` attributes. +#' @return `df_modified` with labels restored on all columns present in `df_reference`. +#' @export +restore_labels <- function(df_modified, df_reference) { + if (!is.data.frame(df_modified)) stop("`df_modified` must be a data frame.", call. = FALSE) + if (!is.data.frame(df_reference)) stop("`df_reference` must be a data frame.", call. = FALSE) + + apply_labels(df_modified, extract_labels(df_reference)) +} + + +#' Evaluate an expression while preserving column labels +#' +#' Snapshots labels from `df` before evaluating `expr`, then reapplies them to +#' matching columns in the result. New columns created inside `expr` receive no +#' label automatically. +#' +#' @param df A data frame carrying `"label"` attributes. +#' @param expr An unquoted expression that transforms `df` and returns a data frame. +#' @return The data frame produced by `expr`, with original labels restored. +#' @export +with_labels <- function(df, expr) { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + + labels <- extract_labels(df) + result <- eval(substitute(expr), parent.frame()) + + if (!is.data.frame(result)) { + stop("The expression passed to `with_labels()` must return a data frame.", call. = FALSE) + } + + apply_labels(result, labels) +} + + +#' Print a tidy summary of column labels +#' +#' @param df A data frame. +#' @param missing_marker String used when a column has no label. Default: `"(no label)"`. +#' @return A `column / class / label` data frame, printed and returned invisibly. +#' @export +label_report <- function(df, missing_marker = "(no label)") { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + if (!is.character(missing_marker) || length(missing_marker) != 1L) { + stop("`missing_marker` must be a single character string.", call. = FALSE) + } + + labels <- vapply(df, function(col) { + lbl <- attr(col, "label") + if (is.null(lbl)) missing_marker else as.character(lbl) + }, FUN.VALUE = character(1)) + + report <- data.frame( + column = names(df), + class = vapply(df, function(x) paste(class(x), collapse = "/"), character(1)), + label = unname(labels), + stringsAsFactors = FALSE + ) + + print(report, row.names = FALSE) + invisible(report) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//validation.R ######## diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index fef64b5f..86a7f72b 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -61,7 +61,6 @@ "Factor variable to reorder:","Kategoriske variabel der skal ændres:" "Sort by levels","Sorter efter niveauer" "Sort by count","Sorter efter antal" -"Create a new variable (otherwise replaces the one selected)","Opret en ny variabel (ellers erstattes den oprindelige)" "Update factor variable","Updater faktor-variabel" "Levels","Niveauer" "Count","Antal" @@ -328,3 +327,4 @@ "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." "Sample data","Træningsdata" +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 300390ff..1193ea71 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -61,7 +61,6 @@ "Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:" "Sort by levels","Panga kwa viwango" "Sort by count","Panga kwa hesabu" -"Create a new variable (otherwise replaces the one selected)","Unda kigezo kipya (vinginevyo kinachukua nafasi ya kile kilichochaguliwa)" "Update factor variable","Sasisha kigezo cha kipengele" "Levels","Viwango" "Count","Hesabu" @@ -328,3 +327,4 @@ "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." "Sample data","Sample data" +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 9e885cb4..6007a903 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//RtmpxB1KWR/file173c92887da27.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpxB1KWR/file173c978fea931.R ######## i18n_path <- system.file("translations", package = "FreesearchR") @@ -75,7 +75,7 @@ if (!"global_freesearchR" %in% ls(name = globalenv())) { #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'26.3.1' +app_version <- function()'26.3.2' ######## @@ -4527,7 +4527,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.1-260302' +hosted_version <- function()'v26.3.2-260311' ######## @@ -6367,31 +6367,19 @@ compare_missings <- function(data, #' ## missings_logic_across() |> #' ## gtsummary::tbl_summary() missings_logic_across <- function(data, exclude = NULL) { - # This function includes a approach way to preserve variable labels + # This function includes a way to preserve variable labels + with_labels(data,{ names(data) |> lapply(\(.x) { - # browser() - # Saving original labels - lab <- REDCapCAST::get_attr(data[[.x]], attr = "label") if (!.x %in% exclude) { - out <- is.na(data[[.x]]) + is.na(data[[.x]]) } else { - out <- data[[.x]] - } - if (!is.na(lab)) { - # Restoring original labels, if not NA - REDCapCAST::set_attr( - data = out, - label = lab, - attr = "label", - overwrite = TRUE - ) - } else { - out + data[[.x]] } }) |> dplyr::bind_cols(.name_repair = "unique_quiet") |> setNames(names(data)) + }) } @@ -11435,7 +11423,7 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t("Create a new variable (otherwise replaces the one selected)"), + label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), value = FALSE, status = "primary", outline = TRUE, @@ -11566,15 +11554,18 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { parameters <- list( variable = variable, new_variable = isTRUE(input$new_var) | - any(grid[["Var1_toset"]] == "New label"), + any(grid[["Var1_toset"]] != "New label"), new_levels = as.character(grid[["Var1"]]), new_labels = as.character(grid[["Var1_toset"]]), ignore = "New label" ) data <- tryCatch({ - rlang::exec(factor_new_levels_labels, - !!!modifyList(parameters, val = list(data = data))) + with_labels(data,{ + rlang::exec(factor_new_levels_labels, + !!!modifyList(parameters, val = list(data = data))) + }) + }, error = function(err) { showNotification(paste( "We encountered the following error creating the new factor:", @@ -12546,6 +12537,126 @@ clean_date <- function(data) { # +######## +#### Current file: /Users/au301842/FreesearchR/R//utils-labels.R +######## + +# ============================================================================= +# Column Label Utilities +# +# Coded with help from Claude to save time. +# Could be seperated for its own package. +# ============================================================================= + +#' Extract column labels from a data frame +#' +#' @param df A data frame. +#' @return A named character vector of label strings (only labelled columns included). +#' @export +extract_labels <- function(df) { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + + labels <- vapply(df, function(col) { + lbl <- attr(col, "label") + if (is.null(lbl)) NA_character_ else as.character(lbl) + }, FUN.VALUE = character(1)) + + labels[!is.na(labels)] +} + + +#' Apply a named label vector to a data frame +#' +#' @param df A data frame. +#' @param labels A named character vector (names = column names, values = labels). +#' Typically the output of [extract_labels()]. Labels for absent columns are +#' silently ignored. +#' @return `df` with `"label"` attributes set on matching columns. +#' @export +apply_labels <- function(df, labels) { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + if (!is.character(labels) || is.null(names(labels))) { + stop("`labels` must be a named character vector.", call. = FALSE) + } + + for (col in intersect(names(labels), names(df))) { + attr(df[[col]], "label") <- labels[[col]] + } + + df +} + + +#' Restore column labels using a reference data frame +#' +#' Convenience wrapper around [extract_labels()] + [apply_labels()]. Labels are +#' matched by column name; new columns in `df_modified` are left unchanged. +#' +#' @param df_modified A data frame whose columns should receive labels. +#' @param df_reference A data frame carrying the authoritative `"label"` attributes. +#' @return `df_modified` with labels restored on all columns present in `df_reference`. +#' @export +restore_labels <- function(df_modified, df_reference) { + if (!is.data.frame(df_modified)) stop("`df_modified` must be a data frame.", call. = FALSE) + if (!is.data.frame(df_reference)) stop("`df_reference` must be a data frame.", call. = FALSE) + + apply_labels(df_modified, extract_labels(df_reference)) +} + + +#' Evaluate an expression while preserving column labels +#' +#' Snapshots labels from `df` before evaluating `expr`, then reapplies them to +#' matching columns in the result. New columns created inside `expr` receive no +#' label automatically. +#' +#' @param df A data frame carrying `"label"` attributes. +#' @param expr An unquoted expression that transforms `df` and returns a data frame. +#' @return The data frame produced by `expr`, with original labels restored. +#' @export +with_labels <- function(df, expr) { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + + labels <- extract_labels(df) + result <- eval(substitute(expr), parent.frame()) + + if (!is.data.frame(result)) { + stop("The expression passed to `with_labels()` must return a data frame.", call. = FALSE) + } + + apply_labels(result, labels) +} + + +#' Print a tidy summary of column labels +#' +#' @param df A data frame. +#' @param missing_marker String used when a column has no label. Default: `"(no label)"`. +#' @return A `column / class / label` data frame, printed and returned invisibly. +#' @export +label_report <- function(df, missing_marker = "(no label)") { + if (!is.data.frame(df)) stop("`df` must be a data frame.", call. = FALSE) + if (!is.character(missing_marker) || length(missing_marker) != 1L) { + stop("`missing_marker` must be a single character string.", call. = FALSE) + } + + labels <- vapply(df, function(col) { + lbl <- attr(col, "label") + if (is.null(lbl)) missing_marker else as.character(lbl) + }, FUN.VALUE = character(1)) + + report <- data.frame( + column = names(df), + class = vapply(df, function(x) paste(class(x), collapse = "/"), character(1)), + label = unname(labels), + stringsAsFactors = FALSE + ) + + print(report, row.names = FALSE) + invisible(report) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//validation.R ######## diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index fef64b5f..86a7f72b 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -61,7 +61,6 @@ "Factor variable to reorder:","Kategoriske variabel der skal ændres:" "Sort by levels","Sorter efter niveauer" "Sort by count","Sorter efter antal" -"Create a new variable (otherwise replaces the one selected)","Opret en ny variabel (ellers erstattes den oprindelige)" "Update factor variable","Updater faktor-variabel" "Levels","Niveauer" "Count","Antal" @@ -328,3 +327,4 @@ "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." "Sample data","Træningsdata" +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 300390ff..1193ea71 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -61,7 +61,6 @@ "Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:" "Sort by levels","Panga kwa viwango" "Sort by count","Panga kwa hesabu" -"Create a new variable (otherwise replaces the one selected)","Unda kigezo kipya (vinginevyo kinachukua nafasi ya kile kilichochaguliwa)" "Update factor variable","Sasisha kigezo cha kipengele" "Levels","Viwango" "Count","Hesabu" @@ -328,3 +327,4 @@ "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." "Sample data","Sample data" +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" diff --git a/man/apply_labels.Rd b/man/apply_labels.Rd new file mode 100644 index 00000000..fa7237ec --- /dev/null +++ b/man/apply_labels.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-labels.R +\name{apply_labels} +\alias{apply_labels} +\title{Apply a named label vector to a data frame} +\usage{ +apply_labels(df, labels) +} +\arguments{ +\item{df}{A data frame.} + +\item{labels}{A named character vector (names = column names, values = labels). +Typically the output of \code{\link[=extract_labels]{extract_labels()}}. Labels for absent columns are +silently ignored.} +} +\value{ +\code{df} with \code{"label"} attributes set on matching columns. +} +\description{ +Apply a named label vector to a data frame +} diff --git a/man/extract_labels.Rd b/man/extract_labels.Rd new file mode 100644 index 00000000..b851352e --- /dev/null +++ b/man/extract_labels.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-labels.R +\name{extract_labels} +\alias{extract_labels} +\title{Extract column labels from a data frame} +\usage{ +extract_labels(df) +} +\arguments{ +\item{df}{A data frame.} +} +\value{ +A named character vector of label strings (only labelled columns included). +} +\description{ +Extract column labels from a data frame +} diff --git a/man/label_report.Rd b/man/label_report.Rd new file mode 100644 index 00000000..03578d10 --- /dev/null +++ b/man/label_report.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-labels.R +\name{label_report} +\alias{label_report} +\title{Print a tidy summary of column labels} +\usage{ +label_report(df, missing_marker = "(no label)") +} +\arguments{ +\item{df}{A data frame.} + +\item{missing_marker}{String used when a column has no label. Default: \code{"(no label)"}.} +} +\value{ +A \code{column / class / label} data frame, printed and returned invisibly. +} +\description{ +Print a tidy summary of column labels +} diff --git a/man/restore_labels.Rd b/man/restore_labels.Rd new file mode 100644 index 00000000..91fdbd1d --- /dev/null +++ b/man/restore_labels.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-labels.R +\name{restore_labels} +\alias{restore_labels} +\title{Restore column labels using a reference data frame} +\usage{ +restore_labels(df_modified, df_reference) +} +\arguments{ +\item{df_modified}{A data frame whose columns should receive labels.} + +\item{df_reference}{A data frame carrying the authoritative \code{"label"} attributes.} +} +\value{ +\code{df_modified} with labels restored on all columns present in \code{df_reference}. +} +\description{ +Convenience wrapper around \code{\link[=extract_labels]{extract_labels()}} + \code{\link[=apply_labels]{apply_labels()}}. Labels are +matched by column name; new columns in \code{df_modified} are left unchanged. +} diff --git a/man/with_labels.Rd b/man/with_labels.Rd new file mode 100644 index 00000000..62b6a9e4 --- /dev/null +++ b/man/with_labels.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-labels.R +\name{with_labels} +\alias{with_labels} +\title{Evaluate an expression while preserving column labels} +\usage{ +with_labels(df, expr) +} +\arguments{ +\item{df}{A data frame carrying \code{"label"} attributes.} + +\item{expr}{An unquoted expression that transforms \code{df} and returns a data frame.} +} +\value{ +The data frame produced by \code{expr}, with original labels restored. +} +\description{ +Snapshots labels from \code{df} before evaluating \code{expr}, then reapplies them to +matching columns in the result. New columns created inside \code{expr} receive no +label automatically. +} diff --git a/tests/testthat/test-utils-labels.R b/tests/testthat/test-utils-labels.R new file mode 100644 index 00000000..e2f467ce --- /dev/null +++ b/tests/testthat/test-utils-labels.R @@ -0,0 +1,143 @@ +# Tests for column label utilities (extract_labels, apply_labels, +# restore_labels, with_labels, label_report) + +# --- extract_labels ---------------------------------------------------------- + +test_that("extract_labels returns named character vector of present labels", { + df <- data.frame(a = 1:3, b = 4:6, c = 7:9) + attr(df$a, "label") <- "Column A" + attr(df$b, "label") <- "Column B" + + lbls <- extract_labels(df) + + expect_type(lbls, "character") + expect_named(lbls, c("a", "b")) + expect_equal(lbls[["a"]], "Column A") + expect_equal(lbls[["b"]], "Column B") + expect_false("c" %in% names(lbls)) +}) + +test_that("extract_labels returns zero-length vector when no labels present", { + expect_equal(length(extract_labels(data.frame(x = 1, y = 2))), 0L) +}) + +test_that("extract_labels errors on non-data-frame input", { + expect_error(extract_labels(list(a = 1)), "`df` must be a data frame") + expect_error(extract_labels(1:5), "`df` must be a data frame") +}) + + +# --- apply_labels ------------------------------------------------------------ + +test_that("apply_labels sets label attributes on matching columns", { + df <- data.frame(age = 1:3, income = c(10, 20, 30)) + df2 <- apply_labels(df, c(age = "Age (years)", income = "Income (USD)")) + + expect_equal(attr(df2$age, "label"), "Age (years)") + expect_equal(attr(df2$income, "label"), "Income (USD)") +}) + +test_that("apply_labels silently ignores labels for absent columns", { + df <- data.frame(age = 1:3) + expect_no_error(apply_labels(df, c(age = "Age", income = "Income"))) + expect_equal(attr(apply_labels(df, c(age = "Age", income = "Income"))$age, "label"), "Age") +}) + +test_that("apply_labels errors on bad inputs", { + expect_error(apply_labels(list(), c(a = "A")), "`df` must be a data frame") + expect_error(apply_labels(data.frame(), c("A")), "`labels` must be a named") + expect_error(apply_labels(data.frame(), 123), "`labels` must be a named") +}) + + +# --- restore_labels ---------------------------------------------------------- + +test_that("restore_labels copies labels from reference to modified df", { + df <- data.frame(a = 1:5, b = letters[1:5], stringsAsFactors = FALSE) + attr(df$a, "label") <- "Variable A" + attr(df$b, "label") <- "Variable B" + + df_mod <- df[df$a > 2, ] + attr(df_mod$a, "label") <- NULL + attr(df_mod$b, "label") <- NULL + + df_restored <- restore_labels(df_mod, df) + + expect_equal(attr(df_restored$a, "label"), "Variable A") + expect_equal(attr(df_restored$b, "label"), "Variable B") +}) + +test_that("restore_labels does not error when modified df has extra columns", { + df <- data.frame(x = 1:3) + attr(df$x, "label") <- "X" + + df_mod <- df + df_mod$y <- df$x * 2 + + result <- restore_labels(df_mod, df) + expect_equal(attr(result$x, "label"), "X") + expect_null(attr(result$y, "label")) +}) + +test_that("restore_labels errors on non-data-frame inputs", { + df <- data.frame(x = 1) + expect_error(restore_labels(list(), df), "`df_modified` must be a data frame") + expect_error(restore_labels(df, list()), "`df_reference` must be a data frame") +}) + + +# --- with_labels ------------------------------------------------------------- + +test_that("with_labels preserves labels through a subsetting expression", { + df <- data.frame(id = 1:5, age = c(25, 34, 45, 29, 52)) + attr(df$age, "label") <- "Age (years)" + + result <- with_labels(df, df[df$age > 30, ]) + expect_equal(attr(result$age, "label"), "Age (years)") +}) + +test_that("with_labels does not assign labels to new columns", { + df <- data.frame(x = 1:3, y = 4:6) + attr(df$x, "label") <- "X label" + + result <- with_labels(df, { df$z <- df$x + df$y; df }) + + expect_equal(attr(result$x, "label"), "X label") + expect_null(attr(result$z, "label")) +}) + +test_that("with_labels errors when expression does not return a data frame", { + df <- data.frame(x = 1:3) + expect_error(with_labels(df, sum(df$x)), "must return a data frame") +}) + +test_that("with_labels errors on non-data-frame df argument", { + expect_error(with_labels(list(x = 1), list()), "`df` must be a data frame") +}) + + +# --- label_report ------------------------------------------------------------ + +test_that("label_report returns correct structure", { + df <- data.frame(a = 1L, b = "x", stringsAsFactors = FALSE) + attr(df$a, "label") <- "Alpha" + + report <- label_report(df) + + expect_s3_class(report, "data.frame") + expect_named(report, c("column", "class", "label")) + expect_equal(nrow(report), 2L) + expect_equal(report$label[report$column == "a"], "Alpha") + expect_equal(report$label[report$column == "b"], "(no label)") +}) + +test_that("label_report respects custom missing_marker", { + df <- data.frame(x = 1) + report <- label_report(df, missing_marker = "N/A") + expect_equal(report$label[1], "N/A") +}) + +test_that("label_report errors on bad inputs", { + expect_error(label_report(list()), "`df` must be a data frame") + expect_error(label_report(data.frame(), c("a", "b")), "`missing_marker`") +}) From 8935b0b2a4c2a843361fd3a7f9f284c0261fb7c5 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 11 Mar 2026 13:22:54 +0100 Subject: [PATCH 02/62] feat: allow passing of global settings launching from R or running docker container. --- NEWS.md | 2 ++ R/launch_FreesearchR.R | 28 +++++++++++++++++++++++----- R/sysdata.rda | Bin 2838 -> 2661 bytes R/ui_elements.R | 8 ++++---- SESSION.md | 19 ------------------- 5 files changed, 29 insertions(+), 28 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6f50a612..7c44be1a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,8 @@ *NEW* New with_labels() function (and helpers) added to allow easy preservation of labels. +*NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Docs will follow. + # FreesearchR 26.3.1 *FIX* ~~Include font files for static loading without dependency on Google.~~ Kept webfonts from google as local fonts are not working for now. diff --git a/R/launch_FreesearchR.R b/R/launch_FreesearchR.R index 504de474..469c443b 100644 --- a/R/launch_FreesearchR.R +++ b/R/launch_FreesearchR.R @@ -23,11 +23,11 @@ launch_FreesearchR <- function(inlcude_globalenv = TRUE, data_limit_upper = 100000, data_limit_lower = 1, ...) { - global_freesearchR <- list( - include_globalenv = include_globalenv, - data_limit_default = data_limit_default, - data_limit_upper = data_limit_upper, - data_limit_lower = data_limit_lower + Sys.setenv( + INCLUDE_GLOBALENV = include_globalenv, + DATA_LIMIT_DEFAULT = data_limit_default, + DATA_LIMIT_UPPER = data_limit_upper, + DATA_LIMIT_LOWER = data_limit_lower ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") @@ -39,3 +39,21 @@ launch_FreesearchR <- function(inlcude_globalenv = TRUE, a <- shiny::runApp(appDir = paste0(appDir, "/app.R"), ...) return(invisible(a)) } + + +## Helper to set env variables +get_config <- function(var_name, default = NULL) { + # First check environment variables (set by Docker) + val <- Sys.getenv(var_name, unset = NA) + + if (!is.na(val) && nzchar(val)) { + return(val) + } + + # Fall back to default (can be overridden when launching from R) + if (!is.null(default)) { + return(default) + } + + stop(paste("Required config variable not set:", var_name)) +} diff --git a/R/sysdata.rda b/R/sysdata.rda index e7ce41066e6125ce50acf9792d07bde50c433502..f20ba2552a749586b3c5f0ce62e1446fd82b4b4c 100644 GIT binary patch literal 2661 zcmV-r3YzsoT4*^jL0KkKSwF8mp8y$Bf5iX)Xaz!l|KNXb-@w2B|L{Nn06+)<;0xay zldLxn4g#q(peO-+@Bjc0svI>j01yOZGEE8OBSM==`bfs00MU~XiLnN%r~XDl8frAv zKOsk>K`{+5Ljo`WMvV2fB*mh00001CXzy$nrJ}NMt}oA00000 z000o84^YvgMutFW4FJ#vfM@^)ng9V3i8UHD$&imxh%#bi0iXZ_6G4+qfXQ-Iz)U3! zv@jWz0?R0%rLjd#Omsk3n~Kt?pw^@^yu3R2W3u)F%dwbUo@do_8Pr5U zg*l$R#DOUP&rersQS3`#+L^l8**o6cJ8-vK@CcA8nUypoZ*>Jye)V$YZ&Q`QwNlN% ztyMEc2(LIb0SB041DLbfZOg^(L048E>ycb9!X%boJP9i5s_~(i^pjN>EL%*K${x~j z5`R75CvXM47X8Z zixd55`%E~knsrPiRqqsqRhxvcsA(cz4_dmt#@9}@3E=fP*!aE^eP-ufPP?If^JeR* z%qTfCZQa|d7HaCK%197mFBVo})_tWL9NU3qlZ1fMJKVQRSn1(K~2inS-lJ!<;p;iHK87 zvM&&KgLQVfnP?tPa_x)V;$q1vj$PSfY^r-=>0%1Cg$Z~mslUHVV#8*@_!i%vIp&F0LNQkM?PH)?_z2zp|Y(rXCOHWPchs^(1Fn|%hN?U-XFu(@rO zm8CPx;~uv)abvGvV^O1XLJ=<;yS( zEfxiqgFRaeoBF#Ncx0*5d!#R8vCFKC(Mr*crP>4wP)wE;lx0Lp(F7bCg2tFKv!Dh+ zCv=V2h8qJFXcok!;`9$_pc~LYH>$ae7){G1kfm8dL=piyR0|}9?7n{6NftrpVQnQ& zt2nNeEwZe+=W9?@aib8cX;_+L(X2Ym3_%(7Qu7f*hOX}n#mfqv_jkEB-JwmkxT7Re z8EO)&>+@OA!0G`4A)PvXe5~oENmHMt&RQ1HD+^?SP?dlRNXdkRCpN5_PctmXz)lld z5l$LfQi&ufLBPdW$o4(nw;S)|+;UMV!Ocrj%FwG+R~RLE+18et-{H>P>b#BlTTxnY zWQL}ZHDzx1ZEQO#mbGFdDkw;B_LXcoM4E60G?51=*?P)8GqCzzlW~{fcN|4~qlA^Bg^ZXxD{moZrdr%JYKF@1ReQ;kwCYbpBo$X|)B`@py z1W;ZJWu78d-&2gB&j8O==U=8DoVdt+&J$B1wO@3ZEXRr5P%baBsfh(TPny(WFB;=v zG6pPe=ojF^u>&yjAJ@0ixe|rmyf8O<=bCcMi#M7gby4-V$-E>mRAC%a3u3MQ+gFhV zltnDsR3s@CYF)T2)Ujt{zfF-62< zLhY+&MEyfh!IYe|LpHqw7Dp=D_q6EgR7-TijK>2Vw?Chm-&6o)tID{nfptyejl;Zs zQ%klJin%}#X;a_amA?TAm-Q}98GjPk?X|ZRLN}8@==!nNI9M4lVDN! z&(*{(sg2c1y?stPy8^_0=g|jUyhI6K4rUr2?O)0ft&jUic6l2`IO$z-F%GW)sw@z& zOcK3N7>6yYhk0FK*$x!Bmi!jin_V89*fazehANvoZZfyKdLLpE#gnC}1srEijKNA= z-8d5Ub$4^YtcCO#N{B|dH?QU9$PDM?LQrCa^DOGHsnA zR#B6Vv^EltZ7fhlnuuss6X-{?UZiHNN6jcEOeiFBJ_a)oR;VM4=pt!GY=%*ec2e>| ziy^7E-J7r7mgg4j*I23z*3BDfrdPie+XV~B1lVeK99}?{9bLf5!&@6&btkf#Wh0BT z8A(R~N*f7+gahL3S{T#{W=e4YPeB_PjH6SE>uW9yb8Txk@51?^wJ=vzir9M9cYTqs z0;2E6wL2*p5QS}i)O&4bv1-|Z=i$m;3cy~X25ifzW3XXYZqFRJdE-$F7@Mk|qdnUv zr%!Yj*9>KOWK^!FBUP)TReMCQCES`XX-ILdafO7al4!dg$D`OOB7&DuYw4VU_JM-S T3k0y)KjQ94rwS4W_2;wTDyY|i literal 2838 zcmV+x3+ePiT4*^jL0KkKSq}>Kv;Z5Gf5QL&Xaz!l|KNXb-@w2B|L{Nn00;;H;0(VP zyxy2^4+E$Yk3a_^f%CqCi3i9UQ1H~m6A05mFp~+QV?{j*JkwOr*&qW!qee`{2C3j8 z36(vmlS#3uJfq4000001kN^Wy$)J>?4^g9K2198BAOVm8k%0ptkOZ1YNh#`&)b%us zpQQk39-slEBPM_V0iXcNh?_+8n9-r3GGGHyfCOYFnoS+%fZ05U-Y7DNxe_sid>n*HyLfA6<%vHyqL_xaW#XwC)n z&i6#kK2@MgN*Rl4f#Z@23V*!c9Gsi!}9 zX(V$r<&Fa7YrN{M|2M@L3-Knb*0OCI!_r@i-U|-7CSRSk&!VlYt6_&0%i|{ojSBoQ z>uhjYxLcz_$%cI#lXeDh>!?0wpT2Lc&~K#Eo>dayO>wcxT5p%f<9aF2Q z_2^}8sM%ASvs9;q5jRm1m^Fh#Q$;wNA0={RyN#s6-We~HE=-$QwLzB68J`Zv68#%$ zu)>S+)w%VoEf8Gs0Lu{q>2{tg_3-DK0BuACPJn_75kv?Q5*t*2D%oWUs)yc3_ zs49xVMnP0j5r`@>C<-hTMNwD_B8sXCqA2?QpT_N;JgU5YeDop<1s^p4<9!`;`Wu|X zM=JqmMWsa<(Yvd9&YJ5&a)sT6yWFpAZpU_YX~w(ShLUNCBm=5qU^a$b7M`a^4b;h5 z5h#E)iF)OmaW~q@wi`~l*I3)FZm|x{Q8`MGp&*dRjKdJgS`u_lv?Mq#lW#2>piL0Y z8O$9RPQ;b9Mgl5GZ890WPSz7l;=SeC2X(#Jwl6OdV#z8F_nC%8vk>i!fVNa?3<<0d z)Ys>wLU2*CUkQW4D`nY6qJP0V%7}|@AfHj~3hA4}KK)hI328fF_6;wpbD3-Qp zwRG4*_ibA=WwT0@uH10xn6b>v>hl7p5T2o4B!R8lXDCxv@}Sc)StXED zYYy(FVo{2=>Fr>kWeHb9iM?sI?V{U{Nv)iEyj_N->#K}c1gpNe)*ait>b%2QMwHM< z0|rR~*_5ud_jhF2oV;~h$(!xX2BPmU#U_wqG?0*tu^0_IK52G|-`&@nOZun*aRp#P zWB@`T=1E-4w5=;f+z9~5F|2~K*b*Rn&%KH9+Nj4MC54jMlu}V9WyCA&HGg0P*Ju=y z2tpAdsulJdl;fPmAZy&xOG*V{ORTnY=Mg6eDP=7|PTtvQ%Jq&iKNb zX0uENem7GBQkJB#6pBgUn3!8XPEkSc0w=`pxIkke5l~|Z-QAc57K%d4V9#cgCq13~ z26klP53OOZFD~yCO%$c5)U~7K$s`QK6H>ymjHrmUX+eX7P)0Pt3ZA#80)$EH+FOa9 zWIbG<^1`kzfp4Kf4cG!6JPUz~7ZE^GlvIrhz=ES~2|^8Ln>cWQNT)Kg!LraQ9x2+o zMJa5emp-<&1xFe&g;u3wG>?X`Jw^r~j9=GF*oqxBc%3sBDJ$|kxN!%Kg*Us3APW-8 zs0~Q!WT!?cdWtYC%SX3DlPoF?Cx4~hS{BhO3qTeUHo{gw765^g5RYvNZLPCEt-($j~^kp>I2qYc>#k9jK zt;^jnrwEDn8ZnbOW^(}~q*8K%$kcSAV1hwa1YLdPthi41oB%-}vb1nPAhWetN+7M5 z)?uHkfBqAQ$45D;`g=V7zsPa=1$_uzU?&iui82(R2!BNLr2LxMb zaJc(#%Atea-_mrg&~W7hkfY{T#;rH+r$b}7|2MyfUNXRiu+m;b%hO=Ega!bk=vfYp zQ=Zq5sn-dK6>&AHm78TcN?Xd=w;bp~&Iv}typpz}gHDZoJOfo&-^FDytAa;vu~P#6 z9@H8!;3h%K`>@0XjWXm-X|?6{km~a`iui7v;$i(g>Q!q5C?pA9w~Rv^!&CW{_Kfm? z-DT~&60f@u8cJP`lU{7&RPXI> zE^IHhLkg@yHbL5XcCq7H{K!S|YJ{{c7eca?G7ljQ5RBCa)PEMu{WpI4nU%`lQy6mkjR6SUD|bmS-kgmy`<28Q7=!lsqnb||GAsw83yyp)cTok; z=VnO1A->6-5(zP_S21gskumH*h~jM_(B$LeQ}WN$e3cH87m+>8tPau!36MoiK_)(e z6)U8ip4776Lp#53M!{egYI&EauYlU zqnW|9B-dBG7Va82ZQUOds40fLw9aoGVpTX!zVBsWrJBol%CNq^#;*60u)PN&$Lld= z`YX<3j9$zoy=4fv=7)n#NtKjY0JAy>Xe(xAi$4DYS%M?HH0ru-gzP4Ul+0^tGCKkV%H8aK@qput+@F67+2iX(*O2iibD olSR^xYtii%N(M??%dc?%fP3h8>qdxZ^dJ0P$rRy2Ks+nj&=-tQ!vFvP diff --git a/R/ui_elements.R b/R/ui_elements.R index 0aea99e8..cac844a0 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -83,9 +83,9 @@ ui_elements <- function(selection) { layout_params = "dropdown", # title = "Choose a datafile to upload", file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta"), - limit_default = global_freesearchR$data_limit_default, - limit_lower = global_freesearchR$data_limit_lower, - limit_upper = global_freesearchR$data_limit_upper + limit_default = DATA_LIMIT_DEFAULT, + limit_lower = DATA_LIMIT_LOWER, + limit_upper = DATA_LIMIT_UPPER ) ), @@ -107,7 +107,7 @@ ui_elements <- function(selection) { id = "env", title = NULL, packages = c("NHANES", "stRoke", "datasets", "MASS"), - globalenv = global_freesearchR$include_globalenv + globalenv = isTruthy(INCLUDE_GLOBALENV) ) ), # shiny::conditionalPanel( diff --git a/SESSION.md b/SESSION.md index 608dbe98..1193d865 100644 --- a/SESSION.md +++ b/SESSION.md @@ -26,8 +26,6 @@ |apexcharter |0.4.5 |2026-01-07 |CRAN (R 4.5.2) | |askpass |1.2.1 |2024-10-04 |CRAN (R 4.5.0) | |assertthat |0.2.1 |2019-03-21 |CRAN (R 4.5.0) | -|attachment |0.4.5 |2025-03-14 |CRAN (R 4.5.0) | -|attempt |0.3.1 |2020-05-03 |CRAN (R 4.5.0) | |backports |1.5.0 |2024-05-23 |CRAN (R 4.5.0) | |base64enc |0.1-6 |2026-02-02 |CRAN (R 4.5.2) | |bayestestR |0.17.0 |2025-08-29 |CRAN (R 4.5.0) | @@ -46,7 +44,6 @@ |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | -|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.2) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | @@ -56,8 +53,6 @@ |colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) | -|credentials |2.0.3 |2025-09-12 |CRAN (R 4.5.0) | -|curl |7.0.0 |2025-08-19 |CRAN (R 4.5.0) | |data.table |1.18.2.1 |2026-01-27 |CRAN (R 4.5.2) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.5.0) | |datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) | @@ -66,7 +61,6 @@ |devtools |2.4.6 |2025-10-03 |CRAN (R 4.5.0) | |DHARMa |0.4.7 |2024-10-18 |CRAN (R 4.5.0) | |digest |0.6.39 |2025-11-19 |CRAN (R 4.5.2) | -|dockerfiler |0.2.5 |2025-05-07 |CRAN (R 4.5.0) | |doParallel |1.0.17 |2022-02-07 |CRAN (R 4.5.0) | |dplyr |1.2.0 |2026-02-03 |CRAN (R 4.5.2) | |DT |0.34.0 |2025-09-02 |CRAN (R 4.5.0) | @@ -93,15 +87,12 @@ |fs |1.6.6 |2025-04-12 |CRAN (R 4.5.0) | |gdtools |0.5.0 |2026-02-09 |CRAN (R 4.5.2) | |generics |0.1.4 |2025-05-09 |CRAN (R 4.5.0) | -|gert |2.3.1 |2026-01-11 |CRAN (R 4.5.2) | |ggalluvial |0.12.5 |2023-02-22 |CRAN (R 4.5.0) | |ggcorrplot |0.1.4.1 |2023-09-05 |CRAN (R 4.5.0) | |ggforce |0.5.0 |2025-06-18 |CRAN (R 4.5.0) | |ggplot2 |4.0.2 |2026-02-03 |CRAN (R 4.5.2) | |ggridges |0.5.7 |2025-08-27 |CRAN (R 4.5.0) | |ggstats |0.12.0 |2025-12-22 |CRAN (R 4.5.2) | -|gh |1.5.0 |2025-05-26 |CRAN (R 4.5.0) | -|gitcreds |0.1.2 |2022-09-08 |CRAN (R 4.5.0) | |glue |1.8.0 |2024-09-30 |CRAN (R 4.5.0) | |gridExtra |2.3 |2017-09-09 |CRAN (R 4.5.0) | |gt |1.3.0 |2026-01-22 |CRAN (R 4.5.2) | @@ -115,24 +106,20 @@ |htmltools |0.5.9 |2025-12-04 |CRAN (R 4.5.2) | |htmlwidgets |1.6.4 |2023-12-06 |CRAN (R 4.5.0) | |httpuv |1.6.16 |2025-04-16 |CRAN (R 4.5.0) | -|httr2 |1.2.2 |2025-12-08 |CRAN (R 4.5.2) | |IDEAFilter |0.2.1 |2025-07-29 |CRAN (R 4.5.0) | |insight |1.4.6 |2026-02-04 |CRAN (R 4.5.2) | |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) | -|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.5.0) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.2) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | |later |1.4.6 |2026-02-13 |CRAN (R 4.5.2) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) | |lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) | -|litedown |0.9 |2025-12-18 |CRAN (R 4.5.2) | |lme4 |1.1-38 |2025-12-02 |CRAN (R 4.5.2) | |lubridate |1.9.5 |2026-02-04 |CRAN (R 4.5.2) | |magrittr |2.0.4 |2025-09-12 |CRAN (R 4.5.0) | -|markdown |2.0 |2025-03-23 |CRAN (R 4.5.0) | |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | |Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.2) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | @@ -148,7 +135,6 @@ |openssl |2.3.4 |2025-09-30 |CRAN (R 4.5.0) | |openxlsx2 |1.23.1 |2026-01-19 |CRAN (R 4.5.2) | |otel |0.2.0 |2025-08-29 |CRAN (R 4.5.0) | -|pak |0.9.2 |2025-12-22 |CRAN (R 4.5.2) | |parameters |0.28.3 |2025-11-25 |CRAN (R 4.5.2) | |patchwork |1.3.2 |2025-08-25 |CRAN (R 4.5.0) | |pbmcapply |1.5.1 |2022-04-28 |CRAN (R 4.5.0) | @@ -172,7 +158,6 @@ |R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) | |ragg |1.5.0 |2025-09-02 |CRAN (R 4.5.0) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) | -|rappdirs |0.3.4 |2026-01-17 |CRAN (R 4.5.2) | |rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) | |Rcpp |1.1.1 |2026-01-10 |CRAN (R 4.5.2) | @@ -205,7 +190,6 @@ |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) | -|shiny2docker |0.0.3 |2025-06-28 |CRAN (R 4.5.0) | |shinybusy |0.3.3 |2024-03-09 |CRAN (R 4.5.0) | |shinyjs |2.1.1 |2026-01-15 |CRAN (R 4.5.2) | |shinyTime |1.0.3 |2022-08-19 |CRAN (R 4.5.0) | @@ -214,7 +198,6 @@ |stringi |1.8.7 |2025-03-27 |CRAN (R 4.5.0) | |stringr |1.6.0 |2025-11-04 |CRAN (R 4.5.0) | |stRoke |25.9.2 |2025-09-30 |CRAN (R 4.5.0) | -|sys |3.4.3 |2024-10-04 |CRAN (R 4.5.0) | |systemfonts |1.3.1 |2025-10-01 |CRAN (R 4.5.0) | |testthat |3.3.2 |2026-01-11 |CRAN (R 4.5.2) | |textshaping |1.0.4 |2025-10-10 |CRAN (R 4.5.0) | @@ -229,7 +212,6 @@ |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.5.0) | |usethis |3.2.1 |2025-09-06 |CRAN (R 4.5.0) | |uuid |1.2-2 |2026-01-23 |CRAN (R 4.5.2) | -|V8 |8.0.1 |2025-10-10 |CRAN (R 4.5.0) | |vctrs |0.7.1 |2026-01-23 |CRAN (R 4.5.2) | |viridis |0.6.5 |2024-01-29 |CRAN (R 4.5.0) | |viridisLite |0.4.3 |2026-02-04 |CRAN (R 4.5.2) | @@ -240,5 +222,4 @@ |xml2 |1.5.2 |2026-01-17 |CRAN (R 4.5.2) | |xtable |1.8-4 |2019-04-21 |CRAN (R 4.5.0) | |yaml |2.3.12 |2025-12-10 |CRAN (R 4.5.2) | -|yesno |0.1.3 |2024-07-26 |CRAN (R 4.5.0) | |zip |2.3.3 |2025-05-13 |CRAN (R 4.5.0) | From 01b48dccb5deb3f5df8696a6f7a7c56ced4651df Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 11 Mar 2026 13:24:21 +0100 Subject: [PATCH 03/62] moved to new release. --- DESCRIPTION | 2 +- NEWS.md | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1c5d410d..e47380cb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.3.2 +Version: 26.3.3 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 7c44be1a..e5800992 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.3.3 + +*NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Docs are missing... + # FreesearchR 26.3.2 *FIX* Updating factor levels always created new factor. @@ -6,8 +10,6 @@ *NEW* New with_labels() function (and helpers) added to allow easy preservation of labels. -*NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Docs will follow. - # FreesearchR 26.3.1 *FIX* ~~Include font files for static loading without dependency on Google.~~ Kept webfonts from google as local fonts are not working for now. From 00906519277bde4c751547f4f0840cd27c1d2413 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 11 Mar 2026 14:45:56 +0100 Subject: [PATCH 04/62] fix: faster summary --- R/helpers.R | 37 ++++++++++++++++--------------------- 1 file changed, 16 insertions(+), 21 deletions(-) diff --git a/R/helpers.R b/R/helpers.R index 04fd8346..75fedb70 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -356,33 +356,28 @@ missing_fraction <- function(data) { #' sample(c(1:8, NA), 20, TRUE) #' ) |> data_description() data_description <- function(data, data_text = "Data") { - data <- if (shiny::is.reactive(data)) - data() - else - data + # Resolve reactive once + if (shiny::is.reactive(data)) data <- data() + + # Early return if null + if (is.null(data)) return(i18n$t("No data present.")) n <- nrow(data) + + # Early return if empty + if (n == 0L) return(i18n$t("No data present.")) + n_var <- ncol(data) - n_complete <- sum(complete.cases(data)) + + # Faster complete.cases alternative using rowSums on NA matrix + n_complete <- n - sum(rowSums(is.na(data)) > 0L) p_complete <- signif(100 * n_complete / n, 3) - if (is.null(data)) { - i18n$t("No data present.") - } else { - glue::glue( - i18n$t( - "{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases." - ) + glue::glue( + i18n$t( + "{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases." ) - } - # sprintf( - # "%s has %s observations and %s variables, with %s (%s%%) complete cases.", - # data_text, - # n, - # n_var, - # n_complete, - # p_complete - # ) + ) } From 16fdd3fdef8b1a53391826093a05c8ac62af51c2 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 11 Mar 2026 14:46:38 +0100 Subject: [PATCH 05/62] feat: mount volume in docker (compose) to automatically load content in app --- R/launch_FreesearchR.R | 88 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 88 insertions(+) diff --git a/R/launch_FreesearchR.R b/R/launch_FreesearchR.R index 469c443b..089cea90 100644 --- a/R/launch_FreesearchR.R +++ b/R/launch_FreesearchR.R @@ -57,3 +57,91 @@ get_config <- function(var_name, default = NULL) { stop(paste("Required config variable not set:", var_name)) } + + +## File loader - based on the module, uses hard coded default values +load_file <- function(path) { + read_fns <- list( + ods = "import_ods", + dta = "import_dta", + csv = "import_delim", + tsv = "import_delim", + txt = "import_delim", + xls = "import_xls", + xlsx = "import_xls", + rds = "import_rds" + ) + + ext <- tolower(tools::file_ext(path)) + + if (!ext %in% names(read_fns)) { + message("Unsupported file type, skipping: ", basename(path), " (.", ext, ")") + return(NULL) + } + + read_fn <- read_fns[[ext]] + + parameters <- list( + file = path, + sheet = 1, + skip = 0, + dec = ".", + encoding = "unknown" + ) + + # Trim parameters to only those accepted by the target function + parameters <- parameters[which(names(parameters) %in% rlang::fn_fmls_names(get(read_fn)))] + + result <- tryCatch( + rlang::exec(read_fn, !!!parameters), + error = function(e) { + # Fall back to rio::import + message("Primary loader failed for ", basename(path), ", trying rio::import") + tryCatch( + rio::import(path), + error = function(e2) { + message("Failed to load ", basename(path), ": ", e2$message) + NULL + } + ) + } + ) + + if (!is.null(result) && NROW(result) < 1) { + message("File loaded but contains no rows, skipping: ", basename(path)) + return(NULL) + } + + result +} + + +load_folder <- function(folder = "/app/data", envir = .GlobalEnv) { + if (is.null(folder) || !dir.exists(folder)) { + message("No data folder found, skipping load") + return(invisible(NULL)) + } + + files <- list.files(folder, full.names = TRUE) + if (length(files) == 0) { + message("Data folder is empty, skipping load") + return(invisible(NULL)) + } + + loaded <- vapply(files, function(file) { + result <- load_file(file) + if (is.null(result)) + return(FALSE) + name <- tools::file_path_sans_ext(basename(file)) + assign(name, default_parsing(result), envir = envir) + TRUE + }, logical(1)) + + message(sprintf( + "Loaded %d/%d files from %s", + sum(loaded), + length(files), + folder + )) + invisible(loaded) +} From 62aa629ad27e0c5967c685851622e17f0493f2ef Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 11:08:14 +0100 Subject: [PATCH 06/62] feat: revised docs on running locally --- README.md | 72 +++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 49 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index 7d03d815..8f7ccef3 100644 --- a/README.md +++ b/README.md @@ -25,45 +25,71 @@ This app has the following simple goals: 1. ease quick data overview and basic visualisations for any clinical researcher -## Run locally on your own machine +Here’s a polished and restructured version of your README section for clarity, conciseness, and user-friendliness: -The ***FreesearchR*** app can also run on your own machine with no data transmitted anywhere. Blow are the available options. +## Run Locally on Your Own Machine -### Run from R (or RStduio) +The **FreesearchR** app can be run locally on your machine, ensuring no data is transmitted externally. Below are the available options for setup and configuration. -Working with data in R, FreesearchR is a quick and easy tool to get overview and perform the first explorative analyses to get you going. +### Configuration & Data Loading -Any data available in the your R session will be available to the FreesearchR app. Just follow the below steps to get going: +The app can be configured either by passing a named list to `run_app()` or by setting environment variables in a **Docker Compose** file. The following variables control data access and display behavior. If no values are provided, the app will use the defaults listed below. -1. **Requirement:** You need to have [*R* installed](https://www.r-project.org/) and possibly an editor like [RStudio](https://posit.co/download/rstudio-desktop/). -1. Then open the *R* console and copy/paste the following code, that will install the `{devtools}` package and then the `{FreesearchR}` *R*-package with its dependencies: +**Configuration Variables** - ``` - require("devtools") - devtools::install_github("agdamsbo/FreesearchR") - library(FreesearchR) - # By loading mtcars to the environment, it will be available - # in the interface like any other data.frame - data(mtcars) - launch_FreesearchR() - ``` +| Variable | Description | Default | +|-------------------------|-----------------------------------------------------------------------------|-----------| +| `INCLUDE_GLOBALENV` | Load datasets already present in the global R environment into the app | `FALSE` | +| `DATA_LIMIT_DEFAULT` | Default number of observations for previewing or working with a dataset | `10,000` | +| `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit | `100,000` | +| `DATA_LIMIT_LOWER` | Minimum number of observations a user can set for the lower limit | `1` | -### Running with docker compose +### Run from R (or RStudio) -For advanced users, wanting to deploy the FreesearchR app to run anywhere, a docker image is available. +If you're working with data in R, **FreesearchR** is a quick and easy tool for exploratory analysis. -Below is the minimal `docker_compose.yml` file: +1. **Requirement:** Ensure you have [R](https://www.r-project.org/) installed, and optionally an editor like [RStudio](https://posit.co/download/rstudio-desktop/). -``` +2. Open the **R console** and run the following code to install the `{FreesearchR}` package and launch the app: + + ```r + if (!require("devtools")) install.packages("devtools") + devtools::install_github("agdamsbo/FreesearchR") + library(FreesearchR) + # Load sample data (e.g., mtcars) to make it available in the app + data(mtcars) + launch_FreesearchR(INCLUDE_GLOBALENV=TRUE) + ``` + +All the variables specified above can also be passed to the app on launch from R. + +### Running with Docker Compose + +For advanced users, you can deploy **FreesearchR** using Docker. A data folder can be mounted to `/app/data` to automatically load supported file types (`.csv`, `.tsv`, `.txt`, `.xls`, `.xlsx`, `.ods`, `.dta`, `.rds`) at startup. + +To mount a local data folder, add a `volumes` entry to your `docker-compose.yml` file: + +```yaml services: - freesearchr: - image: ghcr.io/agdamsbo/freesearchr:latest - ports: + shiny: + image: ghcr.io/agdamsbo/freesearchr:latest + volumes: + - ./data:/app/data:ro + environment: + - INCLUDE_GLOBALENV=FALSE + - DATA_LIMIT_DEFAULT=10000 + - DATA_LIMIT_UPPER=100000 + - DATA_LIMIT_LOWER=1 + ports: - '3838:3838' restart: on-failure ``` +- The `:ro` flag mounts the folder as **read-only**, preventing the app from modifying your original data files. + +- If no volume is mounted, the app will start without any preloaded datasets. + ## Code of Conduct Please note that the ***FreesearchR*** project is published with a [Contributor Code of Conduct](https://contributor-covenant.org/version/2/1/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. From 39db24c9be979588ef50e1873758ff9bd9229ffb Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 11:08:28 +0100 Subject: [PATCH 07/62] docs --- CITATION.cff | 2 +- NEWS.md | 4 +- R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/sysdata.rda | Bin 2661 -> 2667 bytes SESSION.md | 4 +- inst/translations/translation_da.csv | 60 +++++++++++++-------------- inst/translations/translation_sw.csv | 60 +++++++++++++-------------- 8 files changed, 68 insertions(+), 66 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 6d5ebe92..3baa4bf4 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.2 +version: 26.3.3 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/NEWS.md b/NEWS.md index e5800992..570ab7e2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,8 @@ # FreesearchR 26.3.3 -*NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Docs are missing... +*NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Described in the README. + +*FIX* faster data description function. # FreesearchR 26.3.2 diff --git a/R/app_version.R b/R/app_version.R index a87c4470..dccdf7c4 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.2' +app_version <- function()'26.3.3' diff --git a/R/hosted_version.R b/R/hosted_version.R index 771bd124..2306a9f6 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.2-260311' +hosted_version <- function()'v26.3.3-260311' diff --git a/R/sysdata.rda b/R/sysdata.rda index f20ba2552a749586b3c5f0ce62e1446fd82b4b4c..370024a5ce9e7ade03d0b750b138398b0b3598bb 100644 GIT binary patch delta 2584 zcmV+z3g`9Z6zdcYLRx4!F+o`-Q(3KX3CNKSAOWV4FDx%iLKz#8Ayc34VZCWfT;)D5`+PHDb+zY*wG-t_DI=PQ@E8^kHDh66; zg_$-TgnvXFRGI7OND_~lbvnCF51?j2wDO{b6ID{pOEWQCq8kb3WIYDvY8Z%9^;XQf z)7)%Qhi2GhW;0d_&^V%k5HRNlxv9GRnTw{P&yJ77)t)w^B3rhPI?mfH%xY#iWQ?vC zHReqA5JGtq1!NPQGf%(euFG?Y@`89|H6&@8a(~A0g0tXnf5q`dg8YiLn$}IVy7de7 z7=pK5PQS3y!w6|uUSZ{Z6td_mGjc3!wB9G7f)bhGi?wEBqZb9kOls$AM8y$y&34hj z`OyjP(-;wiRfSC5+{6npaS&W22rU`Kk(LO!W_1$J!NQHsZ-kx|7cYD$-s%Ws?#1s3 z$A4CYHnK2pY>Rl)oQG@Pk#BDSoxO)ogpluqW$s|W(AH?PbJ%m+jy7mPFAYn~+A!$0 za@=LlOuO-_kTD9B!7l1*)Ve5|a8b>OE$Mqk+#1(3<4!Nf2+1Ubf+SRA zQB*}(jAF(JprV5m7$~t-Vv88UC@c{XRagrY5hAK9*Xnk8v#Y&T-SOvX5LmslStjmw zxZ&+LH^WBtfU}EAiVmzbD%F%?K@_x_0Ved00>NumkYyIh0!c9>fJ1>WCUSzOrhg6> z60#u9fS4k(bj%TiYEFcaZmtTMXoIXMkWL$+L4rh)8IckegCLy&B1F=MIcVKznv^iS z!OewYUd&NMv?5fQBJl~l6&GuHmVw*e?&MuwDHcgka_-EElA>xw!o(D73J&l@r(dp> z3}(rW8LkSqIgUwWb6Nl#s%JGLU3UG9bYY4CHR@sj5jd_ZBc4 zLX4C|L4@I`5Mf0jG%Vc~h!Lk&qO?l!t~fbwcejo8tfNb*B$0yx1+yt#X@BL*CcvnqV{GbYTixQdo*b3DB6BTRwcE zgU<*jch7PF#E?Znh)!Iy0K(B=S!grWu*tuxv8RNUI&XA^>~=YIk(w!5F|@ltfocho z!m^C0iCQ3ogHTx023B+c$RzHO@@itRG1h@>N?tEO_6h;L1Os}jeSd=oa>-;VR#1@y zfKHVH$sv0$pSIFPka^f!WU19>71E`)RhK;NY6^}tVij#G6HIzFhgky{A|F*RF%&pz z?(oc9u&Lj7dy{?I6x(ZxGDRVlp(@V5HJuC&pb#P%)2G+U&YDz}Ir?1Xp=}bdwn!BT zSOBDqm`Fl%YRRPYGJni`1mQKI6yc?%D3U^y91K;Ak7M2IalZad$0ZV+9MrWetqQe8 zae`N!ooQ*U{v7SztH|G#wH2oZNNQ;lR#xwJ*2A)?YgQsMqJ)a;TuYNY;KryA3CF{8 zxuZ>*{M7;b7koLV7S>MJNr|~&nyi=4s8~&KAth6CQU$1K#(xNi014$5Zj9BaftVsd z5fA_t5J*Ho09fF9Clq~`#-4(ayaTfV`XnP!R%*+81gQ=T*(xgU4?n^6FWl93ceMcT zBkcCH$JYh)B59A0+1}Pll2ZP^utf#nwprpOZS^?H4Dbx~UUm9m`OA!l+~GAc8&&s7 zlFWFW#RB5{Du0-eQ>6K=MiTL^HWMIX#_oZB3@Z>b4$kwq#G#H4GU^%YQ^OYtS)da;>j>PL7pCw@fI^ za539+`T3poKn7a8tBS}MRNgq;JIB>DyJ0x1lmP~nJ^jgB@cihEim%;pXi7I5MW=2q z7d`y{VcSPV!<15D*j8Fe`RlI+XkNdkk7g0Pg;wY69^V=ZNI+f+K4p;Knr8A2ZGqv$ z*F(7;ynjvwOqR_rB^hu8gPGn*HU%Gy{aixonB7#H*VN;yuq;R3eGqlq#6Xqs=3$}k z)%>9v*#ESLXOXm1j+NIV5bE#>qQMIU!7J4Ph;rJfca_!+kl{<2Z^3POwbAL#gFr!e zVyUyX<12f&q4psxSvp#fQO0!W%oL@~(}6EnSATar8pvNkgs6mTgL?j6Y=F*wL?s3& zPcqJ{3acK-z=U%`GgM&n_qTC!w8XmQyD5oQRU6GWu}{l~@^dy=tscf4zJowrcM3Qy z=a=5J9Ehz5LFO0VYD|l1lLLTSh!WFk9v%h`_c>v+TK}6A3?NfUUAY<#Xb~)0&s?_c zHGlat=qf03A*mD`$}6EL!7?bS)GHox4_6{;dlIWW%RlbR~ir^z;! zOD#s(h5LE6cR+=vI?DgtVwYyGDu-53W)szA893`hVJP;}#ROTXhJ{f+gnKpWMrzfC z6N>ANM6Xyx#wsmk64-SSAxe!-t7R^(1fvZ|ydBxP{n>7DZryc?pxtcIwwh&o@qb;g zP`r>$hNp4Gs8(MM!X7(zZ%r+q+~)Bwfj-+wVuVRW(%K(DR?UZ zdWadbE~SpagJBOEk5Py+Vq^iJ00R?2lT3iga#g@g zB@DDM8I%IcD4?aWMNLd}Kv$cJ(x{-;q%yp`I{0Qn86lI)yUogA6LKk-No4?}FP802 z<+y2EQF0Qw+|JQjt*7tsXRu0(Lh_-HpguG~LDUj)XKfTMbm|dP{)pHrt ze?&orIi9`5fhhmaPgiPD>`P$UnY!57JKo$oaJO6V2#_h6l{6%8bp=v>^>XEJQ{4e>r1#!CCM(zvB3!!G1+r&1)vw-E>R75CvXM z47X8Zixd55`%E~knsrPiRqqsqRhxvcsA(cz4_dmt#@9}@3E=fP*!aE^eP-ufPP?If z^JeR*%qTfCZQa|d7HaCK%197mFBVouP3P?e1g9zwXY6Al)!#r6Cz4kdQ=*jEX9V zs}YP?!4wowVuJ-1Dy&gs7)1qwA}Xr^VuB=9MSA^C&o*^;s=K~C?IH^owreEa&et40 zrsnu)-mn&NX;DGdh?=!!8eomBD1b^$BY?nS)ubUtLO^7iWPn7V=r@}Se{)bAGMdVw z^aG+dk5JJVMw!rLT;0)4#6i{+NGA>KY(Pk4R%KHQLJ&@XVTZL*<)eGiJ7{5#8*@_!i%vIp&F0LNQkM?PH)?_z2zp|Y(rXCOe>M|)yQ=0)+nap` zqV1StC9t_|m6fG4%;O%nHF0CFUt?Dtvwd7qGv)}jh~i;$D^+VsIV6%~ia}GvV3Xf{ z{7(I1V20Z6!{tIIfi~vaGr1Yfw~iqY$fUSej$etUAmLK^gT@^ASUauI~)R%L<+M zceyv+p-r~9qa;!pY7(sL^I6cq>Hz{FojQGdtm&mmQ=g^IS{BhO3uJ*%m4FIJ$%KR_ zHmsUYGc3oze@+ux5l$LfQi&ufLBPdW$o4(nw;S)|+;UMV!Ocrj%FwG+R~RLE+18et z-{H>P>b#BlTTxnYWQL}ZHDzx1ZEQO#mbGFdDkw;B_LXcoM4E6e*m6QX6VgYh#7(;0TBQJVFZLk z00oW*qH#yrd}-(@8^Aj-AEH7v6=tlruu72N&61+7@bmm1QvJzW^)L}0g<6$xeENk^|#5q zBrsHA98wEnt^V6rkp+}REZSDF=Rwl@tOw~BB|<)G(HD*SqV{?{7Aq3m9oqEr-sY;- z=%m!6PXUe(x_dE2#A8D3t7b&~Lr}q#oU}tWf4u`1M=IL)wCL$nOLW4F#{(U=KcAW3 zQ~+hG%DAk7bxq@q!@PY{OSTh=xj+zUQ{UW`zYorc$g2I<285$=v|4uJ;d9^5_8qiz zTscK1Ern&IpPst#W`*nec=ll%$W?BB!R_&&w1frVqvlx+`KE6m=GYz_O>{ev>%`zx zf5~jp@==!nNI9M4lVDN!&(*{(sg2c1y?stPy8^_0=g|jUyhI6K4rUr2?O)0ft&jUi zc6l2`IO$z-F%GW)sw@z&OcK3N7>6yYhk0FK*$x!Bmi!jin_V89*fazehANvoZZfyK zdLLpE#gnC}1srEijKNA=-8d5Ub$4^Yf2@V{7)ppnxHqrm=Ew}^ zS9AzkW2~?J#wm7c@~CxX24Ou`QIn3eHWH6*EKo(7h-g(4=tr|&q-L#0%_t^JC?s+| z1~U*=s3VN%B56i!hEa}oQu0BIA*r|Bo3GuL=N9ePSgH-y%^PW^SHBh8e+3K41lVeK z99}?{9bLf5!&@6&btkf#Wh0BT8A(R~N*f7+gahL3S{T#{W=e4YPeB_PjH6SE>uW9y zb8Txk@51?^wJ=vzir9M9cYTqs0;2E6wL2*p5QS}i)O&4bv1-|Z=i$m;3cy~X25ifz zW3XXYZqFRJdE-$F7@Mk|NTWU5C#O$z7uO7Bd1O?srz2IXqg8uEuO-}?FKI||u5pEg osFG;A9>=5DDI$WGQETa(f%bud%L@ds*+1g$NT&)C2leN(;HZwe=Kufz diff --git a/SESSION.md b/SESSION.md index 1193d865..907e05c0 100644 --- a/SESSION.md +++ b/SESSION.md @@ -15,7 +15,7 @@ |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.2.260311 | +|FreesearchR |26.3.3.260311 | -------------------------------------------------------------------------------- @@ -83,7 +83,7 @@ |foreach |1.5.2 |2022-02-02 |CRAN (R 4.5.0) | |foreign |0.8-90 |2025-03-31 |CRAN (R 4.5.2) | |Formula |1.2-5 |2023-02-24 |CRAN (R 4.5.0) | -|FreesearchR |26.3.2 |NA |NA | +|FreesearchR |26.3.3 |NA |NA | |fs |1.6.6 |2025-04-12 |CRAN (R 4.5.0) | |gdtools |0.5.0 |2026-02-09 |CRAN (R 4.5.2) | |generics |0.1.4 |2025-05-09 |CRAN (R 4.5.0) | diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 86a7f72b..15991bfe 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -1,9 +1,6 @@ "en","da" "Hello","Hej" "Get started","Kom i gang" -"File upload","Upload fil" -"REDCap server export","Eksport fra REDCap server" -"Local or sample data","Lokal eller testdata" "Please be mindfull handling sensitive data","Pas godt på og overvej nøje hvordan du håndterer personfølsomme data" "Quick overview","Hurtigt overblik" "Select variables for final import","Vælg variabler til den endelige import" @@ -132,7 +129,6 @@ "Coefficients plot","Koefficientgraf" "Checks","Test af model" "Browse observations","Gennemse observationer" -"Settings","Indstillinger" "The following error occured on determining correlations:","Følgende fejl opstod i forbindelse med korrelationsanalysen:" "No missing observations","Ingen manglende observationer" "There is a total of {p_miss} % missing observations.","Der er i alt {p_miss} % manglende observationer." @@ -145,15 +141,7 @@ "Missings","Manglende observationer" "Class","Klasse" "Observations","Observationer" -"Data classes and missing observations","Dataklasser og manglende observationer" -"Sure you want to reset data? This cannot be undone.","Er du sikker på at du vil gendanne data? Det kan ikke fortrydes." "Cancel","Afbryd" -"Confirm","Bekræft" -"The filtered data","Filtreret data" -"Create new factor","Ny kategorisk variabel" -"Create new variables","Opret nye variabler" -"Select data types to include","Vælg datatyper, der skal inkluderes" -"Uploaded data overview","Overblik over uploaded data" "Specify covariables","Angiv kovariabler" "If none are selected, all are included.","Hvis ingen er valgt inkluderes alle." "Analyse","Analysér" @@ -161,7 +149,6 @@ "Press 'Analyse' to create the regression model and after changing parameters.","Tryk 'Analysér' for at danne regressionsmodel og for at opdatere hvis parametre ændres." "Show p-value","Vis p-værdi" "Model checks","Model-test" -"Please confirm data reset!","Bekræft gendannelse af data!" "Import data from REDCap","Importér data fra REDCap" "REDCap server","REDCap-server" "Web address","Serveradresse" @@ -210,18 +197,7 @@ "Multivariable regression model checks","Tests af multivariabel regressionsmodel" "Grouped by {get_label(data,ter)}","Grupperet efter {get_label(data,ter)}" "Option to perform statistical comparisons between strata in baseline table.","Mulighed for at udføre statistiske tests mellem strata i oversigtstabellen." -"The data includes {n_col} variables. Please limit to 100.","Data indeholder {n_col} variabler. Begræns venligst til 100." -"Data import","Data import" -"Data import formatting","Formatering af data ved import" -"Data modifications","Ændringer af data" -"Variables filter","Variables filter" -"Data filter","Data filter" -"Data characteristics table","Oversigtstabel" -"The dataset without text variables","Datasættet uden variabler formateret som tekst" -"Creating the table. Hold on for a moment..","Opretter tabellen. Vent et øjeblik.." "Generating the report. Hold on for a moment..","Opretter rapporten. Vent et øjeblik.." -"We encountered the following error showing missingness:","Under analysen af manglende observationer opstod følgende fejl:" -"We encountered the following error browsing your data:","I forsøget på at vise en dataoversigt opstod følgende fejl:" "Choose a name for the column to be created or modified, then enter an expression before clicking on the button below to create the variable, or cancel to exit without saving anything.","Vælg et navn til den nye variabel, skriv din formel og tryk så på knappen for at gemme variablen, eller annuler for at lukke uden at gemme." "Please fill in web address and API token, then press 'Connect'.","Udfyld serveradresse og API-nøgle, og tryk så 'Fobind'." "Other","Other" @@ -254,16 +230,12 @@ "Browse data preview","Forhåndsvisning af resultat" "Split character string","Opdel tegnstreng" "Split text","Opdel tekst" -"Split a character string by a common delimiter","Opdel en tekstkolonne med en fælles afgrænser" "Apply split","Anvend opdeling" "Stacked relative barplot","Stablet relativt søjlediagram" "Create relative stacked barplots to show the distribution of categorical levels","Opret relative stablede søjlediagrammer for at vise fordelingen af kategoriske niveauer" "Side-by-side barplot","Side om side barplot" "Create side-by-side barplot to show the distribution of categorical levels","Opret et side-om-side søjlediagram for at vise fordelingen af kategoriske niveauer" "Select table theme","Vælg tema" -"Level of detail","Detaljeniveau" -"Minimal","Minimal" -"Extensive","Stor" "Letters","Bogstaver" "Words","Ord" "Shorten to first letters","Afkort til første bogstaver" @@ -312,7 +284,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være forberedt på at bruge R direkte." "The app contains a selelct number of features and will guide you through key analyses.","Appen indeholder udvalgte funktioner, og guider dig gennem de vigtigste analyser." "Sort by Levels","Sorter efter niveauer" -"Reorder factor levels","Omarranger niveauer" "Modify factor levels","Ændr kategoriske niveauer" "Reorder or rename the levels of factor/categorical variables.","Ændr navn eller rækkefølge på kategorisk variabel." "Maximum number of observations:","Maximale antal observationer:" @@ -326,5 +297,34 @@ "No data present.","Ingen data tilstede." "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." -"Sample data","Træningsdata" "Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" +"Data classes and missing observations","Data classes and missing observations" +"We encountered the following error showing missingness:","We encountered the following error showing missingness:" +"Please confirm data reset!","Please confirm data reset!" +"Sure you want to reset data? This cannot be undone.","Sure you want to reset data? This cannot be undone." +"Confirm","Confirm" +"The filtered data","The filtered data" +"Reorder factor levels","Reorder factor levels" +"Split a character string by a common delimiter","Split a character string by a common delimiter" +"Create new variables","Create new variables" +"Select data types to include","Select data types to include" +"Uploaded data overview","Uploaded data overview" +"We encountered the following error browsing your data:","We encountered the following error browsing your data:" +"Data import","Data import" +"Data import formatting","Data import formatting" +"Data modifications","Data modifications" +"Variables filter","Variables filter" +"Data filter","Data filter" +"Data characteristics table","Data characteristics table" +"Level of detail","Level of detail" +"Minimal","Minimal" +"Extensive","Extensive" +"The dataset without text variables","The dataset without text variables" +"The data includes {n_col} variables. Please limit to 100.","The data includes {n_col} variables. Please limit to 100." +"Creating the table. Hold on for a moment..","Creating the table. Hold on for a moment.." +"File upload","File upload" +"REDCap server export","REDCap server export" +"Local or sample data","Local or sample data" +"Sample data","Sample data" +"Settings","Settings" +"Create new factor","Create new factor" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 1193ea71..4388ae6e 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -1,9 +1,6 @@ "en","sw" "Hello","Habari" "Get started","Tuanze!" -"File upload","Upakiaji wa faili" -"REDCap server export","Usafirishaji wa seva ya REDCap" -"Local or sample data","Data ya ndani au ya sampuli" "Please be mindfull handling sensitive data","Tafadhali kuwa mwangalifu kushughulikia data nyeti" "Quick overview","Muhtasari wa haraka" "Select variables for final import","Chagua vigezo vya kuingiza mwisho" @@ -132,7 +129,6 @@ "Coefficients plot","Mchoro wa viambato" "Checks","Hundi" "Browse observations","Vinjari uchunguzi" -"Settings","Mipangilio" "The following error occured on determining correlations:","Hitilafu ifuatayo ilitokea katika kubaini uhusiano:" "No missing observations","Hakuna uchunguzi unaokosekana" "There is a total of {p_miss} % missing observations.","Kuna jumla ya uchunguzi wa {p_miss}% unaokosekana." @@ -145,15 +141,7 @@ "Missings","Hazipo" "Class","Darasa" "Observations","Uchunguzi" -"Data classes and missing observations","Madarasa ya data na uchunguzi unaokosekana" -"Sure you want to reset data? This cannot be undone.","Una uhakika unataka kuweka upya data? Hii haiwezi kutenduliwa." "Cancel","Ghairi" -"Confirm","Thibitisha" -"The filtered data","Data iliyochujwa" -"Create new factor","Unda kipengele kipya" -"Create new variables","Unda vigezo vipya" -"Select data types to include","Chagua aina za data za kujumuisha" -"Uploaded data overview","Muhtasari wa data iliyopakiwa" "Specify covariables","Bainisha vigeu vinavyoweza kuunganishwa" "If none are selected, all are included.","Ikiwa hakuna aliyechaguliwa, wote wamejumuishwa." "Analyse","Changanua" @@ -161,7 +149,6 @@ "Press 'Analyse' to create the regression model and after changing parameters.","Bonyeza 'Changanua' ili kuunda modeli ya urejeshaji na baada ya kubadilisha vigezo." "Show p-value","Onyesha thamani ya p" "Model checks","Ukaguzi wa modeli" -"Please confirm data reset!","Tafadhali thibitisha urejeshaji wa data!" "Import data from REDCap","Ingiza data kutoka REDCap" "REDCap server","Seva ya REDCap" "Web address","Anwani ya wavuti" @@ -210,18 +197,7 @@ "Multivariable regression model checks","Ukaguzi wa modeli ya urejeshaji unaoweza kubadilika-badilika" "Grouped by {get_label(data,ter)}","Imepangwa kwa makundi kulingana na {get_label(data,ter)}" "Option to perform statistical comparisons between strata in baseline table.","Chaguo la kufanya ulinganisho wa takwimu kati ya tabaka katika jedwali la msingi." -"The data includes {n_col} variables. Please limit to 100.","Data inajumuisha vigezo vya {n_col}. Tafadhali punguza hadi 100." -"Data import","Uingizaji wa data" -"Data import formatting","Uumbizaji wa kuingiza data" -"Data modifications","Marekebisho ya data" -"Variables filter","Kichujio cha vigeugeu" -"Data filter","Kichujio cha data" -"Data characteristics table","Jedwali la sifa za data" -"The dataset without text variables","Seti ya data bila vigeu vya maandishi" -"Creating the table. Hold on for a moment..","Kutengeneza meza. Subiri kwa muda.." "Generating the report. Hold on for a moment..","Inazalisha ripoti. Subiri kidogo.." -"We encountered the following error showing missingness:","Tulikutana na hitilafu ifuatayo inayoonyesha ukosefu:" -"We encountered the following error browsing your data:","Tulipata hitilafu ifuatayo wakati wa kuvinjari data yako:" "Choose a name for the column to be created or modified, then enter an expression before clicking on the button below to create the variable, or cancel to exit without saving anything.","Chagua jina la safu wima itakayoundwa au kurekebishwa, kisha ingiza usemi kabla ya kubofya kitufe kilicho hapa chini ili kuunda kigezo, au ghairi ili kutoka bila kuhifadhi chochote." "Other","Nyingine" "Hour of the day","Saa ya siku" @@ -249,7 +225,6 @@ "Split string to multiple observations (rows) in the same column. Also ads id and instance columns","Gawanya mfuatano katika uchunguzi mwingi (safu) katika safu wima moja. Pia vitambulisho vya matangazo na safu wima za mfano" "Split character string","Gawanya mfuatano wa herufi" "Split text","Gawanya maandishi" -"Split a character string by a common delimiter","Gawanya mfuatano wa herufi kwa kitenganishi cha kawaida" "Select delimiter","Chagua kidhibiti" "Browse data preview","Vinjari hakikisho la data" "Original data","Data asili" @@ -261,9 +236,6 @@ "Side-by-side barplot","Kipande cha baruni cha kando kwa kando" "Create side-by-side barplot to show the distribution of categorical levels","Unda mpangilio wa barufa kando ili kuonyesha usambazaji wa viwango vya kategoria" "Select table theme","Chagua mandhari ya jedwali" -"Level of detail","Kiwango cha maelezo" -"Minimal","Kidogo" -"Extensive","Kina" "Letters","Barua" "Words","Maneno" "Shorten to first letters","Fupisha herufi za kwanza" @@ -312,7 +284,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari kutumia R moja kwa moja." "The app contains a selelct number of features and will guide you through key analyses.","The app contains a selelct number of features and will guide you through key analyses." "Sort by Levels","Sort by Levels" -"Reorder factor levels","Reorder factor levels" "Modify factor levels","Modify factor levels" "Reorder or rename the levels of factor/categorical variables.","Reorder or rename the levels of factor/categorical variables." "Maximum number of observations:","Maximum number of observations:" @@ -326,5 +297,34 @@ "No data present.","No data present." "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." -"Sample data","Sample data" "Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" +"Data classes and missing observations","Data classes and missing observations" +"We encountered the following error showing missingness:","We encountered the following error showing missingness:" +"Please confirm data reset!","Please confirm data reset!" +"Sure you want to reset data? This cannot be undone.","Sure you want to reset data? This cannot be undone." +"Confirm","Confirm" +"The filtered data","The filtered data" +"Reorder factor levels","Reorder factor levels" +"Split a character string by a common delimiter","Split a character string by a common delimiter" +"Create new variables","Create new variables" +"Select data types to include","Select data types to include" +"Uploaded data overview","Uploaded data overview" +"We encountered the following error browsing your data:","We encountered the following error browsing your data:" +"Data import","Data import" +"Data import formatting","Data import formatting" +"Data modifications","Data modifications" +"Variables filter","Variables filter" +"Data filter","Data filter" +"Data characteristics table","Data characteristics table" +"Level of detail","Level of detail" +"Minimal","Minimal" +"Extensive","Extensive" +"The dataset without text variables","The dataset without text variables" +"The data includes {n_col} variables. Please limit to 100.","The data includes {n_col} variables. Please limit to 100." +"Creating the table. Hold on for a moment..","Creating the table. Hold on for a moment.." +"File upload","File upload" +"REDCap server export","REDCap server export" +"Local or sample data","Local or sample data" +"Sample data","Sample data" +"Settings","Settings" +"Create new factor","Create new factor" From a73f8b1ba3767894359fd19bd0016898cb76bb13 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 11:13:06 +0100 Subject: [PATCH 08/62] fixed spelling --- R/launch_FreesearchR.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/launch_FreesearchR.R b/R/launch_FreesearchR.R index 089cea90..99046649 100644 --- a/R/launch_FreesearchR.R +++ b/R/launch_FreesearchR.R @@ -18,7 +18,7 @@ #' data(mtcars) #' launch_FreesearchR(launch.browser = TRUE) #' } -launch_FreesearchR <- function(inlcude_globalenv = TRUE, +launch_FreesearchR <- function(include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 100000, data_limit_lower = 1, From 95fc0a4d5f3a731583eec6f5c3fdab73f3634715 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 11:32:06 +0100 Subject: [PATCH 09/62] fix: trying to fix launching with globals --- R/hosted_version.R | 2 +- R/launch_FreesearchR.R | 19 +++++++++++++++---- man/launch_FreesearchR.Rd | 8 ++++---- 3 files changed, 20 insertions(+), 9 deletions(-) diff --git a/R/hosted_version.R b/R/hosted_version.R index 2306a9f6..b15a5737 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.3-260311' +hosted_version <- function()'v26.3.3-260312' diff --git a/R/launch_FreesearchR.R b/R/launch_FreesearchR.R index 99046649..a789f185 100644 --- a/R/launch_FreesearchR.R +++ b/R/launch_FreesearchR.R @@ -43,14 +43,15 @@ launch_FreesearchR <- function(include_globalenv = TRUE, ## Helper to set env variables get_config <- function(var_name, default = NULL) { - # First check environment variables (set by Docker) - val <- Sys.getenv(var_name, unset = NA) + val <- Sys.getenv(var_name, unset = NA_character_) - if (!is.na(val) && nzchar(val)) { + # Only use env var if it is explicitly set and non-empty + if (!is.na(val) && nzchar(trimws(val))) { + if (is.logical(default)) return(to_logical(val)) + if (is.numeric(default)) return(as.numeric(val)) return(val) } - # Fall back to default (can be overridden when launching from R) if (!is.null(default)) { return(default) } @@ -58,6 +59,16 @@ get_config <- function(var_name, default = NULL) { stop(paste("Required config variable not set:", var_name)) } +to_logical <- function(x) { + result <- switch(tolower(trimws(as.character(x))), + "true" = , "1" = , "yes" = TRUE, + "false" = , "0" = , "no" = FALSE, + NA + ) + if (is.na(result)) stop(paste("Cannot coerce to logical:", x)) + result +} + ## File loader - based on the module, uses hard coded default values load_file <- function(path) { diff --git a/man/launch_FreesearchR.Rd b/man/launch_FreesearchR.Rd index e052ba7b..2ab6c607 100644 --- a/man/launch_FreesearchR.Rd +++ b/man/launch_FreesearchR.Rd @@ -5,7 +5,7 @@ \title{Easily launch the FreesearchR app} \usage{ launch_FreesearchR( - inlcude_globalenv = TRUE, + include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 1e+05, data_limit_lower = 1, @@ -13,6 +13,9 @@ launch_FreesearchR( ) } \arguments{ +\item{include_globalenv}{flag to include global env (local data) as option +when loading data} + \item{data_limit_default}{default data set observations limit} \item{data_limit_upper}{data set observations upper limit} @@ -20,9 +23,6 @@ launch_FreesearchR( \item{data_limit_lower}{data set observations lower limit} \item{...}{passed on to \code{shiny::runApp()}} - -\item{include_globalenv}{flag to include global env (local data) as option -when loading data} } \value{ shiny app From a8ff1c82040f7362faad45b289373691a9293fa1 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 11:58:09 +0100 Subject: [PATCH 10/62] packaging --- .gitignore | 1 - R/sysdata.rda | Bin 2667 -> 2668 bytes SESSION.md | 4 +- app_docker/app.R | 221 ++++++++++++++++----- app_docker/translations/translation_da.csv | 60 +++--- app_docker/translations/translation_sw.csv | 60 +++--- inst/apps/FreesearchR/app.R | 221 ++++++++++++++++----- 7 files changed, 406 insertions(+), 161 deletions(-) diff --git a/.gitignore b/.gitignore index 39765ab7..ce227491 100644 --- a/.gitignore +++ b/.gitignore @@ -6,7 +6,6 @@ dev/ .DS_Store .quarto app/rsconnect -inst/shiny-examples/casting/functions.R functions.R docs inst/doc diff --git a/R/sysdata.rda b/R/sysdata.rda index 370024a5ce9e7ade03d0b750b138398b0b3598bb..bf735f2dcec4f96eb89c18b40a68635bbf4208b7 100644 GIT binary patch delta 2667 zcmV-x3Y7Kh6zmiZLRx4!F+o`-Q(5&5gQSrT9)A}(mNyRvP^yh63KSR5z6t_>Du)eB zKqf;$GHA#`V5g9#)PAHefB-alhMuO$2C9ApCYmKYQ}mvw@ijN4GKOn7 zKz}p=pa1|GXaEFCB-F^lG$Yi}pvj4#27mwzO$JRe10~5<5i^Pzh+;5M3oN37mciHgIbWw^6+ctOr$P_-c8P4LlB#BOazut3PTBRVs|ahrENvZh@gy!@$qly zU*i8>HbYi^3XOGe5ACl!GHYUU%%<3;we;Lb-d2vA_!F(?caz5!S^ke z*Kp+TNxL~t-LZV%pVb$EtoHNAatO!KH zAc8#Z&yOi^Fv;%ZeW1?)xhfM~xOcU=vSi9^W;o=o$S!>5PX`fFffI&x7TY^l>woau zbvMNNK|FIC5;V;^V|c+^_?zGOJ}9tX0YA+#guAm zG%K(9G8bTO7HH72VV;~5R#!T(K-zRlz3tUp6vbE|NerD>yn=kDUv8 zcnZ_dboU}1?wq|TFf=uqEZp`Svd0^BAeV-v=4}{vEuAzn?bkmHYn%*1r7+9ddX+B< zCqfE2kp;gm=-Y=@=1F)Bs3?i9C*g+Oz6 zH%wYetEB)#SE+*MZ*QBGhuxnLLA+wkNtH?shF()qUp-9B4Lgq3APS{{O!73eo+eHj!$(`A@=zpy&#U~VF#xIc^ zc4M9T<=m1;-GZUM)WPc0t~|~%O$Wfr=sq7yzh%$Wq9YBsnW5S8f$lL^yh$j>FYB>8Y6I-frQJT;(;xr>;Aw zWZhbd(JR)v=q<$p{YnA>tTIlM7V7D2UC zF)L82$x(sgc#J8gYc#-Ty6D0bwxqEXiWAD1m|H(SQ9{&Z%FR*Y>axDYKtGFVnol@TjM5O8V>8eq!LC=7y6 zQ5}kz)&@GzEq{qi<@g@aKsR83Zq;xwVK`YVg(}JtAdm^c?NU{%x7TGF! znbmZuZIxxusjWd##;PG!(y=th%d9-;7{L(zRK19y(^rp7#mfqx7uDf8#)UV#iZVqK zw4?@-Jj=9jL@gePrTG@nZ>$K$6- ztq7-0Eh$8j6rkW@tYm#3gU{DF>)ditDbd=NrIn#psID+d_-CG4Yo6|V_ssV>-r9=O zqa-yniK{Dlcdd@qOIooJl^7B$t8p$&^M4wkJO>vA&hCviYxGnH?q2a`95d1FaF|+} z397+t`hSIV)&deuCgvh)hoEqXfB=-kPtlsK06P39!Xf|yx-o=A00n*pNdpUE;pIh0 zo&m|g^&%0Nt1})yVXvMvHPfanoE-1$Y+n1~!)u@$Nbv1Bk9?PyMCL!=4X)Fq)W7fc zh@iX{>wLvjzPA}co*|yg&d*#v`ngm+?h;cWl7GGRGOgpx?kE>0+gyb~PO0)*j3wi2 zZ6-j)t z{Un!eCl!@I5NS{2-j+WPzG%p*{Voj&Hse7gY{Ra#wGuo&T$bB4Ay-^)Fdn7iIIl3(SEQ*dk?z0rnWsa+}D*ot7Vt9XE*V zQ6+n~1g)9}sQ3%saQEq~duLz5ci zf~?_eQ-1gK1+ONK8pp_-6vJNZ@~^B^=8E<1`Q*~gWw6RYe@AOqbO=z#QD6EDPVMUS ztaHu`!don(Q;x(o5|1g`po=vS)T<}Vk9OSAnw_InvTfN`O$LmNV8b)8rn9VxN|kC# z_024aFw?17`TO^}{WH9LYqnYNXDQ5(UTF0u?DKA{!Bs|YBbe9DU|kwAE^x*10XU000Ton&^0`b z2}(vlWYYlv1|}v5WEmL%88m3YCXzy$nrJ}NMt}oA00000000o84^YvgMutFW4FJ#v zfPZKJ2ATi?5{We$FqsJT7=tE8KpFr5F*F%8$Oe}sTqML$%|i)(fLUb}6t*a-tCENc z^6^?#6dKfqXOo9x6v{&^GXLAWzvBp-kxS&3PzplyF^>*z=lkD7HlyG{?F zW3Fc%y2IguQh*R}e%(~OuY*L42*kooiRtnHKqJj`G=Lfl| zy8M}orlQY|kHgiTHlre2wvRf_+bqm#W;tYxt`{}tO!g2$c@qU>6P+_pzvZsWbAO5Q zf_P*#Bx#y*#_@u);BSA$@kN6CinW^7O|`o93-uU+w_Q%Zu+qZ_X;@xi<$V;g=qodF zENryiC!vB8nc<7IW@Dol1;b2g=W9g85q8aX(ZTuA3GUMv5rkEROx@hX3o&sJTqFoB z8O4#72)Jf-63@ZHjm~d`o)s4_e19n3>Ih`+#qSBnR)jXPFmG&&c+;GRYu=G>ZvmaX zhfjo%?}TOUV8GDUXtQ(JbK8zKXhAOxOU&9Z=(cj)WzS5z@v4w93Y5Vv>T1-wD4K9l z&4?}Odq&(E*EHqOHsGQrz@Q@p00u{Ztoe| zN~@&+L#eBN=WBB&Ru67`K?doEIVlLqB!q$_RAf<9MOcht#t5LIgA^Dju~lM=7{Vwl z5fN2b3ltF|sw>y(c6qa_y;a@u=V=gFy|Y;+?smB0?Kd~WM)iQRi%NSM5rk?^gpqEp3Ylnw ztSFF98=*mhM3EVh5*C9XodF_5(uX-{-DsMWFucLdg<@XJQAD&NRGA|23A_~-Yk8J| z+urWvU0x{`NlODrvkMTHV( zTtcF6qLs@+h@?OUA(AW3f&q3aj?fmeb{PudPWQadZiK0o4GvRb$3R_ZGibV;~n3!8We4>NT2q$;Xasb4TML~#8T(bbe(O_9< zGu5!kzpJsQgq1pPbcO78IdzemDOxeKyFh_z36jFHjHroPAcKQYSknepbO6XC?ve6p zVz4pRfow`%FMmMx3IV+Y1A41{g9mcSWGPlqkpzHFl>*5jdoQ21(nXMY*jr?&)n^sb zrM6XOA(o*k z&c8LC3=W_WA{o=C*UHYCRFygUT;-u{60o*N6$w}Xq<@TC zm(QqJO@DA9B~x-z1*mDp2#5d)>1@t0mkB`~j)=H96{=cwA z1>m+>;w5eMILZw04E0`h`eFIYjECIeH8LAj_kT%}%y^x}0^<8Bn2=MX`K?A0@vb%# zAY#Vufqo1t5Hk-U{d;{Yktkj3!vlA&d8aJ6vw5N?RUcb?o5Di{MiIpzwkqH4wRsR( zL{iPAYaVnRFS@{fk%Cks=B*KU->NTXqtRlqEy3NdPc80ht!|1itwL^Es9F=TSBuX|38l|;8pD9ms%+jIH(o%KKlTD+@@$QM-JINUqO z)ik?dIIENa29-Vi$y@OJ=!}Z5-Ee41HycH#ZY~!+{QqIwM@7SwQexOvT1olquLfvd zzo(C85xj*~=jCkl&hS@_!C(f#Jm0L%ANjP6bSs%`YVxa0G*y-bpqE zAB_E6Lh6{^RGZh-@Cu^A z3k1O{)d7fd+NgJx)(w#1OPO!MZF#lP>CJ;cL3m=Rv$o?ad$*zXAuL%sT98r3bbsi~ z6s676fiG8AcRU)%UqOVZglmI({$6Z=&VEEC1}IN5&Z`Qm9>~Cib3!vzVDtC4adNc8 zy5+kmiB?q`%{Q@6%ZKuFHdw75#vHzbKwWnVI4$Rw-n1Nutq4Kp7vE}3i)oVsfLe$W z(`p_b1`hW*VY6EQn-mNnQ%PO98h;LG5iDBIT(<2s`7`J$C~_gG6dcMcp(w#JD5}&e z9&!&?B5HdQt31r^{u}WW0_@L1^p(+e-;wZML^J3N0KOb;5xj>lj!xcP#c5hwGJj%+7B$NS zQNqZkdB2b?IJ9rlK7w#l4SO=%S74KxD$}RQHkL~*M%jh?d9`;yg{C^n|J-7iX0IxT zR#0XW)nyqt>qB8E_R_@!S*V7EQ9guwHR?uc)rAv^>y1ROSVYDuEoBnebrB&-jZUj& zF0KTl4M@Bl*}DDNZgFnib$^PW-E7genq_q#{c9j=_apyHh-J;pdG+EMjh| zdW`pMo}E3=UtBSj<&jdloQ+nljaBUuyq9uly`>?>xyBX}qDi9cdmfKqq>2h%MX{)I Y2i67~EG!bkWdDn~BAh5lR=9-Z09K#SfdBvi diff --git a/SESSION.md b/SESSION.md index 907e05c0..3e97a260 100644 --- a/SESSION.md +++ b/SESSION.md @@ -11,11 +11,11 @@ |collate |en_US.UTF-8 | |ctype |en_US.UTF-8 | |tz |Europe/Copenhagen | -|date |2026-03-11 | +|date |2026-03-12 | |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.3.260311 | +|FreesearchR |26.3.3.260312 | -------------------------------------------------------------------------------- diff --git a/app_docker/app.R b/app_docker/app.R index 7f99dcd4..72d8290a 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpsadCw0/file14b247eddca29.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmprp4Sq1/fileb602d982aa3.R ######## i18n_path <- here::here("translations") @@ -45,8 +45,7 @@ library(rlang) library(shiny.i18n) library(fontawesome) -print(list.files("www/fonts/montserrat", full.names = TRUE)) - +# print(list.files("www/fonts/montserrat", full.names = TRUE)) ## Translation init i18n <- shiny.i18n::Translator$new(translation_csvs_path = i18n_path) @@ -54,16 +53,6 @@ i18n <- shiny.i18n::Translator$new(translation_csvs_path = i18n_path) # i18n <- shiny.i18n::Translator$new(translation_csvs_path = here::here("inst/translations/")) i18n$set_translation_language("en") -## Global freesearchR vars -if (!"global_freesearchR" %in% ls(name = globalenv())) { - global_freesearchR <- list( - include_globalenv = FALSE, - data_limit_default = 1000, - data_limit_upper = 10000, - data_limit_lower = 1 - ) -} - ######## #### Current file: /Users/au301842/FreesearchR/app/functions.R @@ -75,7 +64,7 @@ if (!"global_freesearchR" %in% ls(name = globalenv())) { #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'26.3.2' +app_version <- function()'26.3.3' ######## @@ -4035,33 +4024,28 @@ missing_fraction <- function(data) { #' sample(c(1:8, NA), 20, TRUE) #' ) |> data_description() data_description <- function(data, data_text = "Data") { - data <- if (shiny::is.reactive(data)) - data() - else - data + # Resolve reactive once + if (shiny::is.reactive(data)) data <- data() + + # Early return if null + if (is.null(data)) return(i18n$t("No data present.")) n <- nrow(data) + + # Early return if empty + if (n == 0L) return(i18n$t("No data present.")) + n_var <- ncol(data) - n_complete <- sum(complete.cases(data)) + + # Faster complete.cases alternative using rowSums on NA matrix + n_complete <- n - sum(rowSums(is.na(data)) > 0L) p_complete <- signif(100 * n_complete / n, 3) - if (is.null(data)) { - i18n$t("No data present.") - } else { - glue::glue( - i18n$t( - "{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases." - ) + glue::glue( + i18n$t( + "{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases." ) - } - # sprintf( - # "%s has %s observations and %s variables, with %s (%s%%) complete cases.", - # data_text, - # n, - # n_var, - # n_complete, - # p_complete - # ) + ) } @@ -4527,7 +4511,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.2-260311' +hosted_version <- function()'v26.3.3-260312' ######## @@ -5987,16 +5971,16 @@ landing_page_ui <- function(i18n) { #' data(mtcars) #' launch_FreesearchR(launch.browser = TRUE) #' } -launch_FreesearchR <- function(inlcude_globalenv = TRUE, +launch_FreesearchR <- function(include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 100000, data_limit_lower = 1, ...) { - global_freesearchR <- list( - include_globalenv = include_globalenv, - data_limit_default = data_limit_default, - data_limit_upper = data_limit_upper, - data_limit_lower = data_limit_lower + Sys.setenv( + INCLUDE_GLOBALENV = include_globalenv, + DATA_LIMIT_DEFAULT = data_limit_default, + DATA_LIMIT_UPPER = data_limit_upper, + DATA_LIMIT_LOWER = data_limit_lower ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") @@ -6010,6 +5994,123 @@ launch_FreesearchR <- function(inlcude_globalenv = TRUE, } +## Helper to set env variables +get_config <- function(var_name, default = NULL) { + val <- Sys.getenv(var_name, unset = NA_character_) + + # Only use env var if it is explicitly set and non-empty + if (!is.na(val) && nzchar(trimws(val))) { + if (is.logical(default)) return(to_logical(val)) + if (is.numeric(default)) return(as.numeric(val)) + return(val) + } + + if (!is.null(default)) { + return(default) + } + + stop(paste("Required config variable not set:", var_name)) +} + +to_logical <- function(x) { + result <- switch(tolower(trimws(as.character(x))), + "true" = , "1" = , "yes" = TRUE, + "false" = , "0" = , "no" = FALSE, + NA + ) + if (is.na(result)) stop(paste("Cannot coerce to logical:", x)) + result +} + + +## File loader - based on the module, uses hard coded default values +load_file <- function(path) { + read_fns <- list( + ods = "import_ods", + dta = "import_dta", + csv = "import_delim", + tsv = "import_delim", + txt = "import_delim", + xls = "import_xls", + xlsx = "import_xls", + rds = "import_rds" + ) + + ext <- tolower(tools::file_ext(path)) + + if (!ext %in% names(read_fns)) { + message("Unsupported file type, skipping: ", basename(path), " (.", ext, ")") + return(NULL) + } + + read_fn <- read_fns[[ext]] + + parameters <- list( + file = path, + sheet = 1, + skip = 0, + dec = ".", + encoding = "unknown" + ) + + # Trim parameters to only those accepted by the target function + parameters <- parameters[which(names(parameters) %in% rlang::fn_fmls_names(get(read_fn)))] + + result <- tryCatch( + rlang::exec(read_fn, !!!parameters), + error = function(e) { + # Fall back to rio::import + message("Primary loader failed for ", basename(path), ", trying rio::import") + tryCatch( + rio::import(path), + error = function(e2) { + message("Failed to load ", basename(path), ": ", e2$message) + NULL + } + ) + } + ) + + if (!is.null(result) && NROW(result) < 1) { + message("File loaded but contains no rows, skipping: ", basename(path)) + return(NULL) + } + + result +} + + +load_folder <- function(folder = "/app/data", envir = .GlobalEnv) { + if (is.null(folder) || !dir.exists(folder)) { + message("No data folder found, skipping load") + return(invisible(NULL)) + } + + files <- list.files(folder, full.names = TRUE) + if (length(files) == 0) { + message("Data folder is empty, skipping load") + return(invisible(NULL)) + } + + loaded <- vapply(files, function(file) { + result <- load_file(file) + if (is.null(result)) + return(FALSE) + name <- tools::file_path_sans_ext(basename(file)) + assign(name, default_parsing(result), envir = envir) + TRUE + }, logical(1)) + + message(sprintf( + "Loaded %d/%d files from %s", + sum(loaded), + length(files), + folder + )) + invisible(loaded) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//missings-module.R ######## @@ -10726,9 +10827,9 @@ ui_elements <- function(selection) { layout_params = "dropdown", # title = "Choose a datafile to upload", file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta"), - limit_default = global_freesearchR$data_limit_default, - limit_lower = global_freesearchR$data_limit_lower, - limit_upper = global_freesearchR$data_limit_upper + limit_default = DATA_LIMIT_DEFAULT, + limit_lower = DATA_LIMIT_LOWER, + limit_upper = DATA_LIMIT_UPPER ) ), @@ -10750,7 +10851,7 @@ ui_elements <- function(selection) { id = "env", title = NULL, packages = c("NHANES", "stRoke", "datasets", "MASS"), - globalenv = global_freesearchR$include_globalenv + globalenv = isTruthy(INCLUDE_GLOBALENV) ) ), # shiny::conditionalPanel( @@ -13601,6 +13702,28 @@ dev_banner <- function(){ } +######## +#### Current file: /Users/au301842/FreesearchR/app/globals.R +######## + +## Setting global variables +INCLUDE_GLOBALENV <- get_config("INCLUDE_GLOBALENV", default = FALSE) +DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000) +DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000) +DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) + +## Loads folder passed to the docker container and mounted as below: +## +## services: +## shiny: +## image: your-shiny-app +## volumes: +## - ./data:/app/data:ro +## +## All files in the ./data/ folder is attempted loaded +load_folder() + + ######## #### Current file: /Users/au301842/FreesearchR/app/ui.R ######## @@ -13798,9 +13921,9 @@ server <- function(input, output, session) { # selected = "file" # ) - if (isTRUE(global_freesearchR$include_globalenv)) { + if (isTruthy(INCLUDE_GLOBALENV)) { env_label <- i18n$t("Local or sample data") - output$data_sample_text <- shiny::renderText(shiny::helpText( + output$data_sample_text <- shiny::renderUI(shiny::helpText( i18n$t( "Upload a file, get data directly from REDCap or use local or sample data." ) @@ -13893,7 +14016,7 @@ server <- function(input, output, session) { trigger_return = "change", btn_show_data = FALSE, reset = reactive(input$hidden), - limit_data = global_freesearchR$data_limit_upper + limit_data = DATA_LIMIT_UPPER ) shiny::observeEvent(from_env$data(), { diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 86a7f72b..15991bfe 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -1,9 +1,6 @@ "en","da" "Hello","Hej" "Get started","Kom i gang" -"File upload","Upload fil" -"REDCap server export","Eksport fra REDCap server" -"Local or sample data","Lokal eller testdata" "Please be mindfull handling sensitive data","Pas godt på og overvej nøje hvordan du håndterer personfølsomme data" "Quick overview","Hurtigt overblik" "Select variables for final import","Vælg variabler til den endelige import" @@ -132,7 +129,6 @@ "Coefficients plot","Koefficientgraf" "Checks","Test af model" "Browse observations","Gennemse observationer" -"Settings","Indstillinger" "The following error occured on determining correlations:","Følgende fejl opstod i forbindelse med korrelationsanalysen:" "No missing observations","Ingen manglende observationer" "There is a total of {p_miss} % missing observations.","Der er i alt {p_miss} % manglende observationer." @@ -145,15 +141,7 @@ "Missings","Manglende observationer" "Class","Klasse" "Observations","Observationer" -"Data classes and missing observations","Dataklasser og manglende observationer" -"Sure you want to reset data? This cannot be undone.","Er du sikker på at du vil gendanne data? Det kan ikke fortrydes." "Cancel","Afbryd" -"Confirm","Bekræft" -"The filtered data","Filtreret data" -"Create new factor","Ny kategorisk variabel" -"Create new variables","Opret nye variabler" -"Select data types to include","Vælg datatyper, der skal inkluderes" -"Uploaded data overview","Overblik over uploaded data" "Specify covariables","Angiv kovariabler" "If none are selected, all are included.","Hvis ingen er valgt inkluderes alle." "Analyse","Analysér" @@ -161,7 +149,6 @@ "Press 'Analyse' to create the regression model and after changing parameters.","Tryk 'Analysér' for at danne regressionsmodel og for at opdatere hvis parametre ændres." "Show p-value","Vis p-værdi" "Model checks","Model-test" -"Please confirm data reset!","Bekræft gendannelse af data!" "Import data from REDCap","Importér data fra REDCap" "REDCap server","REDCap-server" "Web address","Serveradresse" @@ -210,18 +197,7 @@ "Multivariable regression model checks","Tests af multivariabel regressionsmodel" "Grouped by {get_label(data,ter)}","Grupperet efter {get_label(data,ter)}" "Option to perform statistical comparisons between strata in baseline table.","Mulighed for at udføre statistiske tests mellem strata i oversigtstabellen." -"The data includes {n_col} variables. Please limit to 100.","Data indeholder {n_col} variabler. Begræns venligst til 100." -"Data import","Data import" -"Data import formatting","Formatering af data ved import" -"Data modifications","Ændringer af data" -"Variables filter","Variables filter" -"Data filter","Data filter" -"Data characteristics table","Oversigtstabel" -"The dataset without text variables","Datasættet uden variabler formateret som tekst" -"Creating the table. Hold on for a moment..","Opretter tabellen. Vent et øjeblik.." "Generating the report. Hold on for a moment..","Opretter rapporten. Vent et øjeblik.." -"We encountered the following error showing missingness:","Under analysen af manglende observationer opstod følgende fejl:" -"We encountered the following error browsing your data:","I forsøget på at vise en dataoversigt opstod følgende fejl:" "Choose a name for the column to be created or modified, then enter an expression before clicking on the button below to create the variable, or cancel to exit without saving anything.","Vælg et navn til den nye variabel, skriv din formel og tryk så på knappen for at gemme variablen, eller annuler for at lukke uden at gemme." "Please fill in web address and API token, then press 'Connect'.","Udfyld serveradresse og API-nøgle, og tryk så 'Fobind'." "Other","Other" @@ -254,16 +230,12 @@ "Browse data preview","Forhåndsvisning af resultat" "Split character string","Opdel tegnstreng" "Split text","Opdel tekst" -"Split a character string by a common delimiter","Opdel en tekstkolonne med en fælles afgrænser" "Apply split","Anvend opdeling" "Stacked relative barplot","Stablet relativt søjlediagram" "Create relative stacked barplots to show the distribution of categorical levels","Opret relative stablede søjlediagrammer for at vise fordelingen af kategoriske niveauer" "Side-by-side barplot","Side om side barplot" "Create side-by-side barplot to show the distribution of categorical levels","Opret et side-om-side søjlediagram for at vise fordelingen af kategoriske niveauer" "Select table theme","Vælg tema" -"Level of detail","Detaljeniveau" -"Minimal","Minimal" -"Extensive","Stor" "Letters","Bogstaver" "Words","Ord" "Shorten to first letters","Afkort til første bogstaver" @@ -312,7 +284,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være forberedt på at bruge R direkte." "The app contains a selelct number of features and will guide you through key analyses.","Appen indeholder udvalgte funktioner, og guider dig gennem de vigtigste analyser." "Sort by Levels","Sorter efter niveauer" -"Reorder factor levels","Omarranger niveauer" "Modify factor levels","Ændr kategoriske niveauer" "Reorder or rename the levels of factor/categorical variables.","Ændr navn eller rækkefølge på kategorisk variabel." "Maximum number of observations:","Maximale antal observationer:" @@ -326,5 +297,34 @@ "No data present.","Ingen data tilstede." "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." -"Sample data","Træningsdata" "Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" +"Data classes and missing observations","Data classes and missing observations" +"We encountered the following error showing missingness:","We encountered the following error showing missingness:" +"Please confirm data reset!","Please confirm data reset!" +"Sure you want to reset data? This cannot be undone.","Sure you want to reset data? This cannot be undone." +"Confirm","Confirm" +"The filtered data","The filtered data" +"Reorder factor levels","Reorder factor levels" +"Split a character string by a common delimiter","Split a character string by a common delimiter" +"Create new variables","Create new variables" +"Select data types to include","Select data types to include" +"Uploaded data overview","Uploaded data overview" +"We encountered the following error browsing your data:","We encountered the following error browsing your data:" +"Data import","Data import" +"Data import formatting","Data import formatting" +"Data modifications","Data modifications" +"Variables filter","Variables filter" +"Data filter","Data filter" +"Data characteristics table","Data characteristics table" +"Level of detail","Level of detail" +"Minimal","Minimal" +"Extensive","Extensive" +"The dataset without text variables","The dataset without text variables" +"The data includes {n_col} variables. Please limit to 100.","The data includes {n_col} variables. Please limit to 100." +"Creating the table. Hold on for a moment..","Creating the table. Hold on for a moment.." +"File upload","File upload" +"REDCap server export","REDCap server export" +"Local or sample data","Local or sample data" +"Sample data","Sample data" +"Settings","Settings" +"Create new factor","Create new factor" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 1193ea71..4388ae6e 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -1,9 +1,6 @@ "en","sw" "Hello","Habari" "Get started","Tuanze!" -"File upload","Upakiaji wa faili" -"REDCap server export","Usafirishaji wa seva ya REDCap" -"Local or sample data","Data ya ndani au ya sampuli" "Please be mindfull handling sensitive data","Tafadhali kuwa mwangalifu kushughulikia data nyeti" "Quick overview","Muhtasari wa haraka" "Select variables for final import","Chagua vigezo vya kuingiza mwisho" @@ -132,7 +129,6 @@ "Coefficients plot","Mchoro wa viambato" "Checks","Hundi" "Browse observations","Vinjari uchunguzi" -"Settings","Mipangilio" "The following error occured on determining correlations:","Hitilafu ifuatayo ilitokea katika kubaini uhusiano:" "No missing observations","Hakuna uchunguzi unaokosekana" "There is a total of {p_miss} % missing observations.","Kuna jumla ya uchunguzi wa {p_miss}% unaokosekana." @@ -145,15 +141,7 @@ "Missings","Hazipo" "Class","Darasa" "Observations","Uchunguzi" -"Data classes and missing observations","Madarasa ya data na uchunguzi unaokosekana" -"Sure you want to reset data? This cannot be undone.","Una uhakika unataka kuweka upya data? Hii haiwezi kutenduliwa." "Cancel","Ghairi" -"Confirm","Thibitisha" -"The filtered data","Data iliyochujwa" -"Create new factor","Unda kipengele kipya" -"Create new variables","Unda vigezo vipya" -"Select data types to include","Chagua aina za data za kujumuisha" -"Uploaded data overview","Muhtasari wa data iliyopakiwa" "Specify covariables","Bainisha vigeu vinavyoweza kuunganishwa" "If none are selected, all are included.","Ikiwa hakuna aliyechaguliwa, wote wamejumuishwa." "Analyse","Changanua" @@ -161,7 +149,6 @@ "Press 'Analyse' to create the regression model and after changing parameters.","Bonyeza 'Changanua' ili kuunda modeli ya urejeshaji na baada ya kubadilisha vigezo." "Show p-value","Onyesha thamani ya p" "Model checks","Ukaguzi wa modeli" -"Please confirm data reset!","Tafadhali thibitisha urejeshaji wa data!" "Import data from REDCap","Ingiza data kutoka REDCap" "REDCap server","Seva ya REDCap" "Web address","Anwani ya wavuti" @@ -210,18 +197,7 @@ "Multivariable regression model checks","Ukaguzi wa modeli ya urejeshaji unaoweza kubadilika-badilika" "Grouped by {get_label(data,ter)}","Imepangwa kwa makundi kulingana na {get_label(data,ter)}" "Option to perform statistical comparisons between strata in baseline table.","Chaguo la kufanya ulinganisho wa takwimu kati ya tabaka katika jedwali la msingi." -"The data includes {n_col} variables. Please limit to 100.","Data inajumuisha vigezo vya {n_col}. Tafadhali punguza hadi 100." -"Data import","Uingizaji wa data" -"Data import formatting","Uumbizaji wa kuingiza data" -"Data modifications","Marekebisho ya data" -"Variables filter","Kichujio cha vigeugeu" -"Data filter","Kichujio cha data" -"Data characteristics table","Jedwali la sifa za data" -"The dataset without text variables","Seti ya data bila vigeu vya maandishi" -"Creating the table. Hold on for a moment..","Kutengeneza meza. Subiri kwa muda.." "Generating the report. Hold on for a moment..","Inazalisha ripoti. Subiri kidogo.." -"We encountered the following error showing missingness:","Tulikutana na hitilafu ifuatayo inayoonyesha ukosefu:" -"We encountered the following error browsing your data:","Tulipata hitilafu ifuatayo wakati wa kuvinjari data yako:" "Choose a name for the column to be created or modified, then enter an expression before clicking on the button below to create the variable, or cancel to exit without saving anything.","Chagua jina la safu wima itakayoundwa au kurekebishwa, kisha ingiza usemi kabla ya kubofya kitufe kilicho hapa chini ili kuunda kigezo, au ghairi ili kutoka bila kuhifadhi chochote." "Other","Nyingine" "Hour of the day","Saa ya siku" @@ -249,7 +225,6 @@ "Split string to multiple observations (rows) in the same column. Also ads id and instance columns","Gawanya mfuatano katika uchunguzi mwingi (safu) katika safu wima moja. Pia vitambulisho vya matangazo na safu wima za mfano" "Split character string","Gawanya mfuatano wa herufi" "Split text","Gawanya maandishi" -"Split a character string by a common delimiter","Gawanya mfuatano wa herufi kwa kitenganishi cha kawaida" "Select delimiter","Chagua kidhibiti" "Browse data preview","Vinjari hakikisho la data" "Original data","Data asili" @@ -261,9 +236,6 @@ "Side-by-side barplot","Kipande cha baruni cha kando kwa kando" "Create side-by-side barplot to show the distribution of categorical levels","Unda mpangilio wa barufa kando ili kuonyesha usambazaji wa viwango vya kategoria" "Select table theme","Chagua mandhari ya jedwali" -"Level of detail","Kiwango cha maelezo" -"Minimal","Kidogo" -"Extensive","Kina" "Letters","Barua" "Words","Maneno" "Shorten to first letters","Fupisha herufi za kwanza" @@ -312,7 +284,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari kutumia R moja kwa moja." "The app contains a selelct number of features and will guide you through key analyses.","The app contains a selelct number of features and will guide you through key analyses." "Sort by Levels","Sort by Levels" -"Reorder factor levels","Reorder factor levels" "Modify factor levels","Modify factor levels" "Reorder or rename the levels of factor/categorical variables.","Reorder or rename the levels of factor/categorical variables." "Maximum number of observations:","Maximum number of observations:" @@ -326,5 +297,34 @@ "No data present.","No data present." "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." -"Sample data","Sample data" "Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" +"Data classes and missing observations","Data classes and missing observations" +"We encountered the following error showing missingness:","We encountered the following error showing missingness:" +"Please confirm data reset!","Please confirm data reset!" +"Sure you want to reset data? This cannot be undone.","Sure you want to reset data? This cannot be undone." +"Confirm","Confirm" +"The filtered data","The filtered data" +"Reorder factor levels","Reorder factor levels" +"Split a character string by a common delimiter","Split a character string by a common delimiter" +"Create new variables","Create new variables" +"Select data types to include","Select data types to include" +"Uploaded data overview","Uploaded data overview" +"We encountered the following error browsing your data:","We encountered the following error browsing your data:" +"Data import","Data import" +"Data import formatting","Data import formatting" +"Data modifications","Data modifications" +"Variables filter","Variables filter" +"Data filter","Data filter" +"Data characteristics table","Data characteristics table" +"Level of detail","Level of detail" +"Minimal","Minimal" +"Extensive","Extensive" +"The dataset without text variables","The dataset without text variables" +"The data includes {n_col} variables. Please limit to 100.","The data includes {n_col} variables. Please limit to 100." +"Creating the table. Hold on for a moment..","Creating the table. Hold on for a moment.." +"File upload","File upload" +"REDCap server export","REDCap server export" +"Local or sample data","Local or sample data" +"Sample data","Sample data" +"Settings","Settings" +"Create new factor","Create new factor" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 6007a903..de5e9f11 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//RtmpxB1KWR/file173c978fea931.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmprp4Sq1/fileb60491b0ce8.R ######## i18n_path <- system.file("translations", package = "FreesearchR") @@ -45,8 +45,7 @@ library(rlang) library(shiny.i18n) library(fontawesome) -print(list.files("www/fonts/montserrat", full.names = TRUE)) - +# print(list.files("www/fonts/montserrat", full.names = TRUE)) ## Translation init i18n <- shiny.i18n::Translator$new(translation_csvs_path = i18n_path) @@ -54,16 +53,6 @@ i18n <- shiny.i18n::Translator$new(translation_csvs_path = i18n_path) # i18n <- shiny.i18n::Translator$new(translation_csvs_path = here::here("inst/translations/")) i18n$set_translation_language("en") -## Global freesearchR vars -if (!"global_freesearchR" %in% ls(name = globalenv())) { - global_freesearchR <- list( - include_globalenv = FALSE, - data_limit_default = 1000, - data_limit_upper = 10000, - data_limit_lower = 1 - ) -} - ######## #### Current file: /Users/au301842/FreesearchR/app/functions.R @@ -75,7 +64,7 @@ if (!"global_freesearchR" %in% ls(name = globalenv())) { #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'26.3.2' +app_version <- function()'26.3.3' ######## @@ -4035,33 +4024,28 @@ missing_fraction <- function(data) { #' sample(c(1:8, NA), 20, TRUE) #' ) |> data_description() data_description <- function(data, data_text = "Data") { - data <- if (shiny::is.reactive(data)) - data() - else - data + # Resolve reactive once + if (shiny::is.reactive(data)) data <- data() + + # Early return if null + if (is.null(data)) return(i18n$t("No data present.")) n <- nrow(data) + + # Early return if empty + if (n == 0L) return(i18n$t("No data present.")) + n_var <- ncol(data) - n_complete <- sum(complete.cases(data)) + + # Faster complete.cases alternative using rowSums on NA matrix + n_complete <- n - sum(rowSums(is.na(data)) > 0L) p_complete <- signif(100 * n_complete / n, 3) - if (is.null(data)) { - i18n$t("No data present.") - } else { - glue::glue( - i18n$t( - "{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases." - ) + glue::glue( + i18n$t( + "{data_text} has {n} observations and {n_var} variables, with {n_complete} ({p_complete} %) complete cases." ) - } - # sprintf( - # "%s has %s observations and %s variables, with %s (%s%%) complete cases.", - # data_text, - # n, - # n_var, - # n_complete, - # p_complete - # ) + ) } @@ -4527,7 +4511,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.2-260311' +hosted_version <- function()'v26.3.3-260312' ######## @@ -5987,16 +5971,16 @@ landing_page_ui <- function(i18n) { #' data(mtcars) #' launch_FreesearchR(launch.browser = TRUE) #' } -launch_FreesearchR <- function(inlcude_globalenv = TRUE, +launch_FreesearchR <- function(include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 100000, data_limit_lower = 1, ...) { - global_freesearchR <- list( - include_globalenv = include_globalenv, - data_limit_default = data_limit_default, - data_limit_upper = data_limit_upper, - data_limit_lower = data_limit_lower + Sys.setenv( + INCLUDE_GLOBALENV = include_globalenv, + DATA_LIMIT_DEFAULT = data_limit_default, + DATA_LIMIT_UPPER = data_limit_upper, + DATA_LIMIT_LOWER = data_limit_lower ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") @@ -6010,6 +5994,123 @@ launch_FreesearchR <- function(inlcude_globalenv = TRUE, } +## Helper to set env variables +get_config <- function(var_name, default = NULL) { + val <- Sys.getenv(var_name, unset = NA_character_) + + # Only use env var if it is explicitly set and non-empty + if (!is.na(val) && nzchar(trimws(val))) { + if (is.logical(default)) return(to_logical(val)) + if (is.numeric(default)) return(as.numeric(val)) + return(val) + } + + if (!is.null(default)) { + return(default) + } + + stop(paste("Required config variable not set:", var_name)) +} + +to_logical <- function(x) { + result <- switch(tolower(trimws(as.character(x))), + "true" = , "1" = , "yes" = TRUE, + "false" = , "0" = , "no" = FALSE, + NA + ) + if (is.na(result)) stop(paste("Cannot coerce to logical:", x)) + result +} + + +## File loader - based on the module, uses hard coded default values +load_file <- function(path) { + read_fns <- list( + ods = "import_ods", + dta = "import_dta", + csv = "import_delim", + tsv = "import_delim", + txt = "import_delim", + xls = "import_xls", + xlsx = "import_xls", + rds = "import_rds" + ) + + ext <- tolower(tools::file_ext(path)) + + if (!ext %in% names(read_fns)) { + message("Unsupported file type, skipping: ", basename(path), " (.", ext, ")") + return(NULL) + } + + read_fn <- read_fns[[ext]] + + parameters <- list( + file = path, + sheet = 1, + skip = 0, + dec = ".", + encoding = "unknown" + ) + + # Trim parameters to only those accepted by the target function + parameters <- parameters[which(names(parameters) %in% rlang::fn_fmls_names(get(read_fn)))] + + result <- tryCatch( + rlang::exec(read_fn, !!!parameters), + error = function(e) { + # Fall back to rio::import + message("Primary loader failed for ", basename(path), ", trying rio::import") + tryCatch( + rio::import(path), + error = function(e2) { + message("Failed to load ", basename(path), ": ", e2$message) + NULL + } + ) + } + ) + + if (!is.null(result) && NROW(result) < 1) { + message("File loaded but contains no rows, skipping: ", basename(path)) + return(NULL) + } + + result +} + + +load_folder <- function(folder = "/app/data", envir = .GlobalEnv) { + if (is.null(folder) || !dir.exists(folder)) { + message("No data folder found, skipping load") + return(invisible(NULL)) + } + + files <- list.files(folder, full.names = TRUE) + if (length(files) == 0) { + message("Data folder is empty, skipping load") + return(invisible(NULL)) + } + + loaded <- vapply(files, function(file) { + result <- load_file(file) + if (is.null(result)) + return(FALSE) + name <- tools::file_path_sans_ext(basename(file)) + assign(name, default_parsing(result), envir = envir) + TRUE + }, logical(1)) + + message(sprintf( + "Loaded %d/%d files from %s", + sum(loaded), + length(files), + folder + )) + invisible(loaded) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//missings-module.R ######## @@ -10726,9 +10827,9 @@ ui_elements <- function(selection) { layout_params = "dropdown", # title = "Choose a datafile to upload", file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta"), - limit_default = global_freesearchR$data_limit_default, - limit_lower = global_freesearchR$data_limit_lower, - limit_upper = global_freesearchR$data_limit_upper + limit_default = DATA_LIMIT_DEFAULT, + limit_lower = DATA_LIMIT_LOWER, + limit_upper = DATA_LIMIT_UPPER ) ), @@ -10750,7 +10851,7 @@ ui_elements <- function(selection) { id = "env", title = NULL, packages = c("NHANES", "stRoke", "datasets", "MASS"), - globalenv = global_freesearchR$include_globalenv + globalenv = isTruthy(INCLUDE_GLOBALENV) ) ), # shiny::conditionalPanel( @@ -13601,6 +13702,28 @@ dev_banner <- function(){ } +######## +#### Current file: /Users/au301842/FreesearchR/app/globals.R +######## + +## Setting global variables +INCLUDE_GLOBALENV <- get_config("INCLUDE_GLOBALENV", default = FALSE) +DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000) +DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000) +DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) + +## Loads folder passed to the docker container and mounted as below: +## +## services: +## shiny: +## image: your-shiny-app +## volumes: +## - ./data:/app/data:ro +## +## All files in the ./data/ folder is attempted loaded +load_folder() + + ######## #### Current file: /Users/au301842/FreesearchR/app/ui.R ######## @@ -13798,9 +13921,9 @@ server <- function(input, output, session) { # selected = "file" # ) - if (isTRUE(global_freesearchR$include_globalenv)) { + if (isTruthy(INCLUDE_GLOBALENV)) { env_label <- i18n$t("Local or sample data") - output$data_sample_text <- shiny::renderText(shiny::helpText( + output$data_sample_text <- shiny::renderUI(shiny::helpText( i18n$t( "Upload a file, get data directly from REDCap or use local or sample data." ) @@ -13893,7 +14016,7 @@ server <- function(input, output, session) { trigger_return = "change", btn_show_data = FALSE, reset = reactive(input$hidden), - limit_data = global_freesearchR$data_limit_upper + limit_data = DATA_LIMIT_UPPER ) shiny::observeEvent(from_env$data(), { From 342579c36f362e02c4e6cf7a376324f70abc94cc Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 12:40:04 +0100 Subject: [PATCH 11/62] handle ordered factors --- R/data-summary.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/data-summary.R b/R/data-summary.R index ccb749bc..62f5e0bf 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -75,7 +75,7 @@ add_sparkline <- function(grid, column = "vals", color.main = "#2a8484", color.s type <- "line" ds <- data.frame(x = NA, y = NA) horizontal <- FALSE - } else if (identical(data_cl, "factor")) { + } else if ("factor" %in% data_cl) { type <- "column" s <- summary(data) ds <- data.frame(x = names(s), y = s) From f928aee11017ca88790dc483124281d813123f5b Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 12:40:31 +0100 Subject: [PATCH 12/62] fix: implement "with_labels" and added tests --- R/helpers.R | 29 +++--- tests/testthat/test-default-parsing.R | 134 ++++++++++++++++++++++++++ 2 files changed, 150 insertions(+), 13 deletions(-) create mode 100644 tests/testthat/test-default-parsing.R diff --git a/R/helpers.R b/R/helpers.R index 75fedb70..adc12777 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -219,20 +219,23 @@ file_export <- function(data, #' head(5) |> #' str() default_parsing <- function(data) { - name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) + # name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) # browser() - out <- data |> - setNames(make.names(names(data), unique = TRUE)) |> - ## Temporary step to avoid nested list and crashing - remove_nested_list() |> - REDCapCAST::parse_data() |> - REDCapCAST::as_factor() |> - REDCapCAST::numchar2fct(numeric.threshold = 8, - character.throshold = 10) |> - REDCapCAST::as_logical() |> - REDCapCAST::fct_drop() - - set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) + with_labels(data,{ + data |> + setNames(make.names(names(data), unique = TRUE)) |> + ## Temporary step to avoid nested list and crashing + remove_nested_list() |> + REDCapCAST::parse_data() |> + REDCapCAST::as_factor() |> + REDCapCAST::numchar2fct(numeric.threshold = 8, + character.throshold = 10) |> + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() + }) + # out <- + # + # set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) # purrr::map2( # out, diff --git a/tests/testthat/test-default-parsing.R b/tests/testthat/test-default-parsing.R new file mode 100644 index 00000000..8cd2455b --- /dev/null +++ b/tests/testthat/test-default-parsing.R @@ -0,0 +1,134 @@ +test_that("default_parsing returns a data.frame", { + result <- default_parsing(mtcars) + expect_true(is.data.frame(result)) +}) + +test_that("default_parsing preserves row count", { + result <- default_parsing(mtcars) + expect_equal(nrow(result), nrow(mtcars)) +}) + +test_that("default_parsing preserves column count", { + result <- default_parsing(mtcars) + expect_equal(ncol(result), ncol(mtcars)) +}) + +test_that("default_parsing produces valid column names (make.names compatible)", { + # Create data with problematic column names + bad_names_df <- data.frame( + `1bad` = 1:5, + `has space` = letters[1:5], + `good_name` = TRUE, + check.names = FALSE + ) + result <- default_parsing(bad_names_df) + expect_true(all(make.names(names(result)) == names(result))) +}) + +test_that("default_parsing handles duplicate column names", { + dup_df <- data.frame(a = 1:5, b = 6:10) + names(dup_df) <- c("x", "x") + result <- default_parsing(dup_df) + expect_equal(length(names(result)), 2) + expect_true(all(!duplicated(names(result)))) +}) + +test_that("default_parsing converts low-cardinality numeric columns to factor", { + # A numeric column with <= 8 unique values should become a factor + df <- data.frame( + group = c(1, 2, 3, 1, 2, 3, 1, 2), # 3 unique → factor + value = rnorm(8) # 8 unique → stays numeric + ) + result <- default_parsing(df) + expect_true(is.factor(result$group)) +}) + +test_that("default_parsing converts low-cardinality character columns to factor", { + # A character column with <= 10 unique values should become a factor + df <- data.frame( + category = rep(c("a", "b", "c"), 4), # 3 unique → factor + stringsAsFactors = FALSE + ) + result <- default_parsing(df) + expect_true(is.factor(result$category)) +}) + +test_that("default_parsing drops unused factor levels", { + df <- data.frame( + x = factor(c("a", "b", "a"), levels = c("a", "b", "c")) # "c" unused + ) + result <- default_parsing(df) + expect_false("c" %in% levels(result$x)) +}) + +test_that("default_parsing converts logical-like columns to logical", { + df <- data.frame( + flag = c(0L, 1L, 0L, 1L, 0L), + stringsAsFactors = FALSE + ) + result <- default_parsing(df) + # as_logical should have converted 0/1 integer to logical + expect_true(is.logical(result$flag)) +}) + +test_that("default_parsing preserves column labels when present", { + df <- data.frame(a = 1:3, b = c("x", "y", "z"), stringsAsFactors = FALSE) + attr(df$a, "label") <- "Column A Label" + attr(df$b, "label") <- "Column B Label" + + result <- default_parsing(df) + + expect_equal(attr(result$a, "label"), "Column A Label") + expect_equal(attr(result$b, "label"), "Column B Label") +}) + +test_that("default_parsing handles columns with no label attribute", { + df <- data.frame(a = 1:3, b = c("x", "y", "z"), stringsAsFactors = FALSE) + result <- default_parsing(df) + # Should not error; label attrs simply absent or NULL + expect_null(attr(result$a, "label")) +}) + +test_that("default_parsing handles a single-column data.frame", { + df <- data.frame(x = 1:10) + result <- default_parsing(df) + expect_equal(ncol(result), 1) + expect_equal(nrow(result), 10) +}) + +test_that("default_parsing handles an empty data.frame gracefully", { + df <- data.frame(a = integer(0), b = character(0), stringsAsFactors = FALSE) + result <- default_parsing(df) + expect_equal(nrow(result), 0) +}) + +test_that("default_parsing handles all-NA columns without error", { + df <- data.frame(a = NA_real_, b = NA_character_, stringsAsFactors = FALSE) + expect_no_error(default_parsing(df)) +}) + +test_that("default_parsing removes nested list columns", { + df <- data.frame(id = 1:3) + df$nested <- list(list(1, 2), list(3), list(4, 5)) # nested list column + # Should not crash; nested list column is removed by remove_nested_list() + expect_no_error(default_parsing(df)) +}) + +test_that("default_parsing works with dplyr::starwars-like tibble", { + skip_if_not_installed("dplyr") + sw <- head(dplyr::starwars, 10) + result <- default_parsing(sw) + expect_true(is.data.frame(result)) + expect_equal(nrow(result), 10) +}) + +test_that("default_parsing high-cardinality character column stays character or factor", { + # > 10 unique values → should NOT be coerced to factor by numchar2fct + df <- data.frame( + id = paste0("id_", 1:20), + stringsAsFactors = FALSE + ) + result <- default_parsing(df) + # high cardinality: remains character (not factor) + expect_false(is.factor(result$id)) +}) From 95e813753ff4a9acd86821640706dd1a9121d6d1 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 12:40:40 +0100 Subject: [PATCH 13/62] merge --- R/sysdata.rda | Bin 2668 -> 2671 bytes SESSION.md | 33 ++++---- app_docker/app.R | 33 ++++---- inst/apps/FreesearchR/app.R | 33 ++++---- renv.lock | 148 +++++++++++++++++++----------------- renv/activate.R | 4 +- 6 files changed, 130 insertions(+), 121 deletions(-) diff --git a/R/sysdata.rda b/R/sysdata.rda index bf735f2dcec4f96eb89c18b40a68635bbf4208b7..7ab55e91eff8121f1805d27dc695bbd323b19233 100644 GIT binary patch literal 2671 zcmV-#3Xt_eT4*^jL0KkKS$IOLcmNpnf5iX)Xaz!l|LA{j-@w2B|L{Nn0ssgB;0wPO zI?Ef60prY5M?jH4@DCz|>I}D6Vjig)Ou=qjST_mHq{t4JfPK2 z^a4qw^-m~b4UkNY000dD13&;8162JoB9!$HQM8*RHjwgw000000001!Nf8x2Q}s5c zME0oA8hVdvfuLx~lLQS713&;A4F;JFG-zQ1A)$gaG|8htG7LZfXd+4}>Uu=|O;1qC z=zwTw02%<$0}uen44IP088Q@Sp^UZF^RJjz>?Ymp`cyVor|(|t<6QgAObQYySeny!*l(Mcei)v{_MbhQt;E(e`SG` z`N;^XgZwgnKHB2(TprtM1zA==iU~dnAQK1t#yJ+#6pKuQXqROh%>>9CYO^Qy*o?vbAeyFD96&dX`^#faX4XO_$^xs%YJII=rC2WVI-rUMwPdgqj9AP z+Q*3OXxe*fbwkq7s!ldUx1=JR&%*Z91=`ahe z;XDx{`b}Xr=K8*N_;H#ztOcCfRYXpAb6L&hu5L}SYPMa_w|kZ7I~~)Ovszi9+S0n( zf?12JhObTvak;VR%6CZ?094>b-V#w4BL;8`*iD6^WP&bWkV?E-oPt1$-71s;Ad!PC zI*Glej9P;%i_PvJ+H^#$MFwJECk(SsW#i&|w3p4ORRF)d2sNmUf{C8dfng>uG< zRw^qKOj!}*;fWwqnI&$lS0pT=7*&av32_G=OmnABF2WK!#29a;V4Svd!^UfFwVsBz zu9>H!x2H>m;$*{inp;M@an4*sb2B--WUS!|WoxH7wRP88U=Yn)PK^MvAaWU8g(^d- zq_o7NL?R=j*<^gBLIUl z3hP~QMioK?MHdAjMb+%UcoRtkNwE`66%py4L%+@cv&Y|_9)GFd!|};HZ1mp~CNQ2h z7OpLA69N)p5rC=dAd}yH{C;{>L>vJuu(V1nEMb{(3W@Q74Cn=rNUEemEK$>lA&Lr_ zjYX&iSOrHZK5hArPSnEXZNn($@WnJ(4XX@GXjMs31G08T6w@`3H9i+c5VyAEnGr}B zn3!8WETV(i08cAqk78K?Rv?7y*D#n`EDJ3LdlWG2=h)!eBF#RdI=SE9-RKFTm7`MI zcL0T`IV>wE%7~St7~s?fm?MG_NIEc`3k;Tr3d&sARt69~Dl4}HLvF;ug9hT3gsPCC z8la#Q&ZH>`FRJ?c*&@h2h+ANInR&*tu~~EN>p+lDaiXFXZH1a*cHZO)!9(^^^n!;C zIeAQ6p;PC1cqbe*F86GZg2*M5B$3j-oFW_j$xTkB$u5GHcyBQ5lB5KOtO7B};)S{v>Z4`=0>uwu;ynMK+v)5O z_U*s}01e}g@C*PqkHYM$E4^0E?0dBQ#ZVXI#w_1oAAi5(H};LH!V)!|eV;bXKINOE zsb~YJkJ0N{$HB?uM6-{l-_*52P%?fWczOk(u%~E+cFl(;E37NJ)79s9${V0QEDC@*-2*S@r*E7)^k;5Iz z*mNNqx6MUG(L^gvP*Ea2R<(`vIXN7>P9tRX6D?;gI`iV$$H6a1+muM}d^3|#|532b*X zH8&l_ElF0}NXIRJk;L|rBA{dT$Gbq8#B-b%!+R4;WH7sdHxz8;&@6F(cThm7&s!F| z2d|MEU6g^7Mz$DZK<)it(n$&kf;V%8;fYzD)K*Yn?Xs~|{L;3aY=15)8G;GA^F>`Y z9INNC2k1d0QZlU$G2a<-RmL)6$hecEDzlBtQ>~D?54=2y%U4@@TuP-lFO{W}4 zag$vp^e%E;op0B@bf~!2(JKAC@?~1_*234W${IsmaYE}pHn#Rw;|oawDmj_D_K+lo zT|oeZOH(UUFr8IYQ)faZQpiOPcu;5^?DWM6P$DBRfF__mibABcB5F;0n7Y=jn=ZB} zI?-{r(AXbI+0{qYiAgr!QJIVmL@IjQsVc2K?=}}EJ$xb7YlWsDbE_Tc9Rlg};oFYh z$IOKkjdPBJEqF&hUgsys>)~l)RY`MMv}5O1p$kbiBQ)wL4b?^Np&8_i(?+SNYJ{Lp dGG<(JAM`e0W46-KEjma1UC9*TLP6mQt>A?V<}UyM literal 2668 zcmV-y3X}ChT4*^jL0KkKS@jKrqyQOGf5iX)Xaz!l|KNXb-@w2B|L{Nn06+)<;0xau zIhHpM2T-bwC<+u8&%O!*fGUR#Oh6_>K{9B_LSUzmrqq6s(PMKX|);v z8&CkzkYvyR000CigVZ!=(droh13)wZpa1|GXaEFCB-F^lG$Yi}pvj4#27mwzO$JRe z10~5<5i^Pzh+;5M3oN37mciHgIbWw^6+ctOr$P_-c8P4LlB#BOazut z3PTBRVs|ahrENvZh@gy!@$qlyU*i8>HbYi^3XOGe5ACl!TjG}zv-mn zDO6u|yw2hx2vr&F--rak_bry!aOCewK-@g3p+wbEW|JvRamZ{#%*lHO(y3x*7lyP` zt)8bsqFtL|)!faTGsNVq2t>jlf;{fek1234$?oKRpw9uhDid9}ceS~)WXf!2IOML# zE_~)s2N6<%6NYsb+dEh5@Y{7a#QH%za~l#g%{pUv!CUy7-}pW#uwMePX0?-O-Mow8 z2m-^DlP_y$uCL<9YHKtrulX_;U~U#@(6V8koD)`8IflRplY?4hTgMG#yN{g00IPrhSdQ;TGoOn zA^VCT<;6e?HKhx`g+Oz6H%wYetEB)#SE+*MZ*QBGhuxnLLA+wkNzDeS?*Fmk3W zC!;iAmjYBGh`fNW1x?&*GTeH?~&N?m3xs4hq-Nc9($Xg*X8zN!> zg3Ot>5sqeOSC|zzg)+6%ol@(*w7`LiA_f=$sDQ{)$de>FD<@ZO6;wnxdY+EM)i~*? znC0GX;f`G8HN&T_JE&ycT8hyt*1G8L%gcJ^wUlXfB$6;-K(=Kotv&nX*qpp|T*;g5 z%?6_HFvd$^a@#8_N@yA8O>SD_$zHa`u1jX}xZ-F`QEL&#!sb@0)|7HdB*_$lr^{fI z+tTIlM7V7D2UCF)L82$x(sgc#J8gYc#-Ty6D0bwxqEXiWAD1m|H(SQ9{&Z%FR*Y>axDYKtGFVnol@TjM z5O8V>8eq!LC=7y6Q5}kz)&@GzEs0Cz_#V+fH(-En)o?IjI9V)(D#{WdkO}0VStKv4 z{ax-zvJZw9*(!ON)pV(Cm1WPVtwB-7sv%a=u{6iatUTx#!4Umay@;XHSC34^%L<M3NMs;9{&~eIJ9**E#Fla#1PK+Loo2p;oA_FiQAmo?2_3 z?tAyl_c`9$iqoScH8hE#n5#1$KVh$)G&R$vESwzg>}+29;=^m88%Xf&Igfmom_+73 z-wm$Qq}0Ff_K2Xo7VCV)RKB+vL7pL=%g)bSKKi*-J?;`yA(FlIGOgpx?kE>0+gyb~ zPO0)*j3wi2Z6-j)t_Yb4aVuTL+Qs@3da)%6+z>bOn8Z#@6f&~zf8LJu&%3M7cK zGGK5EQ36_Ihlh!Sz0O!{mcQD?0|*q-S7v5|wE`upS?!)#8vPmd6x2Ep*oqEh)!a%j zOo}SS3kS?W>gY{Ra#wGuo&T$bB4Ay-^)Fdn7iIIl3(SEQ*dk?z0rnWsa+}D*ot7Vt z9XE*VQ6+n~1g)9}sQ3%saQE!nX{ zlN#lMtl?}^e)seRuO^Nf$H<%%!(Qz2udGz&iuLaKI++k15)qi!~6`t0&BlcHGgLougHQ`#2U;CU(O5Lhl;QxMf;O=kHm4=n)?66o(X8Ra3*?5>!CdWD zAG6?eUM*NF{<*+r)6$Nt7k^LG8JA+xiwxzP~~K!3rSHV)pos)N3c$!f|rJC a>6~Hqfr`ru1hCmZ;_gVN3KAZnuyla;tob(p diff --git a/SESSION.md b/SESSION.md index 3e97a260..2f9f27b9 100644 --- a/SESSION.md +++ b/SESSION.md @@ -33,7 +33,6 @@ |bit64 |4.6.0-1 |2025-01-16 |CRAN (R 4.5.0) | |bitops |1.0-9 |2024-10-03 |CRAN (R 4.5.0) | |boot |1.3-32 |2025-08-29 |CRAN (R 4.5.2) | -|brio |1.1.5 |2024-04-24 |CRAN (R 4.5.0) | |broom |1.0.12 |2026-01-27 |CRAN (R 4.5.2) | |broom.helpers |1.22.0 |2025-09-17 |CRAN (R 4.5.0) | |bsicons |0.1.2 |2023-11-04 |CRAN (R 4.5.0) | @@ -67,7 +66,7 @@ |e1071 |1.7-17 |2025-12-18 |CRAN (R 4.5.2) | |easystats |0.7.5 |2025-07-11 |CRAN (R 4.5.0) | |ellipsis |0.3.2 |2021-04-29 |CRAN (R 4.5.0) | -|emmeans |2.0.1 |2025-12-16 |CRAN (R 4.5.2) | +|emmeans |2.0.2 |2026-03-05 |CRAN (R 4.5.2) | |esquisse |2.1.0 |2025-02-21 |CRAN (R 4.5.0) | |estimability |1.5.1 |2024-05-12 |CRAN (R 4.5.0) | |eulerr |7.0.4 |2025-09-24 |CRAN (R 4.5.0) | @@ -75,7 +74,6 @@ |farver |2.1.2 |2024-05-13 |CRAN (R 4.5.0) | |fastmap |1.2.0 |2024-05-15 |CRAN (R 4.5.0) | |flextable |0.9.11 |2026-02-13 |CRAN (R 4.5.2) | -|fontawesome |0.5.3 |2024-11-16 |CRAN (R 4.5.0) | |fontBitstreamVera |0.1.1 |2017-02-01 |CRAN (R 4.5.0) | |fontLiberation |0.1.0 |2016-10-15 |CRAN (R 4.5.0) | |fontquiver |0.2.1 |2017-02-01 |CRAN (R 4.5.0) | @@ -84,15 +82,15 @@ |foreign |0.8-90 |2025-03-31 |CRAN (R 4.5.2) | |Formula |1.2-5 |2023-02-24 |CRAN (R 4.5.0) | |FreesearchR |26.3.3 |NA |NA | -|fs |1.6.6 |2025-04-12 |CRAN (R 4.5.0) | +|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) | -|ggalluvial |0.12.5 |2023-02-22 |CRAN (R 4.5.0) | +|ggalluvial |0.12.6 |2026-02-22 |CRAN (R 4.5.2) | |ggcorrplot |0.1.4.1 |2023-09-05 |CRAN (R 4.5.0) | |ggforce |0.5.0 |2025-06-18 |CRAN (R 4.5.0) | |ggplot2 |4.0.2 |2026-02-03 |CRAN (R 4.5.2) | |ggridges |0.5.7 |2025-08-27 |CRAN (R 4.5.0) | -|ggstats |0.12.0 |2025-12-22 |CRAN (R 4.5.2) | +|ggstats |0.13.0 |2026-03-06 |CRAN (R 4.5.2) | |glue |1.8.0 |2024-09-30 |CRAN (R 4.5.0) | |gridExtra |2.3 |2017-09-09 |CRAN (R 4.5.0) | |gt |1.3.0 |2026-01-22 |CRAN (R 4.5.2) | @@ -114,10 +112,10 @@ |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.2) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | -|later |1.4.6 |2026-02-13 |CRAN (R 4.5.2) | +|later |1.4.6 |2026-03-05 |CRAN (R 4.5.2) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) | |lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) | -|lme4 |1.1-38 |2025-12-02 |CRAN (R 4.5.2) | +|lme4 |2.0-1 |2026-03-05 |CRAN (R 4.5.2) | |lubridate |1.9.5 |2026-02-04 |CRAN (R 4.5.2) | |magrittr |2.0.4 |2025-09-12 |CRAN (R 4.5.0) | |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | @@ -125,15 +123,15 @@ |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | -|mvtnorm |1.3-3 |2025-01-10 |CRAN (R 4.5.0) | +|mvtnorm |1.3-5 |2026-03-11 |CRAN (R 4.5.2) | |NHANES |2.1.0 |2015-07-02 |CRAN (R 4.5.0) | |nlme |3.1-168 |2025-03-31 |CRAN (R 4.5.2) | |nloptr |2.2.1 |2025-03-17 |CRAN (R 4.5.0) | |nnet |7.3-20 |2025-01-01 |CRAN (R 4.5.2) | |officer |0.7.3 |2026-01-16 |CRAN (R 4.5.2) | |opdisDownsampling |1.0.1 |2024-04-15 |CRAN (R 4.5.0) | -|openssl |2.3.4 |2025-09-30 |CRAN (R 4.5.0) | -|openxlsx2 |1.23.1 |2026-01-19 |CRAN (R 4.5.2) | +|openssl |2.3.5 |2026-02-26 |CRAN (R 4.5.2) | +|openxlsx2 |1.25 |2026-03-07 |CRAN (R 4.5.2) | |otel |0.2.0 |2025-08-29 |CRAN (R 4.5.0) | |parameters |0.28.3 |2025-11-25 |CRAN (R 4.5.2) | |patchwork |1.3.2 |2025-08-25 |CRAN (R 4.5.0) | @@ -156,7 +154,7 @@ |qqplotr |0.0.7 |2025-09-05 |CRAN (R 4.5.0) | |quarto |1.5.1 |2025-09-04 |CRAN (R 4.5.0) | |R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) | -|ragg |1.5.0 |2025-09-02 |CRAN (R 4.5.0) | +|ragg |1.5.1 |2026-03-06 |CRAN (R 4.5.2) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) | |rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) | @@ -172,7 +170,7 @@ |reformulas |0.4.4 |2026-02-02 |CRAN (R 4.5.2) | |remotes |2.5.0 |2024-03-17 |CRAN (R 4.5.0) | |rempsyc |0.2.0 |2025-09-15 |CRAN (R 4.5.0) | -|renv |1.1.7 |2026-01-27 |CRAN (R 4.5.2) | +|renv |1.1.7 |2026-03-05 |CRAN (R 4.5.2) | |reshape2 |1.4.5 |2025-11-12 |CRAN (R 4.5.0) | |rio |1.2.4 |2025-09-26 |CRAN (R 4.5.0) | |rlang |1.1.7 |2026-01-09 |CRAN (R 4.5.2) | @@ -193,14 +191,13 @@ |shinybusy |0.3.3 |2024-03-09 |CRAN (R 4.5.0) | |shinyjs |2.1.1 |2026-01-15 |CRAN (R 4.5.2) | |shinyTime |1.0.3 |2022-08-19 |CRAN (R 4.5.0) | -|shinyWidgets |0.9.0 |2025-02-21 |CRAN (R 4.5.0) | +|shinyWidgets |0.9.1 |2026-03-09 |CRAN (R 4.5.2) | |smd |0.8.0 |2025-02-12 |CRAN (R 4.5.0) | |stringi |1.8.7 |2025-03-27 |CRAN (R 4.5.0) | |stringr |1.6.0 |2025-11-04 |CRAN (R 4.5.0) | |stRoke |25.9.2 |2025-09-30 |CRAN (R 4.5.0) | -|systemfonts |1.3.1 |2025-10-01 |CRAN (R 4.5.0) | -|testthat |3.3.2 |2026-01-11 |CRAN (R 4.5.2) | -|textshaping |1.0.4 |2025-10-10 |CRAN (R 4.5.0) | +|systemfonts |1.3.2 |2026-03-05 |CRAN (R 4.5.2) | +|textshaping |1.0.5 |2026-03-06 |CRAN (R 4.5.2) | |thematic |0.1.8 |2025-09-29 |CRAN (R 4.5.0) | |tibble |3.3.1 |2026-01-11 |CRAN (R 4.5.2) | |tidyr |1.3.2 |2025-12-19 |CRAN (R 4.5.2) | @@ -220,6 +217,6 @@ |writexl |1.5.4 |2025-04-15 |CRAN (R 4.5.0) | |xfun |0.56 |2026-01-18 |CRAN (R 4.5.2) | |xml2 |1.5.2 |2026-01-17 |CRAN (R 4.5.2) | -|xtable |1.8-4 |2019-04-21 |CRAN (R 4.5.0) | +|xtable |1.8-4 |2026-02-22 |CRAN (R 4.5.2) | |yaml |2.3.12 |2025-12-10 |CRAN (R 4.5.2) | |zip |2.3.3 |2025-05-13 |CRAN (R 4.5.0) | diff --git a/app_docker/app.R b/app_docker/app.R index 72d8290a..004466c5 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmprp4Sq1/fileb602d982aa3.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a146f4d002a.R ######## i18n_path <- here::here("translations") @@ -2957,7 +2957,7 @@ add_sparkline <- function(grid, column = "vals", color.main = "#2a8484", color.s type <- "line" ds <- data.frame(x = NA, y = NA) horizontal <- FALSE - } else if (identical(data_cl, "factor")) { + } else if ("factor" %in% data_cl) { type <- "column" s <- summary(data) ds <- data.frame(x = names(s), y = s) @@ -3887,20 +3887,23 @@ file_export <- function(data, #' head(5) |> #' str() default_parsing <- function(data) { - name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) + # name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) # browser() - out <- data |> - setNames(make.names(names(data), unique = TRUE)) |> - ## Temporary step to avoid nested list and crashing - remove_nested_list() |> - REDCapCAST::parse_data() |> - REDCapCAST::as_factor() |> - REDCapCAST::numchar2fct(numeric.threshold = 8, - character.throshold = 10) |> - REDCapCAST::as_logical() |> - REDCapCAST::fct_drop() - - set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) + with_labels(data,{ + data |> + setNames(make.names(names(data), unique = TRUE)) |> + ## Temporary step to avoid nested list and crashing + remove_nested_list() |> + REDCapCAST::parse_data() |> + REDCapCAST::as_factor() |> + REDCapCAST::numchar2fct(numeric.threshold = 8, + character.throshold = 10) |> + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() + }) + # out <- + # + # set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) # purrr::map2( # out, diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index de5e9f11..ad0da02a 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//Rtmprp4Sq1/fileb60491b0ce8.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a14715fd082.R ######## i18n_path <- system.file("translations", package = "FreesearchR") @@ -2957,7 +2957,7 @@ add_sparkline <- function(grid, column = "vals", color.main = "#2a8484", color.s type <- "line" ds <- data.frame(x = NA, y = NA) horizontal <- FALSE - } else if (identical(data_cl, "factor")) { + } else if ("factor" %in% data_cl) { type <- "column" s <- summary(data) ds <- data.frame(x = names(s), y = s) @@ -3887,20 +3887,23 @@ file_export <- function(data, #' head(5) |> #' str() default_parsing <- function(data) { - name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) + # name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) # browser() - out <- data |> - setNames(make.names(names(data), unique = TRUE)) |> - ## Temporary step to avoid nested list and crashing - remove_nested_list() |> - REDCapCAST::parse_data() |> - REDCapCAST::as_factor() |> - REDCapCAST::numchar2fct(numeric.threshold = 8, - character.throshold = 10) |> - REDCapCAST::as_logical() |> - REDCapCAST::fct_drop() - - set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) + with_labels(data,{ + data |> + setNames(make.names(names(data), unique = TRUE)) |> + ## Temporary step to avoid nested list and crashing + remove_nested_list() |> + REDCapCAST::parse_data() |> + REDCapCAST::as_factor() |> + REDCapCAST::numchar2fct(numeric.threshold = 8, + character.throshold = 10) |> + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() + }) + # out <- + # + # set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) # purrr::map2( # out, diff --git a/renv.lock b/renv.lock index dfbaf8cd..11ae7b52 100644 --- a/renv.lock +++ b/renv.lock @@ -2761,7 +2761,7 @@ }, "effectsize": { "Package": "effectsize", - "Version": "1.0.1", + "Version": "1.0.2", "Source": "Repository", "Type": "Package", "Title": "Indices of Effect Size", @@ -2775,11 +2775,11 @@ "R (>= 4.0)" ], "Imports": [ - "bayestestR (>= 0.16.0)", - "insight (>= 1.3.0)", - "parameters (>= 0.26.0)", - "performance (>= 0.14.0)", - "datawizard (>= 1.1.0)", + "bayestestR (>= 0.17.0)", + "insight (>= 1.4.5)", + "parameters (>= 0.28.3)", + "performance (>= 0.15.3)", + "datawizard (>= 1.3.0)", "stats", "utils" ], @@ -2809,7 +2809,7 @@ "VignetteBuilder": "knitr", "Encoding": "UTF-8", "Language": "en-US", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.3.3", "Config/testthat/edition": "3", "Config/testthat/parallel": "true", "Config/Needs/website": "rstudio/bslib, r-lib/pkgdown, easystats/easystatstemplate", @@ -2819,11 +2819,11 @@ }, "emmeans": { "Package": "emmeans", - "Version": "2.0.1", + "Version": "2.0.2", "Source": "Repository", "Type": "Package", "Title": "Estimated Marginal Means, aka Least-Squares Means", - "Date": "2025-12-10", + "Date": "2026-02-20", "Authors@R": "c(person(\"Russell V.\", \"Lenth\", role = c(\"aut\", \"cph\"), email = \"russell-lenth@uiowa.edu\"), person(\"Julia\", \"Piaskowski\", role = c(\"cre\", \"aut\"), email = \"julia.piask@gmail.com\"), person(\"Balazs\", \"Banfai\", role = \"ctb\"), person(\"Ben\", \"Bolker\", role = \"ctb\"), person(\"Paul\", \"Buerkner\", role = \"ctb\"), person(\"Iago\", \"Giné-Vázquez\", role = \"ctb\"), person(\"Maxime\", \"Hervé\", role = \"ctb\"), person(\"Maarten\", \"Jung\", role = \"ctb\"), person(\"Jonathon\", \"Love\", role = \"ctb\"), person(\"Fernando\", \"Miguez\", role = \"ctb\"), person(\"Hannes\", \"Riebl\", role = \"ctb\"), person(\"Henrik\", \"Singmann\", role = \"ctb\"))", "Maintainer": "Julia Piaskowski ", "Depends": [ @@ -2886,7 +2886,7 @@ "sommer", "survival" ], - "URL": "https://rvlenth.github.io/emmeans/,https://rvlenth.github.io/emmeans/", + "URL": "https://rvlenth.github.io/emmeans/, https://github.com/rvlenth/emmeans/", "BugReports": "https://github.com/rvlenth/emmeans/issues", "LazyData": "yes", "ByteCompile": "yes", @@ -3435,16 +3435,16 @@ }, "fs": { "Package": "fs", - "Version": "1.6.6", + "Version": "1.6.7", "Source": "Repository", "Title": "Cross-Platform File System Operations Based on 'libuv'", - "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Hadley\", \"Wickham\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", , \"jeroenooms@gmail.com\", role = \"cre\"), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\"), comment = c(ROR = \"03wc8by49\")) )", "Description": "A cross-platform interface to file system operations, built on top of the 'libuv' C library.", "License": "MIT + file LICENSE", "URL": "https://fs.r-lib.org, https://github.com/r-lib/fs", "BugReports": "https://github.com/r-lib/fs/issues", "Depends": [ - "R (>= 3.6)" + "R (>= 4.1)" ], "Imports": [ "methods" @@ -3465,14 +3465,15 @@ "ByteCompile": "true", "Config/Needs/website": "tidyverse/tidytemplate", "Config/testthat/edition": "3", + "Config/usethis/last-upkeep": "2025-04-23", "Copyright": "file COPYRIGHTS", "Encoding": "UTF-8", "Language": "en-US", - "RoxygenNote": "7.2.3", + "RoxygenNote": "7.3.3", "SystemRequirements": "GNU make", "NeedsCompilation": "yes", - "Author": "Jim Hester [aut], Hadley Wickham [aut], Gábor Csárdi [aut, cre], libuv project contributors [cph] (libuv library), Joyent, Inc. and other Node contributors [cph] (libuv library), Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", + "Author": "Jim Hester [aut], Hadley Wickham [aut], Gábor Csárdi [aut], Jeroen Ooms [cre], libuv project contributors [cph] (libuv library), Joyent, Inc. and other Node contributors [cph] (libuv library), Posit Software, PBC [cph, fnd] (ROR: )", + "Maintainer": "Jeroen Ooms ", "Repository": "CRAN" }, "gap": { @@ -3642,7 +3643,7 @@ }, "ggalluvial": { "Package": "ggalluvial", - "Version": "0.12.5", + "Version": "0.12.6", "Source": "Repository", "Type": "Package", "Title": "Alluvial Plots in 'ggplot2'", @@ -3889,7 +3890,7 @@ }, "ggstats": { "Package": "ggstats", - "Version": "0.12.0", + "Version": "0.13.0", "Source": "Repository", "Type": "Package", "Title": "Extension to 'ggplot2' for Plotting Stats", @@ -4288,7 +4289,7 @@ }, "highr": { "Package": "highr", - "Version": "0.11", + "Version": "0.12", "Source": "Repository", "Type": "Package", "Title": "Syntax Highlighting for R Source Code", @@ -4310,9 +4311,9 @@ "BugReports": "https://github.com/yihui/highr/issues", "VignetteBuilder": "knitr", "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", + "RoxygenNote": "7.3.3", "NeedsCompilation": "no", - "Author": "Yihui Xie [aut, cre] (), Yixuan Qiu [aut], Christopher Gandrud [ctb], Qiang Li [ctb]", + "Author": "Yihui Xie [aut, cre] (ORCID: ), Yixuan Qiu [aut], Christopher Gandrud [ctb], Qiang Li [ctb]", "Maintainer": "Yihui Xie ", "Repository": "CRAN" }, @@ -5041,7 +5042,7 @@ }, "later": { "Package": "later", - "Version": "1.4.6", + "Version": "1.4.8", "Source": "Repository", "Type": "Package", "Title": "Utilities for Scheduling Functions to Execute Later with Event Loops", @@ -5217,72 +5218,74 @@ }, "lme4": { "Package": "lme4", - "Version": "1.1-38", + "Version": "2.0-1", "Source": "Repository", "Title": "Linear Mixed-Effects Models using 'Eigen' and S4", - "Authors@R": "c( person(\"Douglas\",\"Bates\", role=\"aut\", comment=c(ORCID=\"0000-0001-8316-9503\")), person(\"Martin\",\"Maechler\", role=\"aut\", comment=c(ORCID=\"0000-0002-8685-9910\")), person(\"Ben\",\"Bolker\",email=\"bbolker+lme4@gmail.com\", role=c(\"aut\",\"cre\"), comment=c(ORCID=\"0000-0002-2127-0443\")), person(\"Steven\",\"Walker\",role=\"aut\", comment=c(ORCID=\"0000-0002-4394-9078\")), person(\"Rune Haubo Bojesen\",\"Christensen\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4494-3399\")), person(\"Henrik\",\"Singmann\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4842-3657\")), person(\"Bin\", \"Dai\", role=\"ctb\"), person(\"Fabian\", \"Scheipl\", role=\"ctb\", comment=c(ORCID=\"0000-0001-8172-3603\")), person(\"Gabor\", \"Grothendieck\", role=\"ctb\"), person(\"Peter\", \"Green\", role=\"ctb\", comment=c(ORCID=\"0000-0002-0238-9852\")), person(\"John\", \"Fox\", role=\"ctb\"), person(\"Alexander\", \"Bauer\", role=\"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role=c(\"ctb\",\"cph\"), comment=c(ORCID=\"0000-0002-9101-3362\", \"shared copyright on simulate.formula\")), person(\"Emi\", \"Tanaka\", role = \"ctb\", comment = c(ORCID=\"0000-0002-1455-259X\")), person(\"Mikael\", \"Jagan\", role = \"ctb\", comment = c(ORCID=\"0000-0002-3542-2938\")), person(\"Ross D.\", \"Boylan\", email=\"ross.boylan@ucsf.edu\", role=(\"ctb\"), comment = c(ORCID=\"0009-0003-4123-8090\")), person(\"Anna\", \"Ly\", role = \"ctb\", comment = c(ORCID = \"0000-0002-0210-0342\")) )", - "Description": "Fit linear and generalized linear mixed-effects models. The models and their components are represented using S4 classes and methods. The core computational algorithms are implemented using the 'Eigen' C++ library for numerical linear algebra and 'RcppEigen' \"glue\".", + "Authors@R": "c(person(\"Douglas\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"Martin\", \"Maechler\", role = \"aut\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Ben\", \"Bolker\", role = c(\"cre\", \"aut\"), email = \"bbolker+lme4@gmail.com\", comment = c(ORCID = \"0000-0002-2127-0443\")), person(\"Steven\", \"Walker\", role = \"aut\", comment = c(ORCID = \"0000-0002-4394-9078\")), person(\"Rune Haubo Bojesen\", \"Christensen\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4494-3399\")), person(\"Henrik\", \"Singmann\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4842-3657\")), person(\"Bin\", \"Dai\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\", comment = c(ORCID = \"0000-0001-8172-3603\")), person(\"Gabor\", \"Grothendieck\", role = \"ctb\"), person(\"Peter\", \"Green\", role = \"ctb\", comment = c(ORCID = \"0000-0002-0238-9852\")), person(\"John\", \"Fox\", role = \"ctb\"), person(\"Alexander\", \"Bauer\", role = \"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role = c(\"ctb\", \"cph\"), comment = c(ORCID = \"0000-0002-9101-3362\", \"shared copyright on simulate.formula\")), person(\"Emi\", \"Tanaka\", role = \"ctb\", comment = c(ORCID = \"0000-0002-1455-259X\")), person(\"Mikael\", \"Jagan\", role = \"aut\", comment = c(ORCID = \"0000-0002-3542-2938\")), person(\"Ross D.\", \"Boylan\", role = \"ctb\", comment = c(ORCID = \"0009-0003-4123-8090\")), person(\"Anna\", \"Ly\", role = \"aut\", comment = c(ORCID = \"0000-0002-0210-0342\")))", + "Description": "Fit linear and generalized linear mixed-effects models. The models and their components are represented using S4 classes and methods. The core computational algorithms are implemented using the 'Eigen' C++ library for numerical linear algebra and 'RcppEigen' \"glue\".", "Depends": [ - "R (>= 3.6.0)", + "R (>= 3.6)", "Matrix", "methods", "stats" ], "LinkingTo": [ + "Matrix (>= 1.5-0)", "Rcpp (>= 0.10.5)", - "RcppEigen (>= 0.3.3.9.4)", - "Matrix (>= 1.5-0)" + "RcppEigen (>= 0.3.3.9.4)" ], "Imports": [ + "MASS", + "Rdpack", + "boot", "graphics", "grid", - "splines", - "utils", - "parallel", - "MASS", "lattice", - "boot", - "nlme (>= 3.1-123)", "minqa (>= 1.1.15)", + "nlme (>= 3.1-123)", "nloptr (>= 1.0.4)", - "reformulas (>= 0.3.0)", + "parallel", + "reformulas (>= 0.4.3.1)", "rlang", - "Rdpack" + "splines", + "utils" ], - "RdMacros": "Rdpack", "Suggests": [ - "knitr", - "rmarkdown", - "MEMSS", - "testthat (>= 0.8.1)", - "ggplot2", - "mlmRev", - "optimx (>= 2013.8.6)", - "gamm4", - "pbkrtest", "HSAUR3", - "numDeriv", + "MEMSS", "car", "dfoptim", + "gamm4", + "ggplot2", + "glmmTMB", + "knitr", + "merDeriv", "mgcv", - "statmod", + "mlmRev", + "numDeriv", + "optimx (>= 2013.8.6)", + "pbkrtest", + "rmarkdown", "rr2", "semEff", - "tibble", - "merDeriv" + "statmod", + "testthat (>= 0.8.1)", + "tibble" ], "Enhances": [ "DHARMa", "performance" ], + "RdMacros": "Rdpack", "VignetteBuilder": "knitr", "LazyData": "yes", "License": "GPL (>= 2)", "URL": "https://github.com/lme4/lme4/", "BugReports": "https://github.com/lme4/lme4/issues", "Encoding": "UTF-8", + "RoxygenNote": "7.3.3", "NeedsCompilation": "yes", - "Author": "Douglas Bates [aut] (ORCID: ), Martin Maechler [aut] (ORCID: ), Ben Bolker [aut, cre] (ORCID: ), Steven Walker [aut] (ORCID: ), Rune Haubo Bojesen Christensen [ctb] (ORCID: ), Henrik Singmann [ctb] (ORCID: ), Bin Dai [ctb], Fabian Scheipl [ctb] (ORCID: ), Gabor Grothendieck [ctb], Peter Green [ctb] (ORCID: ), John Fox [ctb], Alexander Bauer [ctb], Pavel N. Krivitsky [ctb, cph] (ORCID: , shared copyright on simulate.formula), Emi Tanaka [ctb] (ORCID: ), Mikael Jagan [ctb] (ORCID: ), Ross D. Boylan [ctb] (ORCID: ), Anna Ly [ctb] (ORCID: )", + "Author": "Douglas Bates [aut] (ORCID: ), Martin Maechler [aut] (ORCID: ), Ben Bolker [cre, aut] (ORCID: ), Steven Walker [aut] (ORCID: ), Rune Haubo Bojesen Christensen [ctb] (ORCID: ), Henrik Singmann [ctb] (ORCID: ), Bin Dai [ctb], Fabian Scheipl [ctb] (ORCID: ), Gabor Grothendieck [ctb], Peter Green [ctb] (ORCID: ), John Fox [ctb], Alexander Bauer [ctb], Pavel N. Krivitsky [ctb, cph] (ORCID: , shared copyright on simulate.formula), Emi Tanaka [ctb] (ORCID: ), Mikael Jagan [aut] (ORCID: ), Ross D. Boylan [ctb] (ORCID: ), Anna Ly [aut] (ORCID: )", "Maintainer": "Ben Bolker ", "Repository": "CRAN" }, @@ -5672,10 +5675,10 @@ }, "mvtnorm": { "Package": "mvtnorm", - "Version": "1.3-3", + "Version": "1.3-5", "Source": "Repository", "Title": "Multivariate Normal and t Distributions", - "Date": "2025-01-09", + "Date": "2026-03-10", "Authors@R": "c(person(\"Alan\", \"Genz\", role = \"aut\"), person(\"Frank\", \"Bretz\", role = \"aut\"), person(\"Tetsuhisa\", \"Miwa\", role = \"aut\"), person(\"Xuefei\", \"Mi\", role = \"aut\"), person(\"Friedrich\", \"Leisch\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\"), person(\"Bjoern\", \"Bornkamp\", role = \"ctb\", comment = c(ORCID = \"0000-0002-6294-8185\")), person(\"Martin\", \"Maechler\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Torsten\", \"Hothorn\", role = c(\"aut\", \"cre\"), email = \"Torsten.Hothorn@R-project.org\", comment = c(ORCID = \"0000-0001-8301-0471\")))", "Description": "Computes multivariate normal and t probabilities, quantiles, random deviates, and densities. Log-likelihoods for multivariate Gaussian models and Gaussian copulae parameterised by Cholesky factors of covariance or precision matrices are implemented for interval-censored and exact data, or a mix thereof. Score functions for these log-likelihoods are available. A class representing multiple lower triangular matrices and corresponding methods are part of this package.", "Imports": [ @@ -5686,12 +5689,13 @@ ], "Suggests": [ "qrng", - "numDeriv" + "numDeriv", + "bibtex" ], "License": "GPL-2", "URL": "http://mvtnorm.R-forge.R-project.org", "NeedsCompilation": "yes", - "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (), Martin Maechler [ctb] (), Torsten Hothorn [aut, cre] ()", + "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (ORCID: ), Martin Maechler [ctb] (ORCID: ), Torsten Hothorn [aut, cre] (ORCID: )", "Maintainer": "Torsten Hothorn ", "Repository": "CRAN" }, @@ -5882,7 +5886,7 @@ }, "openssl": { "Package": "openssl", - "Version": "2.3.4", + "Version": "2.3.5", "Source": "Repository", "Type": "Package", "Title": "Toolkit for Encryption, Signatures and Certificates Based on OpenSSL", @@ -5915,7 +5919,7 @@ }, "openxlsx2": { "Package": "openxlsx2", - "Version": "1.23.1", + "Version": "1.25", "Source": "Repository", "Type": "Package", "Title": "Read, Write and Edit 'xlsx' Files", @@ -5942,10 +5946,10 @@ "ggplot2", "knitr", "mschart (>= 0.4)", + "openssl", "rmarkdown", "rvg", "testthat (>= 3.0.0)", - "waldo", "zip" ], "VignetteBuilder": "knitr", @@ -7089,7 +7093,7 @@ }, "ragg": { "Package": "ragg", - "Version": "1.5.0", + "Version": "1.5.1", "Source": "Repository", "Type": "Package", "Title": "Graphic Devices Based on AGG", @@ -7118,7 +7122,7 @@ "Config/testthat/edition": "3", "Config/usethis/last-upkeep": "2025-04-25", "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.3.3", "SystemRequirements": "freetype2, libpng, libtiff, libjpeg, libwebp, libwebpmux", "NeedsCompilation": "yes", "Author": "Thomas Lin Pedersen [cre, aut] (ORCID: ), Maxim Shemanarev [aut, cph] (Author of AGG), Tony Juricic [ctb, cph] (Contributor to AGG), Milan Marusinec [ctb, cph] (Contributor to AGG), Spencer Garrett [ctb] (Contributor to AGG), Posit Software, PBC [cph, fnd] (ROR: )", @@ -7541,7 +7545,7 @@ }, "renv": { "Package": "renv", - "Version": "1.1.7", + "Version": "1.1.8", "Source": "Repository", "Type": "Package", "Title": "Project Environments", @@ -7585,11 +7589,11 @@ "Encoding": "UTF-8", "RoxygenNote": "7.3.3", "VignetteBuilder": "knitr", + "NeedsCompilation": "yes", "Config/Needs/website": "tidyverse/tidytemplate", "Config/testthat/edition": "3", "Config/testthat/parallel": "true", "Config/testthat/start-first": "bioconductor,python,install,restore,snapshot,retrieve,remotes", - "NeedsCompilation": "no", "Author": "Kevin Ushey [aut, cre] (ORCID: ), Hadley Wickham [aut] (ORCID: ), Posit Software, PBC [cph, fnd]", "Maintainer": "Kevin Ushey ", "Repository": "CRAN" @@ -8317,7 +8321,7 @@ }, "shinyWidgets": { "Package": "shinyWidgets", - "Version": "0.9.0", + "Version": "0.9.1", "Source": "Repository", "Title": "Custom Inputs Widgets for Shiny", "Authors@R": "c( person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\", \"cph\")), person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"David\", \"Granjon\", role = \"aut\"), person(\"Ian\", \"Fellows\", role = \"ctb\", comment = \"Methods for mutating vertical tabs & updateMultiInput\"), person(\"Wil\", \"Davis\", role = \"ctb\", comment = \"numericRangeInput function\"), person(\"Spencer\", \"Matthews\", role = \"ctb\", comment = \"autoNumeric methods\"), person(family = \"JavaScript and CSS libraries authors\", role = c(\"ctb\", \"cph\"), comment = \"All authors are listed in LICENSE.md\") )", @@ -8327,7 +8331,7 @@ "License": "GPL-3", "Encoding": "UTF-8", "LazyData": "true", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.3.3", "Depends": [ "R (>= 3.1.0)" ], @@ -8624,7 +8628,7 @@ }, "systemfonts": { "Package": "systemfonts", - "Version": "1.3.1", + "Version": "1.3.2", "Source": "Repository", "Type": "Package", "Title": "System Native Font Finding", @@ -8672,7 +8676,7 @@ }, "textshaping": { "Package": "textshaping", - "Version": "1.0.4", + "Version": "1.0.5", "Source": "Repository", "Title": "Bindings to the 'HarfBuzz' and 'Fribidi' Libraries for Text Shaping", "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\"), comment = c(ROR = \"03wc8by49\")) )", @@ -9513,21 +9517,23 @@ }, "xtable": { "Package": "xtable", - "Version": "1.8-4", + "Version": "1.8-8", "Source": "Repository", - "Date": "2019-04-08", + "Date": "2026-02-20", "Title": "Export Tables to LaTeX or HTML", "Authors@R": "c(person(\"David B.\", \"Dahl\", role=\"aut\"), person(\"David\", \"Scott\", role=c(\"aut\",\"cre\"), email=\"d.scott@auckland.ac.nz\"), person(\"Charles\", \"Roosen\", role=\"aut\"), person(\"Arni\", \"Magnusson\", role=\"aut\"), person(\"Jonathan\", \"Swinton\", role=\"aut\"), person(\"Ajay\", \"Shah\", role=\"ctb\"), person(\"Arne\", \"Henningsen\", role=\"ctb\"), person(\"Benno\", \"Puetz\", role=\"ctb\"), person(\"Bernhard\", \"Pfaff\", role=\"ctb\"), person(\"Claudio\", \"Agostinelli\", role=\"ctb\"), person(\"Claudius\", \"Loehnert\", role=\"ctb\"), person(\"David\", \"Mitchell\", role=\"ctb\"), person(\"David\", \"Whiting\", role=\"ctb\"), person(\"Fernando da\", \"Rosa\", role=\"ctb\"), person(\"Guido\", \"Gay\", role=\"ctb\"), person(\"Guido\", \"Schulz\", role=\"ctb\"), person(\"Ian\", \"Fellows\", role=\"ctb\"), person(\"Jeff\", \"Laake\", role=\"ctb\"), person(\"John\", \"Walker\", role=\"ctb\"), person(\"Jun\", \"Yan\", role=\"ctb\"), person(\"Liviu\", \"Andronic\", role=\"ctb\"), person(\"Markus\", \"Loecher\", role=\"ctb\"), person(\"Martin\", \"Gubri\", role=\"ctb\"), person(\"Matthieu\", \"Stigler\", role=\"ctb\"), person(\"Robert\", \"Castelo\", role=\"ctb\"), person(\"Seth\", \"Falcon\", role=\"ctb\"), person(\"Stefan\", \"Edwards\", role=\"ctb\"), person(\"Sven\", \"Garbade\", role=\"ctb\"), person(\"Uwe\", \"Ligges\", role=\"ctb\"))", "Maintainer": "David Scott ", "Imports": [ "stats", - "utils" + "utils", + "methods" ], "Suggests": [ "knitr", - "plm", "zoo", - "survival" + "survival", + "glue", + "tinytex" ], "VignetteBuilder": "knitr", "Description": "Coerce data to LaTeX and HTML tables.", diff --git a/renv/activate.R b/renv/activate.R index ef25ef83..6e94798d 100644 --- a/renv/activate.R +++ b/renv/activate.R @@ -2,8 +2,8 @@ local({ # the requested version of renv - version <- "1.1.7" - attr(version, "md5") <- "dd5d60f155dadff4c88c2fc6680504b4" + version <- "1.1.8" + attr(version, "md5") <- "cbffd086c66739a0fdaac7a30b4aa65c" attr(version, "sha") <- NULL # the project directory From f0f1e6965ad853f8b3e0260e30388b0817682f7b Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 12:43:30 +0100 Subject: [PATCH 14/62] fix: specified no limit --- README.md | 2 +- app_docker/app.R | 2 +- inst/apps/FreesearchR/app.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 8f7ccef3..e40c0c41 100644 --- a/README.md +++ b/README.md @@ -42,7 +42,7 @@ The app can be configured either by passing a named list to `run_app()` or by se |-------------------------|-----------------------------------------------------------------------------|-----------| | `INCLUDE_GLOBALENV` | Load datasets already present in the global R environment into the app | `FALSE` | | `DATA_LIMIT_DEFAULT` | Default number of observations for previewing or working with a dataset | `10,000` | -| `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit | `100,000` | +| `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit. If set to 0, no uppper limit is applied. | `100,000` | | `DATA_LIMIT_LOWER` | Minimum number of observations a user can set for the lower limit | `1` | ### Run from R (or RStudio) diff --git a/app_docker/app.R b/app_docker/app.R index 004466c5..7cb858bb 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a146f4d002a.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a144d9f4424.R ######## i18n_path <- here::here("translations") diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index ad0da02a..2ee84131 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//RtmpmhqokQ/file1a14715fd082.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a147dcf977e.R ######## i18n_path <- system.file("translations", package = "FreesearchR") From afae978c26ab89cfb24ff450d4775ed25ffba892 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 12:44:14 +0100 Subject: [PATCH 15/62] news --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 570ab7e2..b05d8909 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ *FIX* faster data description function. +Also added a few tests to the package. + # FreesearchR 26.3.2 *FIX* Updating factor levels always created new factor. From 9e2ee1e40290a27d6e53e82dea8ddc74404cdd53 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 12:46:31 +0100 Subject: [PATCH 16/62] added docs --- README.md | 2 +- app_docker/Dockerfile | 2 +- app_docker/app.R | 2 +- app_docker/renv.lock | 148 ++++++++++++++++++++++-------------------- 4 files changed, 80 insertions(+), 74 deletions(-) diff --git a/README.md b/README.md index e40c0c41..344b8649 100644 --- a/README.md +++ b/README.md @@ -62,7 +62,7 @@ If you're working with data in R, **FreesearchR** is a quick and easy tool for e launch_FreesearchR(INCLUDE_GLOBALENV=TRUE) ``` -All the variables specified above can also be passed to the app on launch from R. +All the variables specified above can also be passed to the app on launch from R. Set DATA_LIMIT_UPPER=0 to remove upper data limit. This limit is set to protect the online app version from choking and crashing on large data sets. ### Running with Docker Compose diff --git a/app_docker/Dockerfile b/app_docker/Dockerfile index 15d3a400..029da51f 100644 --- a/app_docker/Dockerfile +++ b/app_docker/Dockerfile @@ -3,7 +3,7 @@ RUN apt-get update -y && apt-get install -y cmake make libcurl4-openssl-dev lib RUN mkdir -p /usr/local/lib/R/etc/ /usr/lib/R/etc/ RUN echo "options(renv.config.pak.enabled = FALSE, repos = c(CRAN = 'https://cran.rstudio.com/'), download.file.method = 'libcurl', Ncpus = 4)" | tee /usr/local/lib/R/etc/Rprofile.site | tee /usr/lib/R/etc/Rprofile.site RUN R -e 'install.packages("remotes")' -RUN R -e 'remotes::install_version("renv", version = "1.1.7")' +RUN R -e 'remotes::install_version("renv", version = "1.1.8")' COPY renv.lock renv.lock RUN --mount=type=cache,id=renv-cache,target=/root/.cache/R/renv R -e 'renv::restore()' WORKDIR /srv/shiny-server/ diff --git a/app_docker/app.R b/app_docker/app.R index 7cb858bb..f50e462a 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a144d9f4424.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a1412a8be28.R ######## i18n_path <- here::here("translations") diff --git a/app_docker/renv.lock b/app_docker/renv.lock index dfbaf8cd..11ae7b52 100644 --- a/app_docker/renv.lock +++ b/app_docker/renv.lock @@ -2761,7 +2761,7 @@ }, "effectsize": { "Package": "effectsize", - "Version": "1.0.1", + "Version": "1.0.2", "Source": "Repository", "Type": "Package", "Title": "Indices of Effect Size", @@ -2775,11 +2775,11 @@ "R (>= 4.0)" ], "Imports": [ - "bayestestR (>= 0.16.0)", - "insight (>= 1.3.0)", - "parameters (>= 0.26.0)", - "performance (>= 0.14.0)", - "datawizard (>= 1.1.0)", + "bayestestR (>= 0.17.0)", + "insight (>= 1.4.5)", + "parameters (>= 0.28.3)", + "performance (>= 0.15.3)", + "datawizard (>= 1.3.0)", "stats", "utils" ], @@ -2809,7 +2809,7 @@ "VignetteBuilder": "knitr", "Encoding": "UTF-8", "Language": "en-US", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.3.3", "Config/testthat/edition": "3", "Config/testthat/parallel": "true", "Config/Needs/website": "rstudio/bslib, r-lib/pkgdown, easystats/easystatstemplate", @@ -2819,11 +2819,11 @@ }, "emmeans": { "Package": "emmeans", - "Version": "2.0.1", + "Version": "2.0.2", "Source": "Repository", "Type": "Package", "Title": "Estimated Marginal Means, aka Least-Squares Means", - "Date": "2025-12-10", + "Date": "2026-02-20", "Authors@R": "c(person(\"Russell V.\", \"Lenth\", role = c(\"aut\", \"cph\"), email = \"russell-lenth@uiowa.edu\"), person(\"Julia\", \"Piaskowski\", role = c(\"cre\", \"aut\"), email = \"julia.piask@gmail.com\"), person(\"Balazs\", \"Banfai\", role = \"ctb\"), person(\"Ben\", \"Bolker\", role = \"ctb\"), person(\"Paul\", \"Buerkner\", role = \"ctb\"), person(\"Iago\", \"Giné-Vázquez\", role = \"ctb\"), person(\"Maxime\", \"Hervé\", role = \"ctb\"), person(\"Maarten\", \"Jung\", role = \"ctb\"), person(\"Jonathon\", \"Love\", role = \"ctb\"), person(\"Fernando\", \"Miguez\", role = \"ctb\"), person(\"Hannes\", \"Riebl\", role = \"ctb\"), person(\"Henrik\", \"Singmann\", role = \"ctb\"))", "Maintainer": "Julia Piaskowski ", "Depends": [ @@ -2886,7 +2886,7 @@ "sommer", "survival" ], - "URL": "https://rvlenth.github.io/emmeans/,https://rvlenth.github.io/emmeans/", + "URL": "https://rvlenth.github.io/emmeans/, https://github.com/rvlenth/emmeans/", "BugReports": "https://github.com/rvlenth/emmeans/issues", "LazyData": "yes", "ByteCompile": "yes", @@ -3435,16 +3435,16 @@ }, "fs": { "Package": "fs", - "Version": "1.6.6", + "Version": "1.6.7", "Source": "Repository", "Title": "Cross-Platform File System Operations Based on 'libuv'", - "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Hadley\", \"Wickham\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", , \"jeroenooms@gmail.com\", role = \"cre\"), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\"), comment = c(ROR = \"03wc8by49\")) )", "Description": "A cross-platform interface to file system operations, built on top of the 'libuv' C library.", "License": "MIT + file LICENSE", "URL": "https://fs.r-lib.org, https://github.com/r-lib/fs", "BugReports": "https://github.com/r-lib/fs/issues", "Depends": [ - "R (>= 3.6)" + "R (>= 4.1)" ], "Imports": [ "methods" @@ -3465,14 +3465,15 @@ "ByteCompile": "true", "Config/Needs/website": "tidyverse/tidytemplate", "Config/testthat/edition": "3", + "Config/usethis/last-upkeep": "2025-04-23", "Copyright": "file COPYRIGHTS", "Encoding": "UTF-8", "Language": "en-US", - "RoxygenNote": "7.2.3", + "RoxygenNote": "7.3.3", "SystemRequirements": "GNU make", "NeedsCompilation": "yes", - "Author": "Jim Hester [aut], Hadley Wickham [aut], Gábor Csárdi [aut, cre], libuv project contributors [cph] (libuv library), Joyent, Inc. and other Node contributors [cph] (libuv library), Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", + "Author": "Jim Hester [aut], Hadley Wickham [aut], Gábor Csárdi [aut], Jeroen Ooms [cre], libuv project contributors [cph] (libuv library), Joyent, Inc. and other Node contributors [cph] (libuv library), Posit Software, PBC [cph, fnd] (ROR: )", + "Maintainer": "Jeroen Ooms ", "Repository": "CRAN" }, "gap": { @@ -3642,7 +3643,7 @@ }, "ggalluvial": { "Package": "ggalluvial", - "Version": "0.12.5", + "Version": "0.12.6", "Source": "Repository", "Type": "Package", "Title": "Alluvial Plots in 'ggplot2'", @@ -3889,7 +3890,7 @@ }, "ggstats": { "Package": "ggstats", - "Version": "0.12.0", + "Version": "0.13.0", "Source": "Repository", "Type": "Package", "Title": "Extension to 'ggplot2' for Plotting Stats", @@ -4288,7 +4289,7 @@ }, "highr": { "Package": "highr", - "Version": "0.11", + "Version": "0.12", "Source": "Repository", "Type": "Package", "Title": "Syntax Highlighting for R Source Code", @@ -4310,9 +4311,9 @@ "BugReports": "https://github.com/yihui/highr/issues", "VignetteBuilder": "knitr", "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", + "RoxygenNote": "7.3.3", "NeedsCompilation": "no", - "Author": "Yihui Xie [aut, cre] (), Yixuan Qiu [aut], Christopher Gandrud [ctb], Qiang Li [ctb]", + "Author": "Yihui Xie [aut, cre] (ORCID: ), Yixuan Qiu [aut], Christopher Gandrud [ctb], Qiang Li [ctb]", "Maintainer": "Yihui Xie ", "Repository": "CRAN" }, @@ -5041,7 +5042,7 @@ }, "later": { "Package": "later", - "Version": "1.4.6", + "Version": "1.4.8", "Source": "Repository", "Type": "Package", "Title": "Utilities for Scheduling Functions to Execute Later with Event Loops", @@ -5217,72 +5218,74 @@ }, "lme4": { "Package": "lme4", - "Version": "1.1-38", + "Version": "2.0-1", "Source": "Repository", "Title": "Linear Mixed-Effects Models using 'Eigen' and S4", - "Authors@R": "c( person(\"Douglas\",\"Bates\", role=\"aut\", comment=c(ORCID=\"0000-0001-8316-9503\")), person(\"Martin\",\"Maechler\", role=\"aut\", comment=c(ORCID=\"0000-0002-8685-9910\")), person(\"Ben\",\"Bolker\",email=\"bbolker+lme4@gmail.com\", role=c(\"aut\",\"cre\"), comment=c(ORCID=\"0000-0002-2127-0443\")), person(\"Steven\",\"Walker\",role=\"aut\", comment=c(ORCID=\"0000-0002-4394-9078\")), person(\"Rune Haubo Bojesen\",\"Christensen\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4494-3399\")), person(\"Henrik\",\"Singmann\", role=\"ctb\", comment=c(ORCID=\"0000-0002-4842-3657\")), person(\"Bin\", \"Dai\", role=\"ctb\"), person(\"Fabian\", \"Scheipl\", role=\"ctb\", comment=c(ORCID=\"0000-0001-8172-3603\")), person(\"Gabor\", \"Grothendieck\", role=\"ctb\"), person(\"Peter\", \"Green\", role=\"ctb\", comment=c(ORCID=\"0000-0002-0238-9852\")), person(\"John\", \"Fox\", role=\"ctb\"), person(\"Alexander\", \"Bauer\", role=\"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role=c(\"ctb\",\"cph\"), comment=c(ORCID=\"0000-0002-9101-3362\", \"shared copyright on simulate.formula\")), person(\"Emi\", \"Tanaka\", role = \"ctb\", comment = c(ORCID=\"0000-0002-1455-259X\")), person(\"Mikael\", \"Jagan\", role = \"ctb\", comment = c(ORCID=\"0000-0002-3542-2938\")), person(\"Ross D.\", \"Boylan\", email=\"ross.boylan@ucsf.edu\", role=(\"ctb\"), comment = c(ORCID=\"0009-0003-4123-8090\")), person(\"Anna\", \"Ly\", role = \"ctb\", comment = c(ORCID = \"0000-0002-0210-0342\")) )", - "Description": "Fit linear and generalized linear mixed-effects models. The models and their components are represented using S4 classes and methods. The core computational algorithms are implemented using the 'Eigen' C++ library for numerical linear algebra and 'RcppEigen' \"glue\".", + "Authors@R": "c(person(\"Douglas\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"Martin\", \"Maechler\", role = \"aut\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Ben\", \"Bolker\", role = c(\"cre\", \"aut\"), email = \"bbolker+lme4@gmail.com\", comment = c(ORCID = \"0000-0002-2127-0443\")), person(\"Steven\", \"Walker\", role = \"aut\", comment = c(ORCID = \"0000-0002-4394-9078\")), person(\"Rune Haubo Bojesen\", \"Christensen\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4494-3399\")), person(\"Henrik\", \"Singmann\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4842-3657\")), person(\"Bin\", \"Dai\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\", comment = c(ORCID = \"0000-0001-8172-3603\")), person(\"Gabor\", \"Grothendieck\", role = \"ctb\"), person(\"Peter\", \"Green\", role = \"ctb\", comment = c(ORCID = \"0000-0002-0238-9852\")), person(\"John\", \"Fox\", role = \"ctb\"), person(\"Alexander\", \"Bauer\", role = \"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role = c(\"ctb\", \"cph\"), comment = c(ORCID = \"0000-0002-9101-3362\", \"shared copyright on simulate.formula\")), person(\"Emi\", \"Tanaka\", role = \"ctb\", comment = c(ORCID = \"0000-0002-1455-259X\")), person(\"Mikael\", \"Jagan\", role = \"aut\", comment = c(ORCID = \"0000-0002-3542-2938\")), person(\"Ross D.\", \"Boylan\", role = \"ctb\", comment = c(ORCID = \"0009-0003-4123-8090\")), person(\"Anna\", \"Ly\", role = \"aut\", comment = c(ORCID = \"0000-0002-0210-0342\")))", + "Description": "Fit linear and generalized linear mixed-effects models. The models and their components are represented using S4 classes and methods. The core computational algorithms are implemented using the 'Eigen' C++ library for numerical linear algebra and 'RcppEigen' \"glue\".", "Depends": [ - "R (>= 3.6.0)", + "R (>= 3.6)", "Matrix", "methods", "stats" ], "LinkingTo": [ + "Matrix (>= 1.5-0)", "Rcpp (>= 0.10.5)", - "RcppEigen (>= 0.3.3.9.4)", - "Matrix (>= 1.5-0)" + "RcppEigen (>= 0.3.3.9.4)" ], "Imports": [ + "MASS", + "Rdpack", + "boot", "graphics", "grid", - "splines", - "utils", - "parallel", - "MASS", "lattice", - "boot", - "nlme (>= 3.1-123)", "minqa (>= 1.1.15)", + "nlme (>= 3.1-123)", "nloptr (>= 1.0.4)", - "reformulas (>= 0.3.0)", + "parallel", + "reformulas (>= 0.4.3.1)", "rlang", - "Rdpack" + "splines", + "utils" ], - "RdMacros": "Rdpack", "Suggests": [ - "knitr", - "rmarkdown", - "MEMSS", - "testthat (>= 0.8.1)", - "ggplot2", - "mlmRev", - "optimx (>= 2013.8.6)", - "gamm4", - "pbkrtest", "HSAUR3", - "numDeriv", + "MEMSS", "car", "dfoptim", + "gamm4", + "ggplot2", + "glmmTMB", + "knitr", + "merDeriv", "mgcv", - "statmod", + "mlmRev", + "numDeriv", + "optimx (>= 2013.8.6)", + "pbkrtest", + "rmarkdown", "rr2", "semEff", - "tibble", - "merDeriv" + "statmod", + "testthat (>= 0.8.1)", + "tibble" ], "Enhances": [ "DHARMa", "performance" ], + "RdMacros": "Rdpack", "VignetteBuilder": "knitr", "LazyData": "yes", "License": "GPL (>= 2)", "URL": "https://github.com/lme4/lme4/", "BugReports": "https://github.com/lme4/lme4/issues", "Encoding": "UTF-8", + "RoxygenNote": "7.3.3", "NeedsCompilation": "yes", - "Author": "Douglas Bates [aut] (ORCID: ), Martin Maechler [aut] (ORCID: ), Ben Bolker [aut, cre] (ORCID: ), Steven Walker [aut] (ORCID: ), Rune Haubo Bojesen Christensen [ctb] (ORCID: ), Henrik Singmann [ctb] (ORCID: ), Bin Dai [ctb], Fabian Scheipl [ctb] (ORCID: ), Gabor Grothendieck [ctb], Peter Green [ctb] (ORCID: ), John Fox [ctb], Alexander Bauer [ctb], Pavel N. Krivitsky [ctb, cph] (ORCID: , shared copyright on simulate.formula), Emi Tanaka [ctb] (ORCID: ), Mikael Jagan [ctb] (ORCID: ), Ross D. Boylan [ctb] (ORCID: ), Anna Ly [ctb] (ORCID: )", + "Author": "Douglas Bates [aut] (ORCID: ), Martin Maechler [aut] (ORCID: ), Ben Bolker [cre, aut] (ORCID: ), Steven Walker [aut] (ORCID: ), Rune Haubo Bojesen Christensen [ctb] (ORCID: ), Henrik Singmann [ctb] (ORCID: ), Bin Dai [ctb], Fabian Scheipl [ctb] (ORCID: ), Gabor Grothendieck [ctb], Peter Green [ctb] (ORCID: ), John Fox [ctb], Alexander Bauer [ctb], Pavel N. Krivitsky [ctb, cph] (ORCID: , shared copyright on simulate.formula), Emi Tanaka [ctb] (ORCID: ), Mikael Jagan [aut] (ORCID: ), Ross D. Boylan [ctb] (ORCID: ), Anna Ly [aut] (ORCID: )", "Maintainer": "Ben Bolker ", "Repository": "CRAN" }, @@ -5672,10 +5675,10 @@ }, "mvtnorm": { "Package": "mvtnorm", - "Version": "1.3-3", + "Version": "1.3-5", "Source": "Repository", "Title": "Multivariate Normal and t Distributions", - "Date": "2025-01-09", + "Date": "2026-03-10", "Authors@R": "c(person(\"Alan\", \"Genz\", role = \"aut\"), person(\"Frank\", \"Bretz\", role = \"aut\"), person(\"Tetsuhisa\", \"Miwa\", role = \"aut\"), person(\"Xuefei\", \"Mi\", role = \"aut\"), person(\"Friedrich\", \"Leisch\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\"), person(\"Bjoern\", \"Bornkamp\", role = \"ctb\", comment = c(ORCID = \"0000-0002-6294-8185\")), person(\"Martin\", \"Maechler\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Torsten\", \"Hothorn\", role = c(\"aut\", \"cre\"), email = \"Torsten.Hothorn@R-project.org\", comment = c(ORCID = \"0000-0001-8301-0471\")))", "Description": "Computes multivariate normal and t probabilities, quantiles, random deviates, and densities. Log-likelihoods for multivariate Gaussian models and Gaussian copulae parameterised by Cholesky factors of covariance or precision matrices are implemented for interval-censored and exact data, or a mix thereof. Score functions for these log-likelihoods are available. A class representing multiple lower triangular matrices and corresponding methods are part of this package.", "Imports": [ @@ -5686,12 +5689,13 @@ ], "Suggests": [ "qrng", - "numDeriv" + "numDeriv", + "bibtex" ], "License": "GPL-2", "URL": "http://mvtnorm.R-forge.R-project.org", "NeedsCompilation": "yes", - "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (), Martin Maechler [ctb] (), Torsten Hothorn [aut, cre] ()", + "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (ORCID: ), Martin Maechler [ctb] (ORCID: ), Torsten Hothorn [aut, cre] (ORCID: )", "Maintainer": "Torsten Hothorn ", "Repository": "CRAN" }, @@ -5882,7 +5886,7 @@ }, "openssl": { "Package": "openssl", - "Version": "2.3.4", + "Version": "2.3.5", "Source": "Repository", "Type": "Package", "Title": "Toolkit for Encryption, Signatures and Certificates Based on OpenSSL", @@ -5915,7 +5919,7 @@ }, "openxlsx2": { "Package": "openxlsx2", - "Version": "1.23.1", + "Version": "1.25", "Source": "Repository", "Type": "Package", "Title": "Read, Write and Edit 'xlsx' Files", @@ -5942,10 +5946,10 @@ "ggplot2", "knitr", "mschart (>= 0.4)", + "openssl", "rmarkdown", "rvg", "testthat (>= 3.0.0)", - "waldo", "zip" ], "VignetteBuilder": "knitr", @@ -7089,7 +7093,7 @@ }, "ragg": { "Package": "ragg", - "Version": "1.5.0", + "Version": "1.5.1", "Source": "Repository", "Type": "Package", "Title": "Graphic Devices Based on AGG", @@ -7118,7 +7122,7 @@ "Config/testthat/edition": "3", "Config/usethis/last-upkeep": "2025-04-25", "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.3.3", "SystemRequirements": "freetype2, libpng, libtiff, libjpeg, libwebp, libwebpmux", "NeedsCompilation": "yes", "Author": "Thomas Lin Pedersen [cre, aut] (ORCID: ), Maxim Shemanarev [aut, cph] (Author of AGG), Tony Juricic [ctb, cph] (Contributor to AGG), Milan Marusinec [ctb, cph] (Contributor to AGG), Spencer Garrett [ctb] (Contributor to AGG), Posit Software, PBC [cph, fnd] (ROR: )", @@ -7541,7 +7545,7 @@ }, "renv": { "Package": "renv", - "Version": "1.1.7", + "Version": "1.1.8", "Source": "Repository", "Type": "Package", "Title": "Project Environments", @@ -7585,11 +7589,11 @@ "Encoding": "UTF-8", "RoxygenNote": "7.3.3", "VignetteBuilder": "knitr", + "NeedsCompilation": "yes", "Config/Needs/website": "tidyverse/tidytemplate", "Config/testthat/edition": "3", "Config/testthat/parallel": "true", "Config/testthat/start-first": "bioconductor,python,install,restore,snapshot,retrieve,remotes", - "NeedsCompilation": "no", "Author": "Kevin Ushey [aut, cre] (ORCID: ), Hadley Wickham [aut] (ORCID: ), Posit Software, PBC [cph, fnd]", "Maintainer": "Kevin Ushey ", "Repository": "CRAN" @@ -8317,7 +8321,7 @@ }, "shinyWidgets": { "Package": "shinyWidgets", - "Version": "0.9.0", + "Version": "0.9.1", "Source": "Repository", "Title": "Custom Inputs Widgets for Shiny", "Authors@R": "c( person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\", \"cph\")), person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"David\", \"Granjon\", role = \"aut\"), person(\"Ian\", \"Fellows\", role = \"ctb\", comment = \"Methods for mutating vertical tabs & updateMultiInput\"), person(\"Wil\", \"Davis\", role = \"ctb\", comment = \"numericRangeInput function\"), person(\"Spencer\", \"Matthews\", role = \"ctb\", comment = \"autoNumeric methods\"), person(family = \"JavaScript and CSS libraries authors\", role = c(\"ctb\", \"cph\"), comment = \"All authors are listed in LICENSE.md\") )", @@ -8327,7 +8331,7 @@ "License": "GPL-3", "Encoding": "UTF-8", "LazyData": "true", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.3.3", "Depends": [ "R (>= 3.1.0)" ], @@ -8624,7 +8628,7 @@ }, "systemfonts": { "Package": "systemfonts", - "Version": "1.3.1", + "Version": "1.3.2", "Source": "Repository", "Type": "Package", "Title": "System Native Font Finding", @@ -8672,7 +8676,7 @@ }, "textshaping": { "Package": "textshaping", - "Version": "1.0.4", + "Version": "1.0.5", "Source": "Repository", "Title": "Bindings to the 'HarfBuzz' and 'Fribidi' Libraries for Text Shaping", "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\"), comment = c(ROR = \"03wc8by49\")) )", @@ -9513,21 +9517,23 @@ }, "xtable": { "Package": "xtable", - "Version": "1.8-4", + "Version": "1.8-8", "Source": "Repository", - "Date": "2019-04-08", + "Date": "2026-02-20", "Title": "Export Tables to LaTeX or HTML", "Authors@R": "c(person(\"David B.\", \"Dahl\", role=\"aut\"), person(\"David\", \"Scott\", role=c(\"aut\",\"cre\"), email=\"d.scott@auckland.ac.nz\"), person(\"Charles\", \"Roosen\", role=\"aut\"), person(\"Arni\", \"Magnusson\", role=\"aut\"), person(\"Jonathan\", \"Swinton\", role=\"aut\"), person(\"Ajay\", \"Shah\", role=\"ctb\"), person(\"Arne\", \"Henningsen\", role=\"ctb\"), person(\"Benno\", \"Puetz\", role=\"ctb\"), person(\"Bernhard\", \"Pfaff\", role=\"ctb\"), person(\"Claudio\", \"Agostinelli\", role=\"ctb\"), person(\"Claudius\", \"Loehnert\", role=\"ctb\"), person(\"David\", \"Mitchell\", role=\"ctb\"), person(\"David\", \"Whiting\", role=\"ctb\"), person(\"Fernando da\", \"Rosa\", role=\"ctb\"), person(\"Guido\", \"Gay\", role=\"ctb\"), person(\"Guido\", \"Schulz\", role=\"ctb\"), person(\"Ian\", \"Fellows\", role=\"ctb\"), person(\"Jeff\", \"Laake\", role=\"ctb\"), person(\"John\", \"Walker\", role=\"ctb\"), person(\"Jun\", \"Yan\", role=\"ctb\"), person(\"Liviu\", \"Andronic\", role=\"ctb\"), person(\"Markus\", \"Loecher\", role=\"ctb\"), person(\"Martin\", \"Gubri\", role=\"ctb\"), person(\"Matthieu\", \"Stigler\", role=\"ctb\"), person(\"Robert\", \"Castelo\", role=\"ctb\"), person(\"Seth\", \"Falcon\", role=\"ctb\"), person(\"Stefan\", \"Edwards\", role=\"ctb\"), person(\"Sven\", \"Garbade\", role=\"ctb\"), person(\"Uwe\", \"Ligges\", role=\"ctb\"))", "Maintainer": "David Scott ", "Imports": [ "stats", - "utils" + "utils", + "methods" ], "Suggests": [ "knitr", - "plm", "zoo", - "survival" + "survival", + "glue", + "tinytex" ], "VignetteBuilder": "knitr", "Description": "Coerce data to LaTeX and HTML tables.", From 7394a6753feb6309e88e95ad7f361749c4019883 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 13:49:57 +0100 Subject: [PATCH 17/62] rerender all --- CITATION.cff | 2 +- DESCRIPTION | 2 +- NEWS.md | 4 ++++ R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/sysdata.rda | Bin 2671 -> 2645 bytes SESSION.md | 28 ++++++++++++++-------------- app_docker/app.R | 6 +++--- app_docker/renv.lock | 12 ++++++------ renv.lock | 12 ++++++------ 10 files changed, 37 insertions(+), 33 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 3baa4bf4..f7e2ec6a 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.3 +version: 26.3.4 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index e47380cb..3e2cc6ab 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.3.3 +Version: 26.3.4 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 b05d8909..f08ae0b2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.3.4 + + + # FreesearchR 26.3.3 *NEW* option to pass global settings when running as docker or launching from R. Support for INCLUDE_GLOBALENV, DATA_LIMIT_DEFAULT, DATA_LIMIT_UPPER and DATA_LIMIT_LOWER. Described in the README. diff --git a/R/app_version.R b/R/app_version.R index dccdf7c4..c6d7307c 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.3' +app_version <- function()'26.3.4' diff --git a/R/hosted_version.R b/R/hosted_version.R index b15a5737..f0c656d1 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.3-260312' +hosted_version <- function()'v26.3.4-260312' diff --git a/R/sysdata.rda b/R/sysdata.rda index 7ab55e91eff8121f1805d27dc695bbd323b19233..f8b0df59c674b9d09f2de1dbfadcfb9a132325b6 100644 GIT binary patch delta 2644 zcmV-a3aj<+6x9?CLRx4!F+o`-Q(5#dim8zf9)A`h79InFQjG#Y7vB00pa1|b4NO1? z01-BXC#HzgNc5-aO&*9CLq>+wV@60dPtzcjQ%xpA)DO`^dV~N2AOH;pfHVe#Qz@tF zgFpZPG!IY>0Av~f0000a(nKXw^lD^-dZtYPJ*opikPS2dJwN~kgh{B=)HG-Tqd)^d z0Dlb{84UmpG#UURN+3l2O;1F?fN7?U02%-QF#(Xs440*jGGr*rLm71eZM1-;_yVS` zl_HD9_r6#n4VDnf@$YNom=MAkcy{=>Ok!qsAd=Xv$KCEZrljCVgMr|JRAGD z_iz8PaCa~MU+&yT<42ah!}+Zauj4``Rez7Q)cd`*P9n)g_f!hPuz?hodnkZR9|IfY zUtTE|nFiusDisEsVroiixyW*2b16s@F^<~_L-?~m(A#;haS^2jyJ71uh~|9`#u z^@NdNz2#cXYbM&={pIh30b#;vpUB!Z)%%$I%s8`* zn$4wc-xgbZoGRMTvSFV;717qH-NgyvzemOA;QAE#u=?!^rVo#taKLjnPcG6zilYR} zh#<&$nV1l|vc%0DNu`>$a+SHwRe!W3NjSx2ldWB*by=*{9I2dTv)Dpjuv5v&socxV z-1U;tsMJik)k&ujsA-zZo0_@hh86B0mj3wkn)KYxHgc>8;X zJwR2|fFZ4|b?(O2jttLcbQA{>kB&4#LP;P(ND)K@6pF@+tF{27--r-wgNi@SxCiywL z+9yp>bE|aZ5(H)?Qh+29Hf4uVIdeuXgDi}k!3O7^C1{|`Oa$SUY^tB9xPO9;gjQulfwtRh zWe^U+aUeyQ+UU}9TU(sGOyjq%t`~`u4ccjK8tun9aS_bS=JArVgejG-oaWWnZE1l6 zHElX*I<(mhNeH4bR7S3@9GZ!V(y@Tt3UC5~PPdDWT;l7F4qh{L44b;Q5n44e^S*gC z*`~S9t4pAgM2rXw%zrDbcI{3$DG^1%NK>r20qjjeB%)1`G|^EW80!xkkApp54Ds}Q z&ki3UDK@3n-ywqBWrxQvIkea0R@5OsccjaxvDCY3RG=EqPs|-tMRb;4vC3w!QKkraW6iI&gPg%lp>0(#AoJ;`JRSb`I`Y{Fq^uq?D0?a;%!pKpU~ zi!}T;c5}nS&F}=#YeuDOcLD{dIV>wE%7~St7~s?fm?ZMRVnNV^=~!g6Gi;^73b?ul ztVMSsh;CSyFn?g*DQHTm3K6ObR7|Qulv?&5tG$vaN4X1V9-}Wf)>bPneNAW*3Jx?> zLam`@n4VkaK&)7P%3h$ehMc^nBb1)ct-(0kLhpAJNfd@s3eSnvo>Yf?AQ745v(wt0 zndD4L#qRFeX)0FPRgI7egsdc4227A4I@KnV>18qa>3_;+F2$=xtt@0Dr3V8QV0w{%x|{Rx*YXueVWXVYe%?x}>?2VK zOI{$%=M$&>UeNpEawZjk1|dTlgFAyf zE;_w1{UyFb?{J!#43+oElF)aZr2^ji>70U{Cx6XqFqaK*teFF?yC7eS3bYKr$bEf& zmB^GW^CFunHA91(FCP+fH6nLkj}F$aCLqAL)V zcYpHMWZxm*(=~k|v_SHpaq8!1v43`en-`r?SpwlVjrNYw_RTHCoK;EygG!HwG^zLg zlp`XmwptnzhT&ka@My8lKMg|ZnCDEJ$AgZZkg*?u z@(qF0n2Kk+E&&vheZ~$ z&x+dfYopo8gK!|b@Ko8?X_cJzq4gmwS2`?6DC0Ui8G4ktx^N}x>aFE_SqrEa%726- zTpQEtg+Ze-K-@v~ArVL4PTVUCi!_!y$y73EmroEd!eSw>Dekl0E*sI5U3Y9Y9( zC(uWZyb+qUkBv}f_)M7QJ_ppndsryoZkdw`i0YH!G^OOhyH&IIbJ5jo&tr>b%WG8w zWs^qOdEERRWE3tW6Je>_@PBy%SatP@1WGb>jFvRjRYgm>l9HoAG=xI~!0~sev$jF6JYw}wxUyN0a z>z{WScPjC6h#9j!3mroGdhzeiqt6;hR>av%^%`u(d%He}FQynu;yui&p|rJHx-`|0 zmBhPO2h4Ylj$W4Sbq?E#;QE<3vPUNKt)EQxcn{nUtbxkdv`bBc{x0N-aG@dSVHHx- CFzo{X delta 2670 zcmV-!3X%2I6z>!cLRx4!F+o`-Q(1UIt9X$P9)A})%NvgYK#@T34plHdH1Pu)XKmZ&K z27j3iG-zQ1A)$gaG|8htG7LZfXd+4}>Uu=|O;1qC=zwTw02%<$0}uen44IP088Q@S zp^UZF^RJjz>?Ymp`cyVor|(| zt<6QgAObQYySeny!*l(Mcei)v{_MbhQh)H%)_-Mzl=;aBs)PJ8em>gb@mwC;Y6V$V zK#B=I3Lp~){Kh#J(-ezLgJ_p^LZH)Z%}H%mf*hEe-s(V^hUu`BKJ{WQYY9^BDluA0 zMs!z1crO%|X9Q9ziCD*|FwA+(GW+=dd3cej$jE17JZ#Rsw)a~qn1Q}7Wdk{c(|-!o zPGL00OqlXNujfoF$>-qYc49OnEayiH@VfJ5wC;D&&_Y3eg+!exCD^??OZ0PrU%DvA z(z$7)b5n6RVPg0#TMEm5YO?4sRk2|tqn}2Vx0a)Er3u={i0o+Edunw<($K0-HgBrt z1DU-$T2)j*SSU-fAqB%#RZvkeC4aFy!LyiJw6UmJXRAcAhYn3Jijr+D`AnGmS3;ULYcC2&gedRs@8Gy#N5VS${|%A^U(J z=S2VudGd?@0D$mzw#<5fi>Ux1=JR&%*Z91=`ahe;XDx{`b}Xr=K8*N_;H#z ztOcCfRYXpAb6L&hu5L}SYJav}(6@V)=sO+Lma|$}q1w{A+Jae&tA?*m3URry=*o9V z764S>Mcxuo7b6C64A@PDqGW4W8DSVKFUA;z?B$^ChKC_JwsXVAYi_lkhPSSnr=z#0ONHWO!*-fm zM!Rv&Ttss-IlN@7;R+#G^zaBcs`5P%?rw zLo1hgyM{S)i>?k`^MAUAP1UHa61u$ao=tUWu5+bnbP$mv0E06M>s@h16+#3>7X=|j z)$G7{6G;R~u@g-d5$T>ozs>)%$KReFf2rTY@yR@F^xqREFrGFRt}Sg70uo^nfT`;s zliz*(etK0z904q_v`Q>2VVQ9XiSdC9=mn5Ss-#0KQPYSaihl~3jYX&iSOrHZK5hAr zPSnEXZNn($@WnJ(4XX@GXjMs31G08T6w@`3H9i+c5VyAEnGr}Bn3!8WETV(i08cAq zk78K?Rv?7y*D#n`EDJ3LdlWG2=h)!eBF#RdI=SE9-RKFTm7`MIcL0T`IV>wE%7~St z7~s?fm?MG_NPjvooeK<>hYHGE*j5G*Jt`}=1Ve7b!Gi|kmV~O1p&Fo|6wah62`{Sp z``IGMJ&0Ric$s;|vawln?dw30P;sK76>Wu@Vs_r-3c*A6QuKm{4LNyCT%l9vd3Yxr zG%ojSkb=l1lq8YTzMLW&2!Oz|fk(d;9a-{|60v(bHh)@5m9|x5LIpxr5-fuzND!Sh zNu>KZOn!oL%;ng%Xw{{O2`NFq#aPJq{!Z?AFf~p?Z5*74dagR z3;;Ke!tARny;jcbd$jz;P#5IJEZ<)rf4}56_Km8-5;dKDpEk`t<(s3aXalH^(d${q z!O7%AvyZ3W)U`rTGJYR;dIg}cr)Y(C&4(u|tbZ%I)79s9${V0QEDC@*-2*S@r*E7)^k;5Iz*mNNq?srwQ#wJI``1gm~M^x*EX4xhC2cv0>UJ_>lL2$irCIR%0-S~ z;PgOJ6D;7|w9{&{FGtzYYpfwEYVRJt*nf%;aIh2nsUfcvV$uv<149XHcQiFO9mOq4 zR@+F&Er5~4_L3r?WA?|pK$*mIoEO7;6H8<;yMZ?pY~|1_aesGEK&j7L7P|+pksDo< zfs;nI7-K-~{b15b3J8KXbA{oFS)J5YP+;w{u~q!iww-K$E-D#<3A*z|T{ax6=YO#W z=s_e>GOZ3V-x+dM#xi2axRawQvyIDBt&qABK^-n%lhwse8Arf`9HR*2Sx$vIHBWH| zD=bo44N)GxDn*VVS;vsA z{pS+1BY046#mc%mB%cNzq#ZXi%-lbD8OGHi(WX}w=OJza&LMXxU}R!yfINO6;0 zCiE_HU7c^&y>zI!*3l~cynpg#TJhGx*RIMMLtSw~>pnKN_EzHyNdhW4nY#9nB!*o< z0EA0ZD^xI@Ra8@FLMBqkMGkmSXdUeI#R*U%BQSs_pgxL1q_iSxO?#NS)~%Z^wkSH$ zaktReA4%EON7ac*Hs4X1j1EL9dfTZgtv&BH7bZP?A=Yb!rXX{x9arfc0_pVO+m7DH z%!L$8ct<{7=O@VP;b~%3Npo4WW9L?(3rRL3H0me~)kW^18RU%9MyaT3grH6` cW?XY0^fq8)w$jlpI!F9n$rRy2LE#Fm;L82umjD0& diff --git a/SESSION.md b/SESSION.md index 2f9f27b9..1bd978b0 100644 --- a/SESSION.md +++ b/SESSION.md @@ -15,7 +15,7 @@ |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.3.260312 | +|FreesearchR |26.3.4.260312 | -------------------------------------------------------------------------------- @@ -32,7 +32,7 @@ |bit |4.6.0 |2025-03-06 |CRAN (R 4.5.0) | |bit64 |4.6.0-1 |2025-01-16 |CRAN (R 4.5.0) | |bitops |1.0-9 |2024-10-03 |CRAN (R 4.5.0) | -|boot |1.3-32 |2025-08-29 |CRAN (R 4.5.2) | +|boot |1.3-32 |2025-08-29 |CRAN (R 4.5.0) | |broom |1.0.12 |2026-01-27 |CRAN (R 4.5.2) | |broom.helpers |1.22.0 |2025-09-17 |CRAN (R 4.5.0) | |bsicons |0.1.2 |2023-11-04 |CRAN (R 4.5.0) | @@ -44,11 +44,11 @@ |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | -|class |7.3-23 |2025-01-01 |CRAN (R 4.5.2) | +|class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | |cli |3.6.5 |2025-04-23 |CRAN (R 4.5.0) | |cluster |2.1.8.2 |2026-02-05 |CRAN (R 4.5.2) | -|codetools |0.2-20 |2024-03-31 |CRAN (R 4.5.2) | +|codetools |0.2-20 |2024-03-31 |CRAN (R 4.5.0) | |colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) | @@ -79,9 +79,9 @@ |fontquiver |0.2.1 |2017-02-01 |CRAN (R 4.5.0) | |forcats |1.0.1 |2025-09-25 |CRAN (R 4.5.0) | |foreach |1.5.2 |2022-02-02 |CRAN (R 4.5.0) | -|foreign |0.8-90 |2025-03-31 |CRAN (R 4.5.2) | +|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.3 |NA |NA | +|FreesearchR |26.3.4 |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) | @@ -109,25 +109,25 @@ |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) | -|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.2) | +|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.0) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | -|later |1.4.6 |2026-03-05 |CRAN (R 4.5.2) | +|later |1.4.8 |2026-03-05 |CRAN (R 4.5.2) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) | |lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) | |lme4 |2.0-1 |2026-03-05 |CRAN (R 4.5.2) | |lubridate |1.9.5 |2026-02-04 |CRAN (R 4.5.2) | |magrittr |2.0.4 |2025-09-12 |CRAN (R 4.5.0) | |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | -|Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.2) | +|Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.0) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | |mvtnorm |1.3-5 |2026-03-11 |CRAN (R 4.5.2) | |NHANES |2.1.0 |2015-07-02 |CRAN (R 4.5.0) | -|nlme |3.1-168 |2025-03-31 |CRAN (R 4.5.2) | +|nlme |3.1-168 |2025-03-31 |CRAN (R 4.5.0) | |nloptr |2.2.1 |2025-03-17 |CRAN (R 4.5.0) | -|nnet |7.3-20 |2025-01-01 |CRAN (R 4.5.2) | +|nnet |7.3-20 |2025-01-01 |CRAN (R 4.5.0) | |officer |0.7.3 |2026-01-16 |CRAN (R 4.5.2) | |opdisDownsampling |1.0.1 |2024-04-15 |CRAN (R 4.5.0) | |openssl |2.3.5 |2026-02-26 |CRAN (R 4.5.2) | @@ -170,14 +170,14 @@ |reformulas |0.4.4 |2026-02-02 |CRAN (R 4.5.2) | |remotes |2.5.0 |2024-03-17 |CRAN (R 4.5.0) | |rempsyc |0.2.0 |2025-09-15 |CRAN (R 4.5.0) | -|renv |1.1.7 |2026-03-05 |CRAN (R 4.5.2) | +|renv |1.1.8 |2026-03-05 |CRAN (R 4.5.2) | |reshape2 |1.4.5 |2025-11-12 |CRAN (R 4.5.0) | |rio |1.2.4 |2025-09-26 |CRAN (R 4.5.0) | |rlang |1.1.7 |2026-01-09 |CRAN (R 4.5.2) | |rmarkdown |2.30 |2025-09-28 |CRAN (R 4.5.0) | |robustbase |0.99-7 |2026-02-05 |CRAN (R 4.5.2) | |roxygen2 |7.3.3 |2025-09-03 |CRAN (R 4.5.0) | -|rpart |4.1.24 |2025-01-07 |CRAN (R 4.5.2) | +|rpart |4.1.24 |2025-01-07 |CRAN (R 4.5.0) | |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) | @@ -217,6 +217,6 @@ |writexl |1.5.4 |2025-04-15 |CRAN (R 4.5.0) | |xfun |0.56 |2026-01-18 |CRAN (R 4.5.2) | |xml2 |1.5.2 |2026-01-17 |CRAN (R 4.5.2) | -|xtable |1.8-4 |2026-02-22 |CRAN (R 4.5.2) | +|xtable |1.8-8 |2026-02-22 |CRAN (R 4.5.2) | |yaml |2.3.12 |2025-12-10 |CRAN (R 4.5.2) | |zip |2.3.3 |2025-05-13 |CRAN (R 4.5.0) | diff --git a/app_docker/app.R b/app_docker/app.R index f50e462a..63a9e442 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmhqokQ/file1a1412a8be28.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp6ipYJe/file24f61644daa6.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.3' +app_version <- function()'26.3.4' ######## @@ -4514,7 +4514,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.3-260312' +hosted_version <- function()'v26.3.4-260312' ######## diff --git a/app_docker/renv.lock b/app_docker/renv.lock index 11ae7b52..ca300008 100644 --- a/app_docker/renv.lock +++ b/app_docker/renv.lock @@ -3405,10 +3405,10 @@ }, "foreign": { "Package": "foreign", - "Version": "0.8-90", + "Version": "0.8-91", "Source": "Repository", "Priority": "recommended", - "Date": "2025-03-31", + "Date": "2026-01-29", "Title": "Read Data Stored by 'Minitab', 'S', 'SAS', 'SPSS', 'Stata', 'Systat', 'Weka', 'dBase', ...", "Depends": [ "R (>= 4.0.0)" @@ -3429,7 +3429,7 @@ "MailingList": "R-help@r-project.org", "URL": "https://svn.r-project.org/R-packages/trunk/foreign/", "NeedsCompilation": "yes", - "Author": "R Core Team [aut, cph, cre] (02zz1nj61), Roger Bivand [ctb, cph], Vincent J. Carey [ctb, cph], Saikat DebRoy [ctb, cph], Stephen Eglen [ctb, cph], Rajarshi Guha [ctb, cph], Swetlana Herbrandt [ctb], Nicholas Lewin-Koh [ctb, cph], Mark Myatt [ctb, cph], Michael Nelson [ctb], Ben Pfaff [ctb], Brian Quistorff [ctb], Frank Warmerdam [ctb, cph], Stephen Weigand [ctb, cph], Free Software Foundation, Inc. [cph]", + "Author": "R Core Team [aut, cph, cre] (ROR: ), Roger Bivand [ctb, cph], Vincent J. Carey [ctb, cph], Saikat DebRoy [ctb, cph], Stephen Eglen [ctb, cph], Rajarshi Guha [ctb, cph], Swetlana Herbrandt [ctb], Nicholas Lewin-Koh [ctb, cph], Mark Myatt [ctb, cph], Michael Nelson [ctb], Ben Pfaff [ctb], Brian Quistorff [ctb], Frank Warmerdam [ctb, cph], Stephen Weigand [ctb, cph], Free Software Foundation, Inc. [cph]", "Maintainer": "R Core Team ", "Repository": "CRAN" }, @@ -5462,14 +5462,14 @@ }, "mgcv": { "Package": "mgcv", - "Version": "1.9-3", + "Version": "1.9-4", "Source": "Repository", "Authors@R": "person(given = \"Simon\", family = \"Wood\", role = c(\"aut\", \"cre\"), email = \"simon.wood@r-project.org\")", "Title": "Mixed GAM Computation Vehicle with Automatic Smoothness Estimation", - "Description": "Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Generalized Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2017) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family.", + "Description": "Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2025) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family.", "Priority": "recommended", "Depends": [ - "R (>= 3.6.0)", + "R (>= 4.4.0)", "nlme (>= 3.1-64)" ], "Imports": [ diff --git a/renv.lock b/renv.lock index 11ae7b52..ca300008 100644 --- a/renv.lock +++ b/renv.lock @@ -3405,10 +3405,10 @@ }, "foreign": { "Package": "foreign", - "Version": "0.8-90", + "Version": "0.8-91", "Source": "Repository", "Priority": "recommended", - "Date": "2025-03-31", + "Date": "2026-01-29", "Title": "Read Data Stored by 'Minitab', 'S', 'SAS', 'SPSS', 'Stata', 'Systat', 'Weka', 'dBase', ...", "Depends": [ "R (>= 4.0.0)" @@ -3429,7 +3429,7 @@ "MailingList": "R-help@r-project.org", "URL": "https://svn.r-project.org/R-packages/trunk/foreign/", "NeedsCompilation": "yes", - "Author": "R Core Team [aut, cph, cre] (02zz1nj61), Roger Bivand [ctb, cph], Vincent J. Carey [ctb, cph], Saikat DebRoy [ctb, cph], Stephen Eglen [ctb, cph], Rajarshi Guha [ctb, cph], Swetlana Herbrandt [ctb], Nicholas Lewin-Koh [ctb, cph], Mark Myatt [ctb, cph], Michael Nelson [ctb], Ben Pfaff [ctb], Brian Quistorff [ctb], Frank Warmerdam [ctb, cph], Stephen Weigand [ctb, cph], Free Software Foundation, Inc. [cph]", + "Author": "R Core Team [aut, cph, cre] (ROR: ), Roger Bivand [ctb, cph], Vincent J. Carey [ctb, cph], Saikat DebRoy [ctb, cph], Stephen Eglen [ctb, cph], Rajarshi Guha [ctb, cph], Swetlana Herbrandt [ctb], Nicholas Lewin-Koh [ctb, cph], Mark Myatt [ctb, cph], Michael Nelson [ctb], Ben Pfaff [ctb], Brian Quistorff [ctb], Frank Warmerdam [ctb, cph], Stephen Weigand [ctb, cph], Free Software Foundation, Inc. [cph]", "Maintainer": "R Core Team ", "Repository": "CRAN" }, @@ -5462,14 +5462,14 @@ }, "mgcv": { "Package": "mgcv", - "Version": "1.9-3", + "Version": "1.9-4", "Source": "Repository", "Authors@R": "person(given = \"Simon\", family = \"Wood\", role = c(\"aut\", \"cre\"), email = \"simon.wood@r-project.org\")", "Title": "Mixed GAM Computation Vehicle with Automatic Smoothness Estimation", - "Description": "Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Generalized Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2017) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family.", + "Description": "Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2025) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family.", "Priority": "recommended", "Depends": [ - "R (>= 3.6.0)", + "R (>= 4.4.0)", "nlme (>= 3.1-64)" ], "Imports": [ From 507982c51b9c78d72249c1a092f4517781daf76f Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 12 Mar 2026 14:19:15 +0100 Subject: [PATCH 18/62] updated renv.lock --- app_docker/app.R | 2 +- app_docker/renv.lock | 15 +++++++-------- renv.lock | 15 +++++++-------- 3 files changed, 15 insertions(+), 17 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index 63a9e442..1355da88 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp6ipYJe/file24f61644daa6.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpZZ6Yua/file58174f49b1bf.R ######## i18n_path <- here::here("translations") diff --git a/app_docker/renv.lock b/app_docker/renv.lock index ca300008..96709a25 100644 --- a/app_docker/renv.lock +++ b/app_docker/renv.lock @@ -2819,11 +2819,11 @@ }, "emmeans": { "Package": "emmeans", - "Version": "2.0.2", + "Version": "2.0.1", "Source": "Repository", "Type": "Package", "Title": "Estimated Marginal Means, aka Least-Squares Means", - "Date": "2026-02-20", + "Date": "2025-12-10", "Authors@R": "c(person(\"Russell V.\", \"Lenth\", role = c(\"aut\", \"cph\"), email = \"russell-lenth@uiowa.edu\"), person(\"Julia\", \"Piaskowski\", role = c(\"cre\", \"aut\"), email = \"julia.piask@gmail.com\"), person(\"Balazs\", \"Banfai\", role = \"ctb\"), person(\"Ben\", \"Bolker\", role = \"ctb\"), person(\"Paul\", \"Buerkner\", role = \"ctb\"), person(\"Iago\", \"Giné-Vázquez\", role = \"ctb\"), person(\"Maxime\", \"Hervé\", role = \"ctb\"), person(\"Maarten\", \"Jung\", role = \"ctb\"), person(\"Jonathon\", \"Love\", role = \"ctb\"), person(\"Fernando\", \"Miguez\", role = \"ctb\"), person(\"Hannes\", \"Riebl\", role = \"ctb\"), person(\"Henrik\", \"Singmann\", role = \"ctb\"))", "Maintainer": "Julia Piaskowski ", "Depends": [ @@ -2886,7 +2886,7 @@ "sommer", "survival" ], - "URL": "https://rvlenth.github.io/emmeans/, https://github.com/rvlenth/emmeans/", + "URL": "https://rvlenth.github.io/emmeans/,https://rvlenth.github.io/emmeans/", "BugReports": "https://github.com/rvlenth/emmeans/issues", "LazyData": "yes", "ByteCompile": "yes", @@ -5675,10 +5675,10 @@ }, "mvtnorm": { "Package": "mvtnorm", - "Version": "1.3-5", + "Version": "1.3-2", "Source": "Repository", "Title": "Multivariate Normal and t Distributions", - "Date": "2026-03-10", + "Date": "2024-11-04", "Authors@R": "c(person(\"Alan\", \"Genz\", role = \"aut\"), person(\"Frank\", \"Bretz\", role = \"aut\"), person(\"Tetsuhisa\", \"Miwa\", role = \"aut\"), person(\"Xuefei\", \"Mi\", role = \"aut\"), person(\"Friedrich\", \"Leisch\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\"), person(\"Bjoern\", \"Bornkamp\", role = \"ctb\", comment = c(ORCID = \"0000-0002-6294-8185\")), person(\"Martin\", \"Maechler\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Torsten\", \"Hothorn\", role = c(\"aut\", \"cre\"), email = \"Torsten.Hothorn@R-project.org\", comment = c(ORCID = \"0000-0001-8301-0471\")))", "Description": "Computes multivariate normal and t probabilities, quantiles, random deviates, and densities. Log-likelihoods for multivariate Gaussian models and Gaussian copulae parameterised by Cholesky factors of covariance or precision matrices are implemented for interval-censored and exact data, or a mix thereof. Score functions for these log-likelihoods are available. A class representing multiple lower triangular matrices and corresponding methods are part of this package.", "Imports": [ @@ -5689,13 +5689,12 @@ ], "Suggests": [ "qrng", - "numDeriv", - "bibtex" + "numDeriv" ], "License": "GPL-2", "URL": "http://mvtnorm.R-forge.R-project.org", "NeedsCompilation": "yes", - "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (ORCID: ), Martin Maechler [ctb] (ORCID: ), Torsten Hothorn [aut, cre] (ORCID: )", + "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (), Martin Maechler [ctb] (), Torsten Hothorn [aut, cre] ()", "Maintainer": "Torsten Hothorn ", "Repository": "CRAN" }, diff --git a/renv.lock b/renv.lock index ca300008..96709a25 100644 --- a/renv.lock +++ b/renv.lock @@ -2819,11 +2819,11 @@ }, "emmeans": { "Package": "emmeans", - "Version": "2.0.2", + "Version": "2.0.1", "Source": "Repository", "Type": "Package", "Title": "Estimated Marginal Means, aka Least-Squares Means", - "Date": "2026-02-20", + "Date": "2025-12-10", "Authors@R": "c(person(\"Russell V.\", \"Lenth\", role = c(\"aut\", \"cph\"), email = \"russell-lenth@uiowa.edu\"), person(\"Julia\", \"Piaskowski\", role = c(\"cre\", \"aut\"), email = \"julia.piask@gmail.com\"), person(\"Balazs\", \"Banfai\", role = \"ctb\"), person(\"Ben\", \"Bolker\", role = \"ctb\"), person(\"Paul\", \"Buerkner\", role = \"ctb\"), person(\"Iago\", \"Giné-Vázquez\", role = \"ctb\"), person(\"Maxime\", \"Hervé\", role = \"ctb\"), person(\"Maarten\", \"Jung\", role = \"ctb\"), person(\"Jonathon\", \"Love\", role = \"ctb\"), person(\"Fernando\", \"Miguez\", role = \"ctb\"), person(\"Hannes\", \"Riebl\", role = \"ctb\"), person(\"Henrik\", \"Singmann\", role = \"ctb\"))", "Maintainer": "Julia Piaskowski ", "Depends": [ @@ -2886,7 +2886,7 @@ "sommer", "survival" ], - "URL": "https://rvlenth.github.io/emmeans/, https://github.com/rvlenth/emmeans/", + "URL": "https://rvlenth.github.io/emmeans/,https://rvlenth.github.io/emmeans/", "BugReports": "https://github.com/rvlenth/emmeans/issues", "LazyData": "yes", "ByteCompile": "yes", @@ -5675,10 +5675,10 @@ }, "mvtnorm": { "Package": "mvtnorm", - "Version": "1.3-5", + "Version": "1.3-2", "Source": "Repository", "Title": "Multivariate Normal and t Distributions", - "Date": "2026-03-10", + "Date": "2024-11-04", "Authors@R": "c(person(\"Alan\", \"Genz\", role = \"aut\"), person(\"Frank\", \"Bretz\", role = \"aut\"), person(\"Tetsuhisa\", \"Miwa\", role = \"aut\"), person(\"Xuefei\", \"Mi\", role = \"aut\"), person(\"Friedrich\", \"Leisch\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\"), person(\"Bjoern\", \"Bornkamp\", role = \"ctb\", comment = c(ORCID = \"0000-0002-6294-8185\")), person(\"Martin\", \"Maechler\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Torsten\", \"Hothorn\", role = c(\"aut\", \"cre\"), email = \"Torsten.Hothorn@R-project.org\", comment = c(ORCID = \"0000-0001-8301-0471\")))", "Description": "Computes multivariate normal and t probabilities, quantiles, random deviates, and densities. Log-likelihoods for multivariate Gaussian models and Gaussian copulae parameterised by Cholesky factors of covariance or precision matrices are implemented for interval-censored and exact data, or a mix thereof. Score functions for these log-likelihoods are available. A class representing multiple lower triangular matrices and corresponding methods are part of this package.", "Imports": [ @@ -5689,13 +5689,12 @@ ], "Suggests": [ "qrng", - "numDeriv", - "bibtex" + "numDeriv" ], "License": "GPL-2", "URL": "http://mvtnorm.R-forge.R-project.org", "NeedsCompilation": "yes", - "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (ORCID: ), Martin Maechler [ctb] (ORCID: ), Torsten Hothorn [aut, cre] (ORCID: )", + "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (), Martin Maechler [ctb] (), Torsten Hothorn [aut, cre] ()", "Maintainer": "Torsten Hothorn ", "Repository": "CRAN" }, From c23570ca54b066e457605930eef430bf745363d7 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 23 Mar 2026 14:05:55 +0100 Subject: [PATCH 19/62] chore: remove unused code --- R/validation.R | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/R/validation.R b/R/validation.R index 2ea65d76..8d6847b4 100644 --- a/R/validation.R +++ b/R/validation.R @@ -65,33 +65,6 @@ validation_server <- function(id, data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data) - # observeEvent(data_r(), { - # to_validate <- data() - # valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col) - # - # if (all(c(valid_dims$nrows, valid_dims$ncols))) { - # valid_status <- "OK" - # } else { - # valid_status <- "Failed" - # } - # - # valid_results <- lapply( - # X = c("nrows", "ncols"), - # FUN = function(x) { - # if (is.null(valid_dims[[x]])) - # return(NULL) - # label <- switch( - # x, - # "nrows" = n_row_label, - # "ncols" = n_col_label - # ) - # list( - # status = ifelse(valid_dims[[x]], "OK", "Failed"), - # label = paste0("", label, "") - # ) - # } - # ) - shiny::observeEvent( data_r(), { From cfbee14dcb5d04a4332258423c968db50ab0c9a9 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 23 Mar 2026 14:06:49 +0100 Subject: [PATCH 20/62] feat: added version check and banner. verbose version can be activated with global variabel on launch. --- R/ui_elements.R | 1 + R/version_check.R | 325 +++++++++++++++++++++++++++ man/check_app_version.Rd | 72 ++++++ man/dot-build_version_alert.Rd | 32 +++ man/dot-get_latest_github_version.Rd | 20 ++ man/dot-has_internet.Rd | 14 ++ man/dot-resolve_app_version.Rd | 27 +++ man/launch_FreesearchR.Rd | 4 + 8 files changed, 495 insertions(+) create mode 100644 R/version_check.R create mode 100644 man/check_app_version.Rd create mode 100644 man/dot-build_version_alert.Rd create mode 100644 man/dot-get_latest_github_version.Rd create mode 100644 man/dot-has_internet.Rd create mode 100644 man/dot-resolve_app_version.Rd diff --git a/R/ui_elements.R b/R/ui_elements.R index cac844a0..96175376 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -25,6 +25,7 @@ ui_elements <- function(selection) { ## Default just output "NULL" ## This could probably be achieved more legantly, but this works. dev_banner(), + version_banner, landing_page_ui(i18n = i18n), # shiny::column(width = 2), # shiny::column( diff --git a/R/version_check.R b/R/version_check.R new file mode 100644 index 00000000..4f6932e4 --- /dev/null +++ b/R/version_check.R @@ -0,0 +1,325 @@ +# version_check.R +# +# Runs a one-time version check at app startup and returns a ready-made +# shinyWidgets::alert() UI element that can be placed directly in the UI +# definition -- no server(), no renderUI(), no uiOutput() required. +# +# Because the check runs outside server(), it executes once when the app +# process starts, so the banner is present immediately on first render with +# no loading delay. +# +# Version detection uses two strategies, tried in order: +# 1. utils::packageVersion() -- works when the package is installed locally. +# 2. app_version argument -- explicit fallback for environments where the +# package is not installed (e.g. shinyapps.io). Pass the result of your +# app_version() function here. +# +# Quick start: +# +# # global.R (or top of app.R, before ui / server) +# source("version_check.R") +# version_banner <- check_app_version( +# github_user = "your-github-username", +# github_repo = "your-repo-name", +# app_version = app_version() # fallback for shinyapps.io +# ) +# +# # ui.R -- drop the result anywhere in the UI tree +# fluidPage( +# version_banner, +# ... +# ) +# +# # Verbose / debug mode -- always show the banner: +# version_banner <- check_app_version( +# github_user = "your-github-username", +# github_repo = "your-repo-name", +# app_version = app_version(), +# verbose = TRUE +# ) + + +# -- Internal helpers ---------------------------------------------------------- + +#' Check internet connectivity +#' +#' @return Logical; TRUE if an internet connection is available. +.has_internet <- function() { + tryCatch({ + con <- url("https://api.github.com", open = "r") + close(con) + TRUE + }, error = function(e) FALSE) +} + + +#' Fetch the latest release version from a GitHub repository +#' +#' @param github_user GitHub username or organisation. +#' @param github_repo Repository name. +#' +#' @return A character string with the version tag (e.g. "1.2.0"), or NULL on +#' failure. +.get_latest_github_version <- function(github_user, github_repo) { + api_url <- sprintf( + "https://api.github.com/repos/%s/%s/releases/latest", + github_user, + github_repo + ) + + tryCatch({ + response <- readLines(url(api_url), warn = FALSE) + json_text <- paste(response, collapse = "") + + tag <- regmatches( + json_text, + regexpr('"tag_name"\\s*:\\s*"([^"]+)"', json_text) + ) + + if (length(tag) == 0 || nchar(tag) == 0) return(NULL) + + # Strip a leading "v" if present (e.g. "v1.2.0" -> "1.2.0") + sub('^"tag_name"\\s*:\\s*"v?([^"]+)"$', "\\1", tag) + }, error = function(e) NULL) +} + + +#' Resolve the current app version +#' +#' Tries two strategies in order: +#' \enumerate{ +#' \item \code{utils::packageVersion(package_name)} -- works when the package +#' is installed locally (development, local \code{runApp()}). +#' \item \code{app_version} argument -- an explicit version string supplied by +#' the caller, e.g. from an \code{app_version()} function bundled with the +#' app. Used on shinyapps.io where the package is not installed. +#' } +#' +#' @param package_name Name of the package / repository. +#' @param app_version Optional fallback version string. +#' +#' @return A character string with the version (e.g. "1.1.0"), or NULL if +#' neither strategy succeeds. +.resolve_app_version <- function(package_name, app_version = NULL) { + + # Strategy 1: installed package + v <- tryCatch( + as.character(utils::packageVersion(package_name)), + error = function(e) NULL + ) + if (!is.null(v)) { + message("[version_check] Version source: installed package") + return(v) + } + + # Strategy 2: explicit fallback supplied by the caller + if (!is.null(app_version)) { + message("[version_check] Version source: app_version() fallback") + return(as.character(app_version)) + } + + NULL +} + + +#' Build a shinyWidgets::alert() UI element for the version banner +#' +#' @param current Current installed version string. +#' @param latest Latest GitHub release version string, or NULL when +#' the check could not complete (e.g. no internet). +#' @param update_available Logical; whether latest > current. +#' @param github_user GitHub username / organisation. +#' @param github_repo Repository name. +#' +#' @return A \code{shinyWidgets::alert()} UI element. +.build_version_alert <- function(current, + latest, + update_available, + github_user, + github_repo) { + + repo_url <- sprintf( + "https://github.com/%s/%s/releases/latest", + github_user, + github_repo + ) + + if (is.null(latest)) { + # Version check could not complete (no internet or API failure) + return( + shinyWidgets::alert( + tags$b("Version check failed. "), + sprintf( + "Running version %s. Could not reach GitHub to check for updates.", + current + ), + status = "warning", + dismissible = TRUE + ) + ) + } + + if (update_available) { + shinyWidgets::alert( + tags$b("Update available! "), + sprintf( + "You are running version %s. Version %s is available on GitHub.", + current, latest + ), + " ", + tags$a(href = repo_url, target = "_blank", "View release"), + status = "warning", + dismissible = TRUE + ) + } else { + # Up to date -- only shown in verbose mode + shinyWidgets::alert( + tags$b("Up to date. "), + sprintf( + "You are running version %s, which matches the latest release (%s).", + current, latest + ), + status = "success", + dismissible = TRUE + ) + } +} + + +# -- Public API ---------------------------------------------------------------- + +#' Run a startup version check and return a banner UI element +#' +#' Call this \strong{outside} \code{server()} -- typically in +#' \code{global.R} or at the top of \code{app.R} -- and embed the returned +#' value directly in your UI definition. Because the check runs at startup +#' the banner is present on first render with no loading delay, and no +#' \code{uiOutput()} / \code{renderUI()} wiring is needed. +#' +#' \strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when +#' a newer version is available or when the check fails. Returns \code{NULL} +#' when the app is up to date (Shiny silently ignores \code{NULL} in the UI). +#' +#' \strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a +#' banner -- including a success banner when up to date -- so you can confirm +#' the check ran and inspect both version strings during development. +#' +#' @param github_user GitHub username or organisation that owns the repository. +#' @param github_repo Repository name. Also used as the package name for +#' \code{utils::packageVersion()}. +#' @param app_version Optional fallback version string for environments where +#' the package is not installed (e.g. shinyapps.io). Pass the result of your +#' \code{app_version()} function here. Ignored when \code{packageVersion()} +#' succeeds. +#' @param verbose Logical; if \code{TRUE} a banner is always returned. +#' Defaults to \code{FALSE}. +#' +#' @return A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there +#' is nothing to show (up to date in non-verbose mode). +#' +#' @examples +#' \dontrun{ +#' # global.R or top of app.R +#' source("version_check.R") +#' version_banner <- check_app_version( +#' github_user = "my-org", +#' github_repo = "my-shiny-app", +#' app_version = app_version() # fallback for shinyapps.io +#' ) +#' +#' # ui.R +#' fluidPage( +#' version_banner, +#' # ... rest of UI +#' ) +#' +#' # Verbose mode for development +#' version_banner <- check_app_version( +#' github_user = "my-org", +#' github_repo = "my-shiny-app", +#' app_version = app_version(), +#' verbose = TRUE +#' ) +#' } +check_app_version <- function(github_user, + github_repo, + app_version = NULL, + verbose = FALSE) { + + # -- 1. Resolve current version ---------------------------------------------- + local_version <- .resolve_app_version(github_repo, app_version) + if (is.null(local_version)) { + message(sprintf( + "[version_check] Could not determine version for '%s' (package not installed and no app_version() fallback supplied).", + github_repo + )) + return(NULL) + } + + message(sprintf("[version_check] Current version: %s", local_version)) + + # -- 2. Internet check ------------------------------------------------------- + if (!.has_internet()) { + message("[version_check] No internet connection detected -- skipping.") + + if (verbose) { + return(.build_version_alert( + current = local_version, + latest = NULL, + update_available = FALSE, + github_user = github_user, + github_repo = github_repo + )) + } + + return(NULL) + } + + # -- 3. Fetch latest GitHub release ------------------------------------------ + latest_version <- .get_latest_github_version(github_user, github_repo) + if (is.null(latest_version)) { + message("[version_check] Could not retrieve latest version from GitHub.") + + if (verbose) { + return(.build_version_alert( + current = local_version, + latest = NULL, + update_available = FALSE, + github_user = github_user, + github_repo = github_repo + )) + } + + return(NULL) + } + + message(sprintf("[version_check] Latest GitHub release: %s", latest_version)) + + # -- 4. Compare versions ----------------------------------------------------- + update_available <- numeric_version(latest_version) > numeric_version(local_version) + + if (update_available) { + message(sprintf( + "[version_check] Update available: %s -> %s", + local_version, latest_version + )) + } else { + message(sprintf("[version_check] App is up to date (%s).", local_version)) + } + + # -- 5. Return banner -------------------------------------------------------- + # An update was found -> always return a warning banner + # Up to date + verbose -> return a success banner + # Up to date + not verbose -> return NULL (Shiny ignores NULL in the UI) + if (update_available || verbose) { + .build_version_alert( + current = local_version, + latest = latest_version, + update_available = update_available, + github_user = github_user, + github_repo = github_repo + ) + } else { + NULL + } +} diff --git a/man/check_app_version.Rd b/man/check_app_version.Rd new file mode 100644 index 00000000..749901e7 --- /dev/null +++ b/man/check_app_version.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version_check.R +\name{check_app_version} +\alias{check_app_version} +\title{Run a startup version check and return a banner UI element} +\usage{ +check_app_version( + github_user, + github_repo, + app_version = NULL, + verbose = FALSE +) +} +\arguments{ +\item{github_user}{GitHub username or organisation that owns the repository.} + +\item{github_repo}{Repository name. Also used as the package name for +\code{utils::packageVersion()}.} + +\item{app_version}{Optional fallback version string for environments where +the package is not installed (e.g. shinyapps.io). Pass the result of your +\code{app_version()} function here. Ignored when \code{packageVersion()} +succeeds.} + +\item{verbose}{Logical; if \code{TRUE} a banner is always returned. +Defaults to \code{FALSE}.} +} +\value{ +A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there +is nothing to show (up to date in non-verbose mode). +} +\description{ +Call this \strong{outside} \code{server()} -- typically in +\code{global.R} or at the top of \code{app.R} -- and embed the returned +value directly in your UI definition. Because the check runs at startup +the banner is present on first render with no loading delay, and no +\code{uiOutput()} / \code{renderUI()} wiring is needed. +} +\details{ +\strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when +a newer version is available or when the check fails. Returns \code{NULL} +when the app is up to date (Shiny silently ignores \code{NULL} in the UI). + +\strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a +banner -- including a success banner when up to date -- so you can confirm +the check ran and inspect both version strings during development. +} +\examples{ +\dontrun{ +# global.R or top of app.R +source("version_check.R") +version_banner <- check_app_version( + github_user = "my-org", + github_repo = "my-shiny-app", + app_version = app_version() # fallback for shinyapps.io +) + +# ui.R +fluidPage( + version_banner, + # ... rest of UI +) + +# Verbose mode for development +version_banner <- check_app_version( + github_user = "my-org", + github_repo = "my-shiny-app", + app_version = app_version(), + verbose = TRUE +) +} +} diff --git a/man/dot-build_version_alert.Rd b/man/dot-build_version_alert.Rd new file mode 100644 index 00000000..d9998740 --- /dev/null +++ b/man/dot-build_version_alert.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version_check.R +\name{.build_version_alert} +\alias{.build_version_alert} +\title{Build a shinyWidgets::alert() UI element for the version banner} +\usage{ +.build_version_alert( + current, + latest, + update_available, + github_user, + github_repo +) +} +\arguments{ +\item{current}{Current installed version string.} + +\item{latest}{Latest GitHub release version string, or NULL when +the check could not complete (e.g. no internet).} + +\item{update_available}{Logical; whether latest > current.} + +\item{github_user}{GitHub username / organisation.} + +\item{github_repo}{Repository name.} +} +\value{ +A \code{shinyWidgets::alert()} UI element. +} +\description{ +Build a shinyWidgets::alert() UI element for the version banner +} diff --git a/man/dot-get_latest_github_version.Rd b/man/dot-get_latest_github_version.Rd new file mode 100644 index 00000000..30b16a66 --- /dev/null +++ b/man/dot-get_latest_github_version.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version_check.R +\name{.get_latest_github_version} +\alias{.get_latest_github_version} +\title{Fetch the latest release version from a GitHub repository} +\usage{ +.get_latest_github_version(github_user, github_repo) +} +\arguments{ +\item{github_user}{GitHub username or organisation.} + +\item{github_repo}{Repository name.} +} +\value{ +A character string with the version tag (e.g. "1.2.0"), or NULL on +failure. +} +\description{ +Fetch the latest release version from a GitHub repository +} diff --git a/man/dot-has_internet.Rd b/man/dot-has_internet.Rd new file mode 100644 index 00000000..0b23d4fd --- /dev/null +++ b/man/dot-has_internet.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version_check.R +\name{.has_internet} +\alias{.has_internet} +\title{Check internet connectivity} +\usage{ +.has_internet() +} +\value{ +Logical; TRUE if an internet connection is available. +} +\description{ +Check internet connectivity +} diff --git a/man/dot-resolve_app_version.Rd b/man/dot-resolve_app_version.Rd new file mode 100644 index 00000000..f16837a6 --- /dev/null +++ b/man/dot-resolve_app_version.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version_check.R +\name{.resolve_app_version} +\alias{.resolve_app_version} +\title{Resolve the current app version} +\usage{ +.resolve_app_version(package_name, app_version = NULL) +} +\arguments{ +\item{package_name}{Name of the package / repository.} + +\item{app_version}{Optional fallback version string.} +} +\value{ +A character string with the version (e.g. "1.1.0"), or NULL if +neither strategy succeeds. +} +\description{ +Tries two strategies in order: +\enumerate{ +\item \code{utils::packageVersion(package_name)} -- works when the package +is installed locally (development, local \code{runApp()}). +\item \code{app_version} argument -- an explicit version string supplied by +the caller, e.g. from an \code{app_version()} function bundled with the +app. Used on shinyapps.io where the package is not installed. +} +} diff --git a/man/launch_FreesearchR.Rd b/man/launch_FreesearchR.Rd index 2ab6c607..5410af8a 100644 --- a/man/launch_FreesearchR.Rd +++ b/man/launch_FreesearchR.Rd @@ -9,6 +9,7 @@ launch_FreesearchR( data_limit_default = 1000, data_limit_upper = 1e+05, data_limit_lower = 1, + check_app_version = FALSE, ... ) } @@ -22,6 +23,9 @@ when loading data} \item{data_limit_lower}{data set observations lower limit} +\item{check_app_version}{always attempt to check app version against latest +release on GitHub. Default is FALSE} + \item{...}{passed on to \code{shiny::runApp()}} } \value{ From b0ecce8c54b796dddaf3ff78f6abd2bb1f7c5d59 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 23 Mar 2026 14:10:06 +0100 Subject: [PATCH 21/62] chore: updated docs and render --- DESCRIPTION | 1 + NEWS.md | 2 + R/hosted_version.R | 2 +- R/launch_FreesearchR.R | 6 ++- R/plot_sankey.R | 92 +++++++++++++++++++++++++++-------------- R/sysdata.rda | Bin 2645 -> 2731 bytes README.md | 55 ++++++++++++------------ SESSION.md | 18 ++++++-- man/data-plots.Rd | 2 + 9 files changed, 114 insertions(+), 64 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3e2cc6ab..5a9d85b9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -141,5 +141,6 @@ Collate: 'update-variables-ext.R' 'utils-labels.R' 'validation.R' + 'version_check.R' 'visual_summary.R' 'wide2long.R' diff --git a/NEWS.md b/NEWS.md index f08ae0b2..3cfed098 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,8 @@ # FreesearchR 26.3.4 +*NEW* Added app version check against latest release on GitHub. Only runs if internet connection present. No other polling. +*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size. # FreesearchR 26.3.3 diff --git a/R/hosted_version.R b/R/hosted_version.R index f0c656d1..17135440 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.4-260312' +hosted_version <- function()'v26.3.4-260323' diff --git a/R/launch_FreesearchR.R b/R/launch_FreesearchR.R index a789f185..92d09a51 100644 --- a/R/launch_FreesearchR.R +++ b/R/launch_FreesearchR.R @@ -8,6 +8,8 @@ #' @param data_limit_default default data set observations limit #' @param data_limit_upper data set observations upper limit #' @param data_limit_lower data set observations lower limit +#' @param check_app_version always attempt to check app version against latest +#' release on GitHub. Default is FALSE #' @param ... passed on to `shiny::runApp()` #' #' @returns shiny app @@ -22,12 +24,14 @@ launch_FreesearchR <- function(include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 100000, data_limit_lower = 1, + check_app_version = FALSE, ...) { Sys.setenv( INCLUDE_GLOBALENV = include_globalenv, DATA_LIMIT_DEFAULT = data_limit_default, DATA_LIMIT_UPPER = data_limit_upper, - DATA_LIMIT_LOWER = data_limit_lower + DATA_LIMIT_LOWER = data_limit_lower, + CHECK_APP_VERSION = check_app_version ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") diff --git a/R/plot_sankey.R b/R/plot_sankey.R index b3aa1b55..baa864dd 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -33,15 +33,17 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { dplyr::ungroup() if (numbers == "count") { - out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) - ) + out <- out |> dplyr::mutate(lx = factor(paste0( + !!dplyr::sym(pri), "\n(n=", gx.sum, ")" + )), ly = factor(paste0( + !!dplyr::sym(sec), "\n(n=", gy.sum, ")" + ))) } else if (numbers == "percentage") { - out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) - ) + out <- out |> dplyr::mutate(lx = factor(paste0( + !!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)" + )), ly = factor(paste0( + !!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)" + ))) } if (is.factor(data[[pri]])) { @@ -83,20 +85,38 @@ str_remove_last <- function(data, pattern = "\n") { #' mtcars |> #' default_parsing() |> #' plot_sankey("cyl", "gear", "vs", color.group = "pri") -plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL,missing.level="Missing") { +#' +#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") +plot_sankey <- function(data, + pri, + sec, + ter = NULL, + color.group = "pri", + colors = NULL, + missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { ds <- list(data) } - out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors,missing.level=missing.level) + + out <- lapply(ds, \(.ds) { + plot_sankey_single( + .ds, + pri = pri, + sec = sec, + color.group = color.group, + colors = colors, + missing.level = missing.level + ) }) patchwork::wrap_plots(out) } + + #' Beautiful sankey plot #' #' @param color.group set group to colour by. "x" or "y". @@ -123,19 +143,31 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") -plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL,missing.level="Missing", ...) { +plot_sankey_single <- function(data, + pri, + sec, + color.group = c("pri", "sec"), + colors = NULL, + missing.level = "Missing", + ...) { color.group <- match.arg(color.group) + + # browser() + # if (is.na(ds[c(pri,sec)])) + # browser() data_orig <- data + data[c(pri, sec)] <- data[c(pri, sec)] |> dplyr::mutate( - # dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop)#, - # dplyr::across(dplyr::where(is.factor), \(.x){forcats::fct_na_value_to_level(.x,missing.level)}) + dplyr::across(dplyr::where(is.logical), as.factor), + dplyr::across(dplyr::where(is.factor), forcats::fct_drop), + dplyr::across(dplyr::where(is.factor), \(.x) { + forcats::fct_na_value_to_level(.x, missing.level) + }) ) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) na.color <- "#2986cc" @@ -148,21 +180,26 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] secondary.colors <- rep(na.color, length(levels(data[[pri]]))) - label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) + label.colors <- Reduce(c, lapply(list( + secondary.colors, rev(main.colors) + ), contrast_text)) } else { main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) ## Only keep colors for included levels main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] secondary.colors <- rep(na.color, length(levels(data[[sec]]))) - label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) + label.colors <- Reduce(c, lapply(list( + rev(main.colors), secondary.colors + ), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) + colors[is.na(colors)] <- "grey80" } else { label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, pri), get_label(data, sec)) |> + group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |> sapply(line_break) |> unname() @@ -181,9 +218,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co knot.pos = 0.4, curve_type = "sigmoid" ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), - size = 2, - width = 1 / 3.4 - ) + size = 2, + width = 1 / 3.4) } else { p <- p + ggalluvial::geom_alluvium( @@ -196,9 +232,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co knot.pos = 0.4, curve_type = "sigmoid" ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), - size = 2, - width = 1 / 3.4 - ) + size = 2, + width = 1 / 3.4) } ## Will fail to use stat="stratum" if library is not loaded. @@ -208,13 +243,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co stat = "stratum", ggplot2::aes(label = after_stat(stratum)), colour = label.colors, - size = 8, + size = 6, lineheight = 1 ) + - ggplot2::scale_x_continuous( - breaks = 1:2, - labels = group_labels - ) + + ggplot2::scale_x_continuous(breaks = 1:2, labels = group_labels) + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + # ggplot2::scale_color_manual(values = main.colors) + ggplot2::theme_void() + diff --git a/R/sysdata.rda b/R/sysdata.rda index f8b0df59c674b9d09f2de1dbfadcfb9a132325b6..efea72cf58fc1738966ab77c2a0f106f5c8e661a 100644 GIT binary patch literal 2731 zcmV;c3RLw%T4*^jL0KkKS)61t6#yD1f5iX)Xaz!l|KNXb-@w2B|L{Nn004*q;0zxZ z5!h}#4gpGl4FDfJK7b|m!6`3>ra&fu&`d)~rkNQ{sg%t%G8l~jG&Z1ZOwtiBK$>KX zl>Id^qK_!`00E#h000008lE6ZRP>CViRldkAY>Xaj7)$40}vT7lSv^JJu+xW_MnW6 zHl%0+2yG)kW`F`|qd}DjXlT$+O*EJRG|7T6nlJzYX^H9>0EtPdqMI5`LqX~QJfHy3 z00EkS2Gj;i(#Ih(lrV{q$3QDuDyeKyQ=7!13cKHXO92tG!W!Nmu8gw!7y}0G-uCH` zO{fksO3(^I;@mT_Zog8u&6pHGg(+n?=iUPgQU-fPGEJaYNZ(O7JUNbs3y zqLKQxi$0jmAkSQ|eU)fC3c>{PrD>(2N?-gARO>NOFqsC_#ySRtRL#}R7a^Wzt8j95!z(k*SljbKaK@^E8TD56>w{rBZ;aFF%AJTr|XmKmpA*{rn~Xg9y) z_$5HQ%9R?FOp7wHMeuG zR$l{V2nuKr6k-Aa0zyM(h@vf)P*p@fa6ubls0DM%9M8b0I{SJ|nUny{6hl6Ice?vr zJNJ6H5CRjK-Rprx6pI8@RA4MvDk!jEh_F~9#T7&qVyqBiDlCGKRYVjNQAI^T6jW2y z>hrm0cY3OJ&k`Und90IXHs{-KZun^2s0%nPDxxPFT-I@TYnu~hEi87-naf-6D}%7@ zP8y4?EYq^tbtHg8(}auEEU7Fh)PsgxMnp`c0H`p6$kdib5vV#4Y)y-9WP_|IkWLw@ zGX;={d5yt9Nd$l)h^0AmWnF3tgfeqIGR)aBwpgI0lcXtzGPTp3S#{4^LO{(_ zh7+Y0`?KY}1rLdX=k8MQGH^#@ujg zn|OA)%Cx4W01^;2pc2zT7>M53bP!66BG{;`xdJpzTvrw0Hs4s~zFFWqJx{+o{h8b1 z^t(5FfF1T7NEMLpFs-AO+SM{Z0+A95&&rV}y8F2PB&v*X1hSIRD5S9_WyC5ckR&sZ z6eJiBBLl*LI}ngLunGJ(Ct_)uL(M`|9HjHS-14P6xm$3`CT)f+(MUFmp^UbLR!WE+ zGo~=6nXDnH{T&z*-tJ;dh@@CdOiZ?aoG765ND0{30}z6&K?%#2U>I5{3oQnF78q^p zZ8}nHuW>Kop`K@%*X0SK){RQrb_oHfIV>wE%81I*h&VL?rU^P=Arg2}bZj!zH}+9w z`V_=sf$0zfOhpYgCN>Nv=UxGl8CFoy1}er!v&YxQ`}VgQQ7;E7TH4l)jS|``j1s*AI_0Lf@#N}$*Ido{+f^D|7)?z) znr&rog72+wZE8_imX)+pDJP}0Hhi<@@Df0uIraSeRb3hhYy^-G;BoMvW`r;MY2a{( zooOxkv=(P?38yBTq!>rlSIPoN1!NIdK3cRwm!d8SAQo7V2_P1J)`a;5tavK5{dsqa zAT7bIVm%wZp3i{f=@V#W($0wR@pw9gdf1Jd*2Mw5k7u2xJ<=7ryVOvv@YaKLdmlgm@8o>2gX!P2M$38-al zB)6EQn7qB~DpO%F`$yro#;6hmdhD><*DeXyex>LmGud0{-WKVoE@WXG#|kT1lhJx- z5J9LXlJUx~DTe#2s2@hUXp*bnigc*$nIil^`TkUuYp<8gK3m{tN zc;u{a9@&##Vrf#SJQ61RX-y8Z;WAeASBygfW@WVsj;mTC=Wg^JQ#MA8awbtz=q)fe zVU|^BZj$Tt>e*~8Av|!Guy%2s5g{P36gH@aj8lti`^S*3!dW=NH=d^dcZg(!XZ=@fh-3J*fX)~7zjrL z5++6uFXM48T8u+vF}_g>3UhI%I?(I%eXU*8qf3^vhtz2WvLa@pF?0M7`XuuMBM^?K zG4T_~jEm5X5MlB)&G!&ocH{=h6UwXt5iny#o3oLI^8-5(3mo^}Ny5G1t%1i7$cgP- z+~j~@mm*O@0%#p19F1hu_9l9EucPeGXq*V(dP}IQk-5CCdaocwm5EMkGmlY>MyZ@e z8r;@-pRWM!Xkc;N~3FIh?nar*8=FXJ@ljnXw^`XvKszZw>fkI zs-wE~plVv!-E2AzN}8N;d%xr&R( zR}_v?v({pI@MmU$vZyW6#RfGvsAY3WhkWud4GDr8hJy)-M;(T^wO<-Rb;3ffSHOd6 zvgW8)u%se`TyZ&UsOIrd)rv2-qXyTF__VRcG@@aRQl*s|Zxy=LRP+kTB2}6js@D({ z2VGztK#5)M$hC2&I#8<@ZJF1AERqohf`E0M)RCftNQI6T0KCFBDXnciX-tl8P;1?l ztD{6Mk&{m5Y_S&}Q^$QWQDIG5?V%0621Fl28<{R;OY*4~SgCkxhXhzFK?614$f2-V zKQ+^FzekD`6+}x;G!)qkF}htm{;3tp`=McAHPUW2vlm8m&J|iIl=UU!P-~>43k8uA l!7O^b-l1L@zH4;R$TbG287oqvROuh_cO+AV2?@qSAyD*!+=KuC literal 2645 zcmV-b3aa%&T4*^jL0KkKS@bZ9sQ?)Df5iX)Xaz!l|LA{j-@w2B|L{Nn0ssgB;0wPN zA{HJ4f>MnFKo{Qn51;@5FAYpU2mlc_geRtm(@6BE=}jJp7(+&e)MG|SHBZwZlv7P6 zL(~t^LwbY&10Vnm27ojMgi|S}>VrT405lI!4FF^s00000B+^7BQ}k+NgLOk!q zsAd=Xv$KCEZrljCVgMr|JRAGD_iz8PaCa~MU+&yT<42ah!}+Zauj4``RgbmQ`@ObK zBFRPfR0_hdffSZ|D1b~K0~_RDUMUut2I5{S6$YDPYD#Lk$Z}$HDM%ABj@t=C__J9x zds3G|qgN$Em{SonX0kNo5s;9zTlt4CRQfDkzl>$TFq-F+TH!- z?}Pzi!fBt#+BMbtnEcE*vy7U}rET99TYQ`<+R(CLpFb7R)~MaZ3E{s-#pmGq6#20F z?Fyz3kDPG8b2m>e(n5-(1j~pZ$a$HV5W2F&%^gXlnznM4xy@CyBuO~MWs|L4rgd4Y z)f}muWwY2qUa(Wi$*J7S%-r>o(Wul+xz$Oh5vXaJ%bS|H<%SjRAeRQE#%&k&Eu3~4 za^0tPGkqY`RFnC7wir}E#S~2l4qVIAzjs3SCSe0+AR=pss4+!W1cZjo006dGNFX8m zfFR{X01J9Dj6Z-tc>8;XJwR2|fFZ4|b?(O2jttLcbQA{>kB&4#LP;P(ND)K@6pF@+tF{27--|UGb#D}lB_We`Zc8xDDJA(q$2oBk%*^KT zlCy*y8dy zGj$A`y0;NpH8S(Qc{SOlxz4Lgpprz42n@_Ct#<8BI4KcD!AMiAxdH4=LL{P1ku=d! z9vJHn8;^rMUkvf|e9sOaOq10^y^^q=b{4KJZ4&}XFo?iZ`Di5fpL-u=DxwYmmRMRP z78WqfxP?UYz=m`Mkb@+OL^NQIltBzoRJ_z$iKi1v4Un3o_3y=dN_XXL!zkwP#WYwA zs|-tMRb;4vC3w!QKkraW6iI&gPg%lp>0(#AoJ;`JRSb`I`Y{Fq^ zuq?D0?a;%!pKpU~i!}T;c5}nS&F}=#YeuDOcLD{dIV>wE%7~St7~s?fm?ZMRVnNV^ z=~!g6Gi;^73b?ultVMSsh;CSyFks&)XiBLH5vmGQOsYbZTJ|5Sy^<(LxeI6>qc1qt zRx2)jO=uDd4m4Ckt)XU^o?GTXtXO`^UZAsvoV=zZl%CJ6!8qGO?{^eQ6oyg?&xzHZ zREK;Z5t-z()7qVxY7$tj|=9Ze`&njL`b8S_n!I0F_CakUV z-RoPesYOI$+9VkT=iW=x)tqkTf&;v7?_TX^*2SMNKz_z6#sc(??ujxs7$Jd@+BFGu z76KAwR|On8=DaWfKmaG@4Apbl^ND+UF#$jYd$ZsIfC~40*Xdzj>$;os@YnJcNMWO# z)qdVetL!6D2uofd%;yuQ{a(=f;&LVxfCeE^v?UG9512v;L-z9vB}A0JyZs2DxE3|{ ziCJ|nGJ`vVJT5xDF#RRIL+@~!nGBWp$&%1_ouvZa`stj4ohQv|FqaK*teFF?yC7eS z3bYKr$bEf&mB^GW^CFunHA91(FCP+fH6nLkj} zF$aCLqAL)VckgQ*%e|CVI7oAaA0^v7}_Kwl^%`L>7RZ0MZ zN{@#$srUYrBO*UA{C*(pCv>ZsR2tno-+hRg+Ze-K-@v~ArVK{zRf zymQK)p(iv`yR+q+OEs3GDUW9+C9ol3j*`3h7^2-3XYF#rR2f8RkQbV(ba6vV~b|X zYgGeflSbHi-25G66fPtaVX52jc>-8<^@#*ZGIflWG}To_OS+Phqd_!;Lj%C^cgZwc z0TC(00X+n3VlsxJQpMT5&9SW8w)>`r)V*9QRwu1C_SYJ-Di?MYDcQ)#g;8trTP$CU zRgLSPcNupo@p6b6vpx$QLi&2~@6V&p8c0^e*-Z5sY{q-LK8P=-7)s*Is-d*CTDmmV zkd?%{R|m{@j*ecI?R5^@is1U0II>43^R1su_IMB653GU8*tAPcgZ?h$ig2MJ=wTI7 D5E<{a diff --git a/README.md b/README.md index 344b8649..b6444c6d 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,9 @@ -# FreesearchR FreesearchR website +# FreesearchR FreesearchR website -[![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) -[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.14527429.svg)](https://doi.org/10.5281/zenodo.14527429) -[![rhub](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml) -[![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/FreesearchR/) + +[![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.14527429.svg)](https://doi.org/10.5281/zenodo.14527429) [![rhub](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml) [![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/FreesearchR/) + The [***FreesearchR***](https://app.freesearchr.org) is a simple, clinical health data exploration and analysis tool to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results. @@ -19,11 +18,11 @@ All feedback is welcome and can be shared as a GitHub issue. Any suggestions on This app has the following simple goals: -1. help the health clinician getting an overview of data in quality improvement projects and clinical research +1. help the health clinician getting an overview of data in quality improvement projects and clinical research -1. help learners get a good start analysing data and coding in *R* +2. help learners get a good start analysing data and coding in *R* -1. ease quick data overview and basic visualisations for any clinical researcher +3. ease quick data overview and basic visualisations for any clinical researcher Here’s a polished and restructured version of your README section for clarity, conciseness, and user-friendliness: @@ -35,32 +34,32 @@ The **FreesearchR** app can be run locally on your machine, ensuring no data is The app can be configured either by passing a named list to `run_app()` or by setting environment variables in a **Docker Compose** file. The following variables control data access and display behavior. If no values are provided, the app will use the defaults listed below. - **Configuration Variables** -| Variable | Description | Default | -|-------------------------|-----------------------------------------------------------------------------|-----------| -| `INCLUDE_GLOBALENV` | Load datasets already present in the global R environment into the app | `FALSE` | -| `DATA_LIMIT_DEFAULT` | Default number of observations for previewing or working with a dataset | `10,000` | -| `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit. If set to 0, no uppper limit is applied. | `100,000` | -| `DATA_LIMIT_LOWER` | Minimum number of observations a user can set for the lower limit | `1` | +| Variable | Description | Default | +|--------------|--------------------------------------------|--------------| +| `INCLUDE_GLOBALENV` | Load datasets already present in the global R environment into the app | `FALSE` | +| `DATA_LIMIT_DEFAULT` | Default number of observations for previewing or working with a dataset | `10,000` | +| `DATA_LIMIT_UPPER` | Maximum number of observations a user can set for the upper limit. If set to 0, no uppper limit is applied. | `100,000` | +| `DATA_LIMIT_LOWER` | Minimum number of observations a user can set for the lower limit | `1` | +| `CHECK_APP_VERSION` | Always print version check results. Checks app version against latest release on GitHub. | `FALSE` | ### Run from R (or RStudio) If you're working with data in R, **FreesearchR** is a quick and easy tool for exploratory analysis. -1. **Requirement:** Ensure you have [R](https://www.r-project.org/) installed, and optionally an editor like [RStudio](https://posit.co/download/rstudio-desktop/). +1. **Requirement:** Ensure you have [R](https://www.r-project.org/) installed, and optionally an editor like [RStudio](https://posit.co/download/rstudio-desktop/). -2. Open the **R console** and run the following code to install the `{FreesearchR}` package and launch the app: +2. Open the **R console** and run the following code to install the `{FreesearchR}` package and launch the app: - ```r - if (!require("devtools")) install.packages("devtools") - devtools::install_github("agdamsbo/FreesearchR") - library(FreesearchR) - # Load sample data (e.g., mtcars) to make it available in the app - data(mtcars) - launch_FreesearchR(INCLUDE_GLOBALENV=TRUE) - ``` + ``` r + if (!require("devtools")) install.packages("devtools") + devtools::install_github("agdamsbo/FreesearchR") + library(FreesearchR) + # Load sample data (e.g., mtcars) to make it available in the app + data(mtcars) + launch_FreesearchR(INCLUDE_GLOBALENV=TRUE,CHECK_APP_VERSION=TRUE) + ``` All the variables specified above can also be passed to the app on launch from R. Set DATA_LIMIT_UPPER=0 to remove upper data limit. This limit is set to protect the online app version from choking and crashing on large data sets. @@ -70,7 +69,7 @@ For advanced users, you can deploy **FreesearchR** using Docker. A data folder c To mount a local data folder, add a `volumes` entry to your `docker-compose.yml` file: -```yaml +``` yaml services: shiny: image: ghcr.io/agdamsbo/freesearchr:latest @@ -86,9 +85,9 @@ services: restart: on-failure ``` -- The `:ro` flag mounts the folder as **read-only**, preventing the app from modifying your original data files. +- The `:ro` flag mounts the folder as **read-only**, preventing the app from modifying your original data files. -- If no volume is mounted, the app will start without any preloaded datasets. +- If no volume is mounted, the app will start without any preloaded datasets. ## Code of Conduct diff --git a/SESSION.md b/SESSION.md index 1bd978b0..44778018 100644 --- a/SESSION.md +++ b/SESSION.md @@ -11,11 +11,11 @@ |collate |en_US.UTF-8 | |ctype |en_US.UTF-8 | |tz |Europe/Copenhagen | -|date |2026-03-12 | +|date |2026-03-23 | |rstudio |2026.01.1+403 Apple Blossom (desktop) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |quarto |1.7.30 @ /usr/local/bin/quarto | -|FreesearchR |26.3.4.260312 | +|FreesearchR |26.3.4.260323 | -------------------------------------------------------------------------------- @@ -33,6 +33,7 @@ |bit64 |4.6.0-1 |2025-01-16 |CRAN (R 4.5.0) | |bitops |1.0-9 |2024-10-03 |CRAN (R 4.5.0) | |boot |1.3-32 |2025-08-29 |CRAN (R 4.5.0) | +|brio |1.1.5 |2024-04-24 |CRAN (R 4.5.0) | |broom |1.0.12 |2026-01-27 |CRAN (R 4.5.2) | |broom.helpers |1.22.0 |2025-09-17 |CRAN (R 4.5.0) | |bsicons |0.1.2 |2023-11-04 |CRAN (R 4.5.0) | @@ -43,6 +44,7 @@ |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | +|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | @@ -52,6 +54,7 @@ |colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) | +|curl |7.0.0 |2025-08-19 |CRAN (R 4.5.0) | |data.table |1.18.2.1 |2026-01-27 |CRAN (R 4.5.2) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.5.0) | |datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) | @@ -66,7 +69,7 @@ |e1071 |1.7-17 |2025-12-18 |CRAN (R 4.5.2) | |easystats |0.7.5 |2025-07-11 |CRAN (R 4.5.0) | |ellipsis |0.3.2 |2021-04-29 |CRAN (R 4.5.0) | -|emmeans |2.0.2 |2026-03-05 |CRAN (R 4.5.2) | +|emmeans |2.0.1 |2025-12-16 |CRAN (R 4.5.2) | |esquisse |2.1.0 |2025-02-21 |CRAN (R 4.5.0) | |estimability |1.5.1 |2024-05-12 |CRAN (R 4.5.0) | |eulerr |7.0.4 |2025-09-24 |CRAN (R 4.5.0) | @@ -74,6 +77,7 @@ |farver |2.1.2 |2024-05-13 |CRAN (R 4.5.0) | |fastmap |1.2.0 |2024-05-15 |CRAN (R 4.5.0) | |flextable |0.9.11 |2026-02-13 |CRAN (R 4.5.2) | +|fontawesome |0.5.3 |2024-11-16 |CRAN (R 4.5.0) | |fontBitstreamVera |0.1.1 |2017-02-01 |CRAN (R 4.5.0) | |fontLiberation |0.1.0 |2016-10-15 |CRAN (R 4.5.0) | |fontquiver |0.2.1 |2017-02-01 |CRAN (R 4.5.0) | @@ -109,9 +113,11 @@ |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) | +|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.5.0) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.0) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | +|labeling |0.4.3 |2023-08-29 |CRAN (R 4.5.0) | |later |1.4.8 |2026-03-05 |CRAN (R 4.5.2) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) | |lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) | @@ -123,7 +129,7 @@ |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | -|mvtnorm |1.3-5 |2026-03-11 |CRAN (R 4.5.2) | +|mvtnorm |1.3-2 |2024-11-04 |CRAN (R 4.5.2) | |NHANES |2.1.0 |2015-07-02 |CRAN (R 4.5.0) | |nlme |3.1-168 |2025-03-31 |CRAN (R 4.5.0) | |nloptr |2.2.1 |2025-03-17 |CRAN (R 4.5.0) | @@ -156,6 +162,7 @@ |R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) | |ragg |1.5.1 |2026-03-06 |CRAN (R 4.5.2) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) | +|rappdirs |0.3.4 |2026-01-17 |CRAN (R 4.5.2) | |rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) | |Rcpp |1.1.1 |2026-01-10 |CRAN (R 4.5.2) | @@ -197,6 +204,7 @@ |stringr |1.6.0 |2025-11-04 |CRAN (R 4.5.0) | |stRoke |25.9.2 |2025-09-30 |CRAN (R 4.5.0) | |systemfonts |1.3.2 |2026-03-05 |CRAN (R 4.5.2) | +|testthat |3.3.2 |2026-01-11 |CRAN (R 4.5.2) | |textshaping |1.0.5 |2026-03-06 |CRAN (R 4.5.2) | |thematic |0.1.8 |2025-09-29 |CRAN (R 4.5.0) | |tibble |3.3.1 |2026-01-11 |CRAN (R 4.5.2) | @@ -208,7 +216,9 @@ |twosamples |2.0.1 |2023-06-23 |CRAN (R 4.5.0) | |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.5.0) | |usethis |3.2.1 |2025-09-06 |CRAN (R 4.5.0) | +|utf8 |1.2.6 |2025-06-08 |CRAN (R 4.5.0) | |uuid |1.2-2 |2026-01-23 |CRAN (R 4.5.2) | +|V8 |8.0.1 |2025-10-10 |CRAN (R 4.5.0) | |vctrs |0.7.1 |2026-01-23 |CRAN (R 4.5.2) | |viridis |0.6.5 |2024-01-29 |CRAN (R 4.5.0) | |viridisLite |0.4.3 |2026-02-04 |CRAN (R 4.5.2) | diff --git a/man/data-plots.Rd b/man/data-plots.Rd index e5f94f58..cd9efdfd 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -170,6 +170,8 @@ mtcars |> mtcars |> default_parsing() |> plot_sankey("cyl", "gear", "vs", color.group = "pri") + + # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") mtcars |> plot_scatter(pri = "mpg", sec = "wt") mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") } From 2d062e0ac5f11fb609010ae5ce9ec3758bbfdaa0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 23 Mar 2026 14:29:53 +0100 Subject: [PATCH 22/62] feat: sankey plotting supports logicals and missing values --- R/plot_sankey.R | 49 ++-- app_docker/app.R | 466 ++++++++++++++++++++++++++++++----- inst/apps/FreesearchR/app.R | 468 +++++++++++++++++++++++++++++++----- 3 files changed, 843 insertions(+), 140 deletions(-) diff --git a/R/plot_sankey.R b/R/plot_sankey.R index baa864dd..4fd879b8 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -87,6 +87,7 @@ str_remove_last <- function(data, pattern = "\n") { #' plot_sankey("cyl", "gear", "vs", color.group = "pri") #' #' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") +#' # stRoke::trial |> plot_sankey("active", "male") plot_sankey <- function(data, pri, sec, @@ -152,41 +153,49 @@ plot_sankey_single <- function(data, ...) { color.group <- match.arg(color.group) - - # browser() - # if (is.na(ds[c(pri,sec)])) - - # browser() data_orig <- data - data[c(pri, sec)] <- data[c(pri, sec)] |> - dplyr::mutate( - dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop), - dplyr::across(dplyr::where(is.factor), \(.x) { - forcats::fct_na_value_to_level(.x, missing.level) - }) - ) + data[c(pri, sec)] <- with_labels(data,{ + data[c(pri, sec)] |> + dplyr::mutate( + dplyr::across(dplyr::where(is.logical), as.factor), + dplyr::across(dplyr::where(is.factor), forcats::fct_drop), + dplyr::across(dplyr::where(is.factor), \(.x) { + if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.level) else .x + }) + ) + }) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) + + ## Aggregate data + data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...) na.color <- "#2986cc" box.color <- "#1E4B66" if (is.null(colors)) { if (color.group == "sec") { + if (anyNA(data_orig[[sec]])){ main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) + } else { + main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) + } ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] + main.colors <- main.colors[match(levels(data[[sec]]), levels(data[[sec]]))] secondary.colors <- rep(na.color, length(levels(data[[pri]]))) label.colors <- Reduce(c, lapply(list( secondary.colors, rev(main.colors) ), contrast_text)) } else { - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) + if (anyNA(data_orig[[sec]])){ + main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) + } else { + main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) + } + # main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] + main.colors <- main.colors[match(levels(data[[pri]]), levels(data[[pri]]))] secondary.colors <- rep(na.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list( @@ -199,11 +208,13 @@ plot_sankey_single <- function(data, label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |> + group_labels <- c(get_label(data, pri), get_label(data, sec)) |> sapply(line_break) |> unname() - p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) + # browser() + + p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) if (color.group == "sec") { p <- p + diff --git a/app_docker/app.R b/app_docker/app.R index 1355da88..7d30c295 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpZZ6Yua/file58174f49b1bf.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprPVhaz/file70562aff8e9e.R ######## i18n_path <- here::here("translations") @@ -4514,7 +4514,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.4-260312' +hosted_version <- function()'v26.3.4-260323' ######## @@ -5964,6 +5964,8 @@ landing_page_ui <- function(i18n) { #' @param data_limit_default default data set observations limit #' @param data_limit_upper data set observations upper limit #' @param data_limit_lower data set observations lower limit +#' @param check_app_version always attempt to check app version against latest +#' release on GitHub. Default is FALSE #' @param ... passed on to `shiny::runApp()` #' #' @returns shiny app @@ -5978,12 +5980,14 @@ launch_FreesearchR <- function(include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 100000, data_limit_lower = 1, + check_app_version = FALSE, ...) { Sys.setenv( INCLUDE_GLOBALENV = include_globalenv, DATA_LIMIT_DEFAULT = data_limit_default, DATA_LIMIT_UPPER = data_limit_upper, - DATA_LIMIT_LOWER = data_limit_lower + DATA_LIMIT_LOWER = data_limit_lower, + CHECK_APP_VERSION = check_app_version ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") @@ -7054,15 +7058,17 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { dplyr::ungroup() if (numbers == "count") { - out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) - ) + out <- out |> dplyr::mutate(lx = factor(paste0( + !!dplyr::sym(pri), "\n(n=", gx.sum, ")" + )), ly = factor(paste0( + !!dplyr::sym(sec), "\n(n=", gy.sum, ")" + ))) } else if (numbers == "percentage") { - out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) - ) + out <- out |> dplyr::mutate(lx = factor(paste0( + !!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)" + )), ly = factor(paste0( + !!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)" + ))) } if (is.factor(data[[pri]])) { @@ -7104,20 +7110,38 @@ str_remove_last <- function(data, pattern = "\n") { #' mtcars |> #' default_parsing() |> #' plot_sankey("cyl", "gear", "vs", color.group = "pri") -plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL,missing.level="Missing") { +#' +#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") +plot_sankey <- function(data, + pri, + sec, + ter = NULL, + color.group = "pri", + colors = NULL, + missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { ds <- list(data) } - out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors,missing.level=missing.level) + + out <- lapply(ds, \(.ds) { + plot_sankey_single( + .ds, + pri = pri, + sec = sec, + color.group = color.group, + colors = colors, + missing.level = missing.level + ) }) patchwork::wrap_plots(out) } + + #' Beautiful sankey plot #' #' @param color.group set group to colour by. "x" or "y". @@ -7144,19 +7168,31 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") -plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL,missing.level="Missing", ...) { +plot_sankey_single <- function(data, + pri, + sec, + color.group = c("pri", "sec"), + colors = NULL, + missing.level = "Missing", + ...) { color.group <- match.arg(color.group) + + # browser() + # if (is.na(ds[c(pri,sec)])) + # browser() data_orig <- data + data[c(pri, sec)] <- data[c(pri, sec)] |> dplyr::mutate( - # dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop)#, - # dplyr::across(dplyr::where(is.factor), \(.x){forcats::fct_na_value_to_level(.x,missing.level)}) + dplyr::across(dplyr::where(is.logical), as.factor), + dplyr::across(dplyr::where(is.factor), forcats::fct_drop), + dplyr::across(dplyr::where(is.factor), \(.x) { + forcats::fct_na_value_to_level(.x, missing.level) + }) ) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) na.color <- "#2986cc" @@ -7169,21 +7205,26 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] secondary.colors <- rep(na.color, length(levels(data[[pri]]))) - label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) + label.colors <- Reduce(c, lapply(list( + secondary.colors, rev(main.colors) + ), contrast_text)) } else { main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) ## Only keep colors for included levels main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] secondary.colors <- rep(na.color, length(levels(data[[sec]]))) - label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) + label.colors <- Reduce(c, lapply(list( + rev(main.colors), secondary.colors + ), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) + colors[is.na(colors)] <- "grey80" } else { label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, pri), get_label(data, sec)) |> + group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |> sapply(line_break) |> unname() @@ -7202,9 +7243,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co knot.pos = 0.4, curve_type = "sigmoid" ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), - size = 2, - width = 1 / 3.4 - ) + size = 2, + width = 1 / 3.4) } else { p <- p + ggalluvial::geom_alluvium( @@ -7217,9 +7257,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co knot.pos = 0.4, curve_type = "sigmoid" ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), - size = 2, - width = 1 / 3.4 - ) + size = 2, + width = 1 / 3.4) } ## Will fail to use stat="stratum" if library is not loaded. @@ -7229,13 +7268,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co stat = "stratum", ggplot2::aes(label = after_stat(stratum)), colour = label.colors, - size = 8, + size = 6, lineheight = 1 ) + - ggplot2::scale_x_continuous( - breaks = 1:2, - labels = group_labels - ) + + ggplot2::scale_x_continuous(breaks = 1:2, labels = group_labels) + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + # ggplot2::scale_color_manual(values = main.colors) + ggplot2::theme_void() + @@ -10772,6 +10808,7 @@ ui_elements <- function(selection) { ## Default just output "NULL" ## This could probably be achieved more legantly, but this works. dev_banner(), + version_banner, landing_page_ui(i18n = i18n), # shiny::column(width = 2), # shiny::column( @@ -12832,33 +12869,6 @@ validation_server <- function(id, data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data) - # observeEvent(data_r(), { - # to_validate <- data() - # valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col) - # - # if (all(c(valid_dims$nrows, valid_dims$ncols))) { - # valid_status <- "OK" - # } else { - # valid_status <- "Failed" - # } - # - # valid_results <- lapply( - # X = c("nrows", "ncols"), - # FUN = function(x) { - # if (is.null(valid_dims[[x]])) - # return(NULL) - # label <- switch( - # x, - # "nrows" = n_row_label, - # "ncols" = n_col_label - # ) - # list( - # status = ifelse(valid_dims[[x]], "OK", "Failed"), - # label = paste0("", label, "") - # ) - # } - # ) - shiny::observeEvent( data_r(), { @@ -13242,6 +13252,337 @@ make_validation_alerts <- function(data) { } +######## +#### Current file: /Users/au301842/FreesearchR/R//version_check.R +######## + +# version_check.R +# +# Runs a one-time version check at app startup and returns a ready-made +# shinyWidgets::alert() UI element that can be placed directly in the UI +# definition -- no server(), no renderUI(), no uiOutput() required. +# +# Because the check runs outside server(), it executes once when the app +# process starts, so the banner is present immediately on first render with +# no loading delay. +# +# Version detection uses two strategies, tried in order: +# 1. utils::packageVersion() -- works when the package is installed locally. +# 2. app_version argument -- explicit fallback for environments where the +# package is not installed (e.g. shinyapps.io). Pass the result of your +# app_version() function here. +# +# Quick start: +# +# # global.R (or top of app.R, before ui / server) +# source("version_check.R") +# version_banner <- check_app_version( +# github_user = "your-github-username", +# github_repo = "your-repo-name", +# app_version = app_version() # fallback for shinyapps.io +# ) +# +# # ui.R -- drop the result anywhere in the UI tree +# fluidPage( +# version_banner, +# ... +# ) +# +# # Verbose / debug mode -- always show the banner: +# version_banner <- check_app_version( +# github_user = "your-github-username", +# github_repo = "your-repo-name", +# app_version = app_version(), +# verbose = TRUE +# ) + + +# -- Internal helpers ---------------------------------------------------------- + +#' Check internet connectivity +#' +#' @return Logical; TRUE if an internet connection is available. +.has_internet <- function() { + tryCatch({ + con <- url("https://api.github.com", open = "r") + close(con) + TRUE + }, error = function(e) FALSE) +} + + +#' Fetch the latest release version from a GitHub repository +#' +#' @param github_user GitHub username or organisation. +#' @param github_repo Repository name. +#' +#' @return A character string with the version tag (e.g. "1.2.0"), or NULL on +#' failure. +.get_latest_github_version <- function(github_user, github_repo) { + api_url <- sprintf( + "https://api.github.com/repos/%s/%s/releases/latest", + github_user, + github_repo + ) + + tryCatch({ + response <- readLines(url(api_url), warn = FALSE) + json_text <- paste(response, collapse = "") + + tag <- regmatches( + json_text, + regexpr('"tag_name"\\s*:\\s*"([^"]+)"', json_text) + ) + + if (length(tag) == 0 || nchar(tag) == 0) return(NULL) + + # Strip a leading "v" if present (e.g. "v1.2.0" -> "1.2.0") + sub('^"tag_name"\\s*:\\s*"v?([^"]+)"$', "\\1", tag) + }, error = function(e) NULL) +} + + +#' Resolve the current app version +#' +#' Tries two strategies in order: +#' \enumerate{ +#' \item \code{utils::packageVersion(package_name)} -- works when the package +#' is installed locally (development, local \code{runApp()}). +#' \item \code{app_version} argument -- an explicit version string supplied by +#' the caller, e.g. from an \code{app_version()} function bundled with the +#' app. Used on shinyapps.io where the package is not installed. +#' } +#' +#' @param package_name Name of the package / repository. +#' @param app_version Optional fallback version string. +#' +#' @return A character string with the version (e.g. "1.1.0"), or NULL if +#' neither strategy succeeds. +.resolve_app_version <- function(package_name, app_version = NULL) { + + # Strategy 1: installed package + v <- tryCatch( + as.character(utils::packageVersion(package_name)), + error = function(e) NULL + ) + if (!is.null(v)) { + message("[version_check] Version source: installed package") + return(v) + } + + # Strategy 2: explicit fallback supplied by the caller + if (!is.null(app_version)) { + message("[version_check] Version source: app_version() fallback") + return(as.character(app_version)) + } + + NULL +} + + +#' Build a shinyWidgets::alert() UI element for the version banner +#' +#' @param current Current installed version string. +#' @param latest Latest GitHub release version string, or NULL when +#' the check could not complete (e.g. no internet). +#' @param update_available Logical; whether latest > current. +#' @param github_user GitHub username / organisation. +#' @param github_repo Repository name. +#' +#' @return A \code{shinyWidgets::alert()} UI element. +.build_version_alert <- function(current, + latest, + update_available, + github_user, + github_repo) { + + repo_url <- sprintf( + "https://github.com/%s/%s/releases/latest", + github_user, + github_repo + ) + + if (is.null(latest)) { + # Version check could not complete (no internet or API failure) + return( + shinyWidgets::alert( + tags$b("Version check failed. "), + sprintf( + "Running version %s. Could not reach GitHub to check for updates.", + current + ), + status = "warning", + dismissible = TRUE + ) + ) + } + + if (update_available) { + shinyWidgets::alert( + tags$b("Update available! "), + sprintf( + "You are running version %s. Version %s is available on GitHub.", + current, latest + ), + " ", + tags$a(href = repo_url, target = "_blank", "View release"), + status = "warning", + dismissible = TRUE + ) + } else { + # Up to date -- only shown in verbose mode + shinyWidgets::alert( + tags$b("Up to date. "), + sprintf( + "You are running version %s, which matches the latest release (%s).", + current, latest + ), + status = "success", + dismissible = TRUE + ) + } +} + + +# -- Public API ---------------------------------------------------------------- + +#' Run a startup version check and return a banner UI element +#' +#' Call this \strong{outside} \code{server()} -- typically in +#' \code{global.R} or at the top of \code{app.R} -- and embed the returned +#' value directly in your UI definition. Because the check runs at startup +#' the banner is present on first render with no loading delay, and no +#' \code{uiOutput()} / \code{renderUI()} wiring is needed. +#' +#' \strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when +#' a newer version is available or when the check fails. Returns \code{NULL} +#' when the app is up to date (Shiny silently ignores \code{NULL} in the UI). +#' +#' \strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a +#' banner -- including a success banner when up to date -- so you can confirm +#' the check ran and inspect both version strings during development. +#' +#' @param github_user GitHub username or organisation that owns the repository. +#' @param github_repo Repository name. Also used as the package name for +#' \code{utils::packageVersion()}. +#' @param app_version Optional fallback version string for environments where +#' the package is not installed (e.g. shinyapps.io). Pass the result of your +#' \code{app_version()} function here. Ignored when \code{packageVersion()} +#' succeeds. +#' @param verbose Logical; if \code{TRUE} a banner is always returned. +#' Defaults to \code{FALSE}. +#' +#' @return A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there +#' is nothing to show (up to date in non-verbose mode). +#' +#' @examples +#' \dontrun{ +#' # global.R or top of app.R +#' source("version_check.R") +#' version_banner <- check_app_version( +#' github_user = "my-org", +#' github_repo = "my-shiny-app", +#' app_version = app_version() # fallback for shinyapps.io +#' ) +#' +#' # ui.R +#' fluidPage( +#' version_banner, +#' # ... rest of UI +#' ) +#' +#' # Verbose mode for development +#' version_banner <- check_app_version( +#' github_user = "my-org", +#' github_repo = "my-shiny-app", +#' app_version = app_version(), +#' verbose = TRUE +#' ) +#' } +check_app_version <- function(github_user, + github_repo, + app_version = NULL, + verbose = FALSE) { + + # -- 1. Resolve current version ---------------------------------------------- + local_version <- .resolve_app_version(github_repo, app_version) + if (is.null(local_version)) { + message(sprintf( + "[version_check] Could not determine version for '%s' (package not installed and no app_version() fallback supplied).", + github_repo + )) + return(NULL) + } + + message(sprintf("[version_check] Current version: %s", local_version)) + + # -- 2. Internet check ------------------------------------------------------- + if (!.has_internet()) { + message("[version_check] No internet connection detected -- skipping.") + + if (verbose) { + return(.build_version_alert( + current = local_version, + latest = NULL, + update_available = FALSE, + github_user = github_user, + github_repo = github_repo + )) + } + + return(NULL) + } + + # -- 3. Fetch latest GitHub release ------------------------------------------ + latest_version <- .get_latest_github_version(github_user, github_repo) + if (is.null(latest_version)) { + message("[version_check] Could not retrieve latest version from GitHub.") + + if (verbose) { + return(.build_version_alert( + current = local_version, + latest = NULL, + update_available = FALSE, + github_user = github_user, + github_repo = github_repo + )) + } + + return(NULL) + } + + message(sprintf("[version_check] Latest GitHub release: %s", latest_version)) + + # -- 4. Compare versions ----------------------------------------------------- + update_available <- numeric_version(latest_version) > numeric_version(local_version) + + if (update_available) { + message(sprintf( + "[version_check] Update available: %s -> %s", + local_version, latest_version + )) + } else { + message(sprintf("[version_check] App is up to date (%s).", local_version)) + } + + # -- 5. Return banner -------------------------------------------------------- + # An update was found -> always return a warning banner + # Up to date + verbose -> return a success banner + # Up to date + not verbose -> return NULL (Shiny ignores NULL in the UI) + if (update_available || verbose) { + .build_version_alert( + current = local_version, + latest = latest_version, + update_available = update_available, + github_user = github_user, + github_repo = github_repo + ) + } else { + NULL + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//visual_summary.R ######## @@ -13714,6 +14055,7 @@ INCLUDE_GLOBALENV <- get_config("INCLUDE_GLOBALENV", default = FALSE) DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000) DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000) DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) +CHECK_APP_VERSION <- get_config("CHECK_APP_VERSION", default = FALSE) ## Loads folder passed to the docker container and mounted as below: ## @@ -13726,6 +14068,10 @@ DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) ## All files in the ./data/ folder is attempted loaded load_folder() +## App version check + +version_banner <- check_app_version("agdamsbo", "FreesearchR",app_version = app_version(),verbose=CHECK_APP_VERSION) + ######## #### Current file: /Users/au301842/FreesearchR/app/ui.R diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 2ee84131..68fad36f 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//RtmpmhqokQ/file1a147dcf977e.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprPVhaz/file70565b30c8af.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.3' +app_version <- function()'26.3.4' ######## @@ -4514,7 +4514,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.3-260312' +hosted_version <- function()'v26.3.4-260323' ######## @@ -5964,6 +5964,8 @@ landing_page_ui <- function(i18n) { #' @param data_limit_default default data set observations limit #' @param data_limit_upper data set observations upper limit #' @param data_limit_lower data set observations lower limit +#' @param check_app_version always attempt to check app version against latest +#' release on GitHub. Default is FALSE #' @param ... passed on to `shiny::runApp()` #' #' @returns shiny app @@ -5978,12 +5980,14 @@ launch_FreesearchR <- function(include_globalenv = TRUE, data_limit_default = 1000, data_limit_upper = 100000, data_limit_lower = 1, + check_app_version = FALSE, ...) { Sys.setenv( INCLUDE_GLOBALENV = include_globalenv, DATA_LIMIT_DEFAULT = data_limit_default, DATA_LIMIT_UPPER = data_limit_upper, - DATA_LIMIT_LOWER = data_limit_lower + DATA_LIMIT_LOWER = data_limit_lower, + CHECK_APP_VERSION = check_app_version ) appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") @@ -7054,15 +7058,17 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { dplyr::ungroup() if (numbers == "count") { - out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) - ) + out <- out |> dplyr::mutate(lx = factor(paste0( + !!dplyr::sym(pri), "\n(n=", gx.sum, ")" + )), ly = factor(paste0( + !!dplyr::sym(sec), "\n(n=", gy.sum, ")" + ))) } else if (numbers == "percentage") { - out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) - ) + out <- out |> dplyr::mutate(lx = factor(paste0( + !!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)" + )), ly = factor(paste0( + !!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)" + ))) } if (is.factor(data[[pri]])) { @@ -7104,20 +7110,38 @@ str_remove_last <- function(data, pattern = "\n") { #' mtcars |> #' default_parsing() |> #' plot_sankey("cyl", "gear", "vs", color.group = "pri") -plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL,missing.level="Missing") { +#' +#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") +plot_sankey <- function(data, + pri, + sec, + ter = NULL, + color.group = "pri", + colors = NULL, + missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { ds <- list(data) } - out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors,missing.level=missing.level) + + out <- lapply(ds, \(.ds) { + plot_sankey_single( + .ds, + pri = pri, + sec = sec, + color.group = color.group, + colors = colors, + missing.level = missing.level + ) }) patchwork::wrap_plots(out) } + + #' Beautiful sankey plot #' #' @param color.group set group to colour by. "x" or "y". @@ -7144,19 +7168,31 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") -plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL,missing.level="Missing", ...) { +plot_sankey_single <- function(data, + pri, + sec, + color.group = c("pri", "sec"), + colors = NULL, + missing.level = "Missing", + ...) { color.group <- match.arg(color.group) + + # browser() + # if (is.na(ds[c(pri,sec)])) + # browser() data_orig <- data + data[c(pri, sec)] <- data[c(pri, sec)] |> dplyr::mutate( - # dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop)#, - # dplyr::across(dplyr::where(is.factor), \(.x){forcats::fct_na_value_to_level(.x,missing.level)}) + dplyr::across(dplyr::where(is.logical), as.factor), + dplyr::across(dplyr::where(is.factor), forcats::fct_drop), + dplyr::across(dplyr::where(is.factor), \(.x) { + forcats::fct_na_value_to_level(.x, missing.level) + }) ) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) na.color <- "#2986cc" @@ -7169,21 +7205,26 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] secondary.colors <- rep(na.color, length(levels(data[[pri]]))) - label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) + label.colors <- Reduce(c, lapply(list( + secondary.colors, rev(main.colors) + ), contrast_text)) } else { main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) ## Only keep colors for included levels main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] secondary.colors <- rep(na.color, length(levels(data[[sec]]))) - label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) + label.colors <- Reduce(c, lapply(list( + rev(main.colors), secondary.colors + ), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) + colors[is.na(colors)] <- "grey80" } else { label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, pri), get_label(data, sec)) |> + group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |> sapply(line_break) |> unname() @@ -7202,9 +7243,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co knot.pos = 0.4, curve_type = "sigmoid" ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), - size = 2, - width = 1 / 3.4 - ) + size = 2, + width = 1 / 3.4) } else { p <- p + ggalluvial::geom_alluvium( @@ -7217,9 +7257,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co knot.pos = 0.4, curve_type = "sigmoid" ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), - size = 2, - width = 1 / 3.4 - ) + size = 2, + width = 1 / 3.4) } ## Will fail to use stat="stratum" if library is not loaded. @@ -7229,13 +7268,10 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co stat = "stratum", ggplot2::aes(label = after_stat(stratum)), colour = label.colors, - size = 8, + size = 6, lineheight = 1 ) + - ggplot2::scale_x_continuous( - breaks = 1:2, - labels = group_labels - ) + + ggplot2::scale_x_continuous(breaks = 1:2, labels = group_labels) + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + # ggplot2::scale_color_manual(values = main.colors) + ggplot2::theme_void() + @@ -10772,6 +10808,7 @@ ui_elements <- function(selection) { ## Default just output "NULL" ## This could probably be achieved more legantly, but this works. dev_banner(), + version_banner, landing_page_ui(i18n = i18n), # shiny::column(width = 2), # shiny::column( @@ -12832,33 +12869,6 @@ validation_server <- function(id, data_r <- if (shiny::is.reactive(data)) data else shiny::reactive(data) - # observeEvent(data_r(), { - # to_validate <- data() - # valid_dims <- check_data(to_validate, n_row = n_row, n_col = n_col) - # - # if (all(c(valid_dims$nrows, valid_dims$ncols))) { - # valid_status <- "OK" - # } else { - # valid_status <- "Failed" - # } - # - # valid_results <- lapply( - # X = c("nrows", "ncols"), - # FUN = function(x) { - # if (is.null(valid_dims[[x]])) - # return(NULL) - # label <- switch( - # x, - # "nrows" = n_row_label, - # "ncols" = n_col_label - # ) - # list( - # status = ifelse(valid_dims[[x]], "OK", "Failed"), - # label = paste0("", label, "") - # ) - # } - # ) - shiny::observeEvent( data_r(), { @@ -13242,6 +13252,337 @@ make_validation_alerts <- function(data) { } +######## +#### Current file: /Users/au301842/FreesearchR/R//version_check.R +######## + +# version_check.R +# +# Runs a one-time version check at app startup and returns a ready-made +# shinyWidgets::alert() UI element that can be placed directly in the UI +# definition -- no server(), no renderUI(), no uiOutput() required. +# +# Because the check runs outside server(), it executes once when the app +# process starts, so the banner is present immediately on first render with +# no loading delay. +# +# Version detection uses two strategies, tried in order: +# 1. utils::packageVersion() -- works when the package is installed locally. +# 2. app_version argument -- explicit fallback for environments where the +# package is not installed (e.g. shinyapps.io). Pass the result of your +# app_version() function here. +# +# Quick start: +# +# # global.R (or top of app.R, before ui / server) +# source("version_check.R") +# version_banner <- check_app_version( +# github_user = "your-github-username", +# github_repo = "your-repo-name", +# app_version = app_version() # fallback for shinyapps.io +# ) +# +# # ui.R -- drop the result anywhere in the UI tree +# fluidPage( +# version_banner, +# ... +# ) +# +# # Verbose / debug mode -- always show the banner: +# version_banner <- check_app_version( +# github_user = "your-github-username", +# github_repo = "your-repo-name", +# app_version = app_version(), +# verbose = TRUE +# ) + + +# -- Internal helpers ---------------------------------------------------------- + +#' Check internet connectivity +#' +#' @return Logical; TRUE if an internet connection is available. +.has_internet <- function() { + tryCatch({ + con <- url("https://api.github.com", open = "r") + close(con) + TRUE + }, error = function(e) FALSE) +} + + +#' Fetch the latest release version from a GitHub repository +#' +#' @param github_user GitHub username or organisation. +#' @param github_repo Repository name. +#' +#' @return A character string with the version tag (e.g. "1.2.0"), or NULL on +#' failure. +.get_latest_github_version <- function(github_user, github_repo) { + api_url <- sprintf( + "https://api.github.com/repos/%s/%s/releases/latest", + github_user, + github_repo + ) + + tryCatch({ + response <- readLines(url(api_url), warn = FALSE) + json_text <- paste(response, collapse = "") + + tag <- regmatches( + json_text, + regexpr('"tag_name"\\s*:\\s*"([^"]+)"', json_text) + ) + + if (length(tag) == 0 || nchar(tag) == 0) return(NULL) + + # Strip a leading "v" if present (e.g. "v1.2.0" -> "1.2.0") + sub('^"tag_name"\\s*:\\s*"v?([^"]+)"$', "\\1", tag) + }, error = function(e) NULL) +} + + +#' Resolve the current app version +#' +#' Tries two strategies in order: +#' \enumerate{ +#' \item \code{utils::packageVersion(package_name)} -- works when the package +#' is installed locally (development, local \code{runApp()}). +#' \item \code{app_version} argument -- an explicit version string supplied by +#' the caller, e.g. from an \code{app_version()} function bundled with the +#' app. Used on shinyapps.io where the package is not installed. +#' } +#' +#' @param package_name Name of the package / repository. +#' @param app_version Optional fallback version string. +#' +#' @return A character string with the version (e.g. "1.1.0"), or NULL if +#' neither strategy succeeds. +.resolve_app_version <- function(package_name, app_version = NULL) { + + # Strategy 1: installed package + v <- tryCatch( + as.character(utils::packageVersion(package_name)), + error = function(e) NULL + ) + if (!is.null(v)) { + message("[version_check] Version source: installed package") + return(v) + } + + # Strategy 2: explicit fallback supplied by the caller + if (!is.null(app_version)) { + message("[version_check] Version source: app_version() fallback") + return(as.character(app_version)) + } + + NULL +} + + +#' Build a shinyWidgets::alert() UI element for the version banner +#' +#' @param current Current installed version string. +#' @param latest Latest GitHub release version string, or NULL when +#' the check could not complete (e.g. no internet). +#' @param update_available Logical; whether latest > current. +#' @param github_user GitHub username / organisation. +#' @param github_repo Repository name. +#' +#' @return A \code{shinyWidgets::alert()} UI element. +.build_version_alert <- function(current, + latest, + update_available, + github_user, + github_repo) { + + repo_url <- sprintf( + "https://github.com/%s/%s/releases/latest", + github_user, + github_repo + ) + + if (is.null(latest)) { + # Version check could not complete (no internet or API failure) + return( + shinyWidgets::alert( + tags$b("Version check failed. "), + sprintf( + "Running version %s. Could not reach GitHub to check for updates.", + current + ), + status = "warning", + dismissible = TRUE + ) + ) + } + + if (update_available) { + shinyWidgets::alert( + tags$b("Update available! "), + sprintf( + "You are running version %s. Version %s is available on GitHub.", + current, latest + ), + " ", + tags$a(href = repo_url, target = "_blank", "View release"), + status = "warning", + dismissible = TRUE + ) + } else { + # Up to date -- only shown in verbose mode + shinyWidgets::alert( + tags$b("Up to date. "), + sprintf( + "You are running version %s, which matches the latest release (%s).", + current, latest + ), + status = "success", + dismissible = TRUE + ) + } +} + + +# -- Public API ---------------------------------------------------------------- + +#' Run a startup version check and return a banner UI element +#' +#' Call this \strong{outside} \code{server()} -- typically in +#' \code{global.R} or at the top of \code{app.R} -- and embed the returned +#' value directly in your UI definition. Because the check runs at startup +#' the banner is present on first render with no loading delay, and no +#' \code{uiOutput()} / \code{renderUI()} wiring is needed. +#' +#' \strong{Normal mode} (\code{verbose = FALSE}): returns a banner only when +#' a newer version is available or when the check fails. Returns \code{NULL} +#' when the app is up to date (Shiny silently ignores \code{NULL} in the UI). +#' +#' \strong{Verbose / debug mode} (\code{verbose = TRUE}): always returns a +#' banner -- including a success banner when up to date -- so you can confirm +#' the check ran and inspect both version strings during development. +#' +#' @param github_user GitHub username or organisation that owns the repository. +#' @param github_repo Repository name. Also used as the package name for +#' \code{utils::packageVersion()}. +#' @param app_version Optional fallback version string for environments where +#' the package is not installed (e.g. shinyapps.io). Pass the result of your +#' \code{app_version()} function here. Ignored when \code{packageVersion()} +#' succeeds. +#' @param verbose Logical; if \code{TRUE} a banner is always returned. +#' Defaults to \code{FALSE}. +#' +#' @return A \code{shinyWidgets::alert()} UI element, or \code{NULL} when there +#' is nothing to show (up to date in non-verbose mode). +#' +#' @examples +#' \dontrun{ +#' # global.R or top of app.R +#' source("version_check.R") +#' version_banner <- check_app_version( +#' github_user = "my-org", +#' github_repo = "my-shiny-app", +#' app_version = app_version() # fallback for shinyapps.io +#' ) +#' +#' # ui.R +#' fluidPage( +#' version_banner, +#' # ... rest of UI +#' ) +#' +#' # Verbose mode for development +#' version_banner <- check_app_version( +#' github_user = "my-org", +#' github_repo = "my-shiny-app", +#' app_version = app_version(), +#' verbose = TRUE +#' ) +#' } +check_app_version <- function(github_user, + github_repo, + app_version = NULL, + verbose = FALSE) { + + # -- 1. Resolve current version ---------------------------------------------- + local_version <- .resolve_app_version(github_repo, app_version) + if (is.null(local_version)) { + message(sprintf( + "[version_check] Could not determine version for '%s' (package not installed and no app_version() fallback supplied).", + github_repo + )) + return(NULL) + } + + message(sprintf("[version_check] Current version: %s", local_version)) + + # -- 2. Internet check ------------------------------------------------------- + if (!.has_internet()) { + message("[version_check] No internet connection detected -- skipping.") + + if (verbose) { + return(.build_version_alert( + current = local_version, + latest = NULL, + update_available = FALSE, + github_user = github_user, + github_repo = github_repo + )) + } + + return(NULL) + } + + # -- 3. Fetch latest GitHub release ------------------------------------------ + latest_version <- .get_latest_github_version(github_user, github_repo) + if (is.null(latest_version)) { + message("[version_check] Could not retrieve latest version from GitHub.") + + if (verbose) { + return(.build_version_alert( + current = local_version, + latest = NULL, + update_available = FALSE, + github_user = github_user, + github_repo = github_repo + )) + } + + return(NULL) + } + + message(sprintf("[version_check] Latest GitHub release: %s", latest_version)) + + # -- 4. Compare versions ----------------------------------------------------- + update_available <- numeric_version(latest_version) > numeric_version(local_version) + + if (update_available) { + message(sprintf( + "[version_check] Update available: %s -> %s", + local_version, latest_version + )) + } else { + message(sprintf("[version_check] App is up to date (%s).", local_version)) + } + + # -- 5. Return banner -------------------------------------------------------- + # An update was found -> always return a warning banner + # Up to date + verbose -> return a success banner + # Up to date + not verbose -> return NULL (Shiny ignores NULL in the UI) + if (update_available || verbose) { + .build_version_alert( + current = local_version, + latest = latest_version, + update_available = update_available, + github_user = github_user, + github_repo = github_repo + ) + } else { + NULL + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//visual_summary.R ######## @@ -13714,6 +14055,7 @@ INCLUDE_GLOBALENV <- get_config("INCLUDE_GLOBALENV", default = FALSE) DATA_LIMIT_DEFAULT <- get_config("DATA_LIMIT_DEFAULT", default = 10000) DATA_LIMIT_UPPER <- get_config("DATA_LIMIT_UPPER", default = 100000) DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) +CHECK_APP_VERSION <- get_config("CHECK_APP_VERSION", default = FALSE) ## Loads folder passed to the docker container and mounted as below: ## @@ -13726,6 +14068,10 @@ DATA_LIMIT_LOWER <- get_config("DATA_LIMIT_LOWER", default = 1) ## All files in the ./data/ folder is attempted loaded load_folder() +## App version check + +version_banner <- check_app_version("agdamsbo", "FreesearchR",app_version = app_version(),verbose=CHECK_APP_VERSION) + ######## #### Current file: /Users/au301842/FreesearchR/app/ui.R From 6c850847b755ac2d4d29f7c2d5fa685a22c522a8 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 24 Mar 2026 12:04:54 +0100 Subject: [PATCH 23/62] feat: added option to choose color palettes for all available plots. this includes a custom function to generate colors from several palettes as well as a select function to include color previews. --- R/custom_SelectInput.R | 197 ++++++++++++++++++---- R/data_plots.R | 265 ++++++++++++++++-------------- R/generate_colors.R | 237 ++++++++++++++++++++++++++ R/plot_bar.R | 12 +- R/plot_box.R | 12 +- R/plot_euler.R | 14 +- R/plot_hbar.R | 44 +++-- R/plot_ridge.R | 3 +- R/plot_sankey.R | 112 ++++++++----- R/plot_scatter.R | 6 +- R/plot_violin.R | 10 +- man/colorSelectInput.Rd | 72 ++++++++ man/continuous_colors.Rd | 44 +++++ man/data-plots.Rd | 53 ++++-- man/generate_colors.Rd | 63 +++++++ man/plot_euler.Rd | 2 +- man/plot_euler_single.Rd | 4 +- man/plot_sankey_single.Rd | 10 ++ man/scale_fill_generate.Rd | 45 +++++ man/vertical_stacked_bars.Rd | 4 +- tests/testthat/test-plot_colors.R | 146 ++++++++++++++++ 21 files changed, 1107 insertions(+), 248 deletions(-) create mode 100644 R/generate_colors.R create mode 100644 man/colorSelectInput.Rd create mode 100644 man/continuous_colors.Rd create mode 100644 man/generate_colors.Rd create mode 100644 man/scale_fill_generate.Rd create mode 100644 tests/testthat/test-plot_colors.R diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index 6c7a55c9..8ac469be 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -20,30 +20,36 @@ #' @importFrom shiny selectizeInput #' @export #' -columnSelectInput <- function( - inputId, - label, - data, - selected = "", - ..., - col_subset = NULL, - placeholder = "", - onInitialize, - none_label = "No variable selected", - maxItems = NULL -) { - datar <- if (is.reactive(data)) data else reactive(data) - col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) +columnSelectInput <- function(inputId, + label, + data, + selected = "", + ..., + col_subset = NULL, + placeholder = "", + onInitialize, + none_label = "No variable selected", + maxItems = NULL) { + datar <- if (is.reactive(data)) + data + else + reactive(data) + col_subsetr <- if (is.reactive(col_subset)) + col_subset + else + reactive(col_subset) labels <- Map(function(col) { json <- sprintf( - IDEAFilter:::strip_leading_ws(' + IDEAFilter:::strip_leading_ws( + ' { "name": "%s", "label": "%s", "dataclass": "%s", "datatype": "%s" - }'), + }' + ), col, attr(datar()[[col]], "label") %||% "", IDEAFilter:::get_dataFilter_class(datar()[[col]]), @@ -52,12 +58,25 @@ columnSelectInput <- function( }, col = names(datar())) if (!"none" %in% names(datar())) { - labels <- c("none" = list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', none_label)), labels) + labels <- c("none" = list( + sprintf( + '\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', + none_label + ) + ), labels) choices <- setNames(names(labels), labels) - choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] + choices <- choices[match(if (length(col_subsetr()) == 0 || + isTRUE(col_subsetr() == "")) + names(datar()) + else + col_subsetr(), choices)] } else { choices <- setNames(names(datar()), labels) - choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] + choices <- choices[match(if (length(col_subsetr()) == 0 || + isTRUE(col_subsetr() == "")) + choices + else + col_subsetr(), choices)] } shiny::selectizeInput( @@ -66,8 +85,9 @@ columnSelectInput <- function( choices = choices, selected = selected, ..., - options = c( - list(render = I("{ + options = c(list( + render = I( + "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); @@ -95,9 +115,10 @@ columnSelectInput <- function( escape(item.data.name) + ''; } - }")), - if (!is.null(maxItems)) list(maxItems = maxItems) - ) + }" + ) + ), if (!is.null(maxItems)) + list(maxItems = maxItems)) ) } @@ -150,7 +171,10 @@ vectorSelectInput <- function(inputId, ..., placeholder = "", onInitialize) { - datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices) + datar <- if (shiny::is.reactive(choices)) + data + else + shiny::reactive(choices) labels <- sprintf( IDEAFilter:::strip_leading_ws(' @@ -170,8 +194,9 @@ vectorSelectInput <- function(inputId, choices = choices_new, selected = selected, ..., - options = c( - list(render = I("{ + options = c(list( + render = I( + "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); @@ -190,7 +215,123 @@ vectorSelectInput <- function(inputId, escape(item.data.name) + ''; } - }")) + }" + ) + )) + ) +} + + +#' A selectizeInput customized for named vectors of color names supported by +#' \code{\link{generate_colors}} +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param choices A named \code{vector} from which fields should be populated +#' @param selected default selection +#' @param previews number of preview colors. Default is 4. +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' +#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element +#' @export +#' +#' @examples +#' if (shiny::interactive()) { +#'top_palettes <- c( +#'"Perceptual (blue-yellow)" = "viridis", +#'"Perceptual (fire)" = "plasma", +#'"Colour-blind friendly" = "Okabe-Ito", +#'"Qualitative (bold)" = "Dark 2", +#'"Qualitative (paired)" = "Paired", +#'"Sequential (blues)" = "Blues", +#'"Diverging (red-blue)" = "RdBu", +#'"Tableau style" = "Tableau 10", +#'"Pastel" = "Pastel 1", +#'"Rainbow" = "rainbow" +#') +#' shinyApp( +#' ui = fluidPage( +#' titlePanel("Color Palette Select Test"), +#' colorSelectInput( +#' inputId = "palette", +#' label = "Color palette", +#' choices = top_palettes, +#' selected = "viridis" +#' ), +#' verbatimTextOutput("selected") +#' ), +#' server = function(input, output, session) { +#' output$selected <- renderPrint(input$palette) +#' } +#' ) +#' } +colorSelectInput <- function(inputId, + label, + choices, + selected = "", + previews = 4, + ..., + placeholder = "") { + vals <- if (shiny::is.reactive(choices)) { + choices() + } else{ + choices + } + + swatch_html <- function(palette_name) { + colors <- tryCatch( + suppressMessages(generate_colors(previews, palette_name)), + error = function(e) + rep("#cccccc", 3) + ) + # Strip alpha channel to ensure valid 6-digit CSS hex + colors <- substr(colors, 1, 7) + paste0( + sprintf( + "", + colors + ), + collapse = "" + ) + } + + labels <- sprintf( + '{"name": "%s", "label": "%s", "swatch": "%s"}', + vals, + names(vals) %||% "", + vapply(vals, swatch_html, character(1)) + ) + + choices_new <- stats::setNames(vals, labels) + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices_new, + selected = selected, + ..., + options = list( + render = I( + "{ + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" + ) ) ) } diff --git a/R/data_plots.R b/R/data_plots.R index 0d72e998..cd590cce 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -22,11 +22,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { title = "Create plot", icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), - shiny::helpText(i18n$t('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.')), + shiny::helpText( + i18n$t( + 'Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.' + ) + ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), shiny::uiOutput(outputId = ns("secondary")), shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("color_palette")), shiny::br(), shiny::actionButton( inputId = ns("act_plot"), @@ -72,14 +77,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::selectInput( inputId = ns("plot_type"), label = i18n$t("File format"), - choices = list( - "png", - "tiff", - "eps", - "pdf", - "jpeg", - "svg" - ) + choices = list("png", "tiff", "eps", "pdf", "jpeg", "svg") ), shiny::br(), # Button @@ -90,12 +88,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ) ) ), - shiny::p("We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", - "View notes in new tab", - target = "_blank", - rel = "noopener noreferrer" - )) + shiny::p( + "We have collected a few notes on visualising data and details on the options included in FreesearchR:", + shiny::tags$a( + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + "View notes in new tab", + target = "_blank", + rel = "noopener noreferrer" + ) + ) ), shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), @@ -116,21 +117,37 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @export data_visuals_server <- function(id, data, + palettes = c( + "Perceptual (blue-yellow)" = "viridis", + "Perceptual (fire)" = "plasma", + "Colour-blind friendly" = "Okabe-Ito", + "Qualitative (bold)" = "Dark 2", + "Qualitative (paired)" = "Paired", + "Sequential (blues)" = "Blues", + "Diverging (red-blue)" = "RdBu", + "Tableau style" = "Tableau 10", + "Pastel" = "Pastel 1", + "Rainbow" = "rainbow" + ), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { ns <- session$ns - rv <- shiny::reactiveValues( - plot.params = NULL, - plot = NULL, - code = NULL - ) + rv <- shiny::reactiveValues(plot.params = NULL, + plot = NULL, + code = NULL) shiny::observe({ - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_plot",title = i18n$t("Create plot")) - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_download",title = i18n$t("Download")) + bslib::accordion_panel_update( + id = "acc_plot", + target = "acc_pan_plot", + title = i18n$t("Create plot") + ) + bslib::accordion_panel_update(id = "acc_plot", + target = "acc_pan_download", + title = i18n$t("Download")) }) # ## --- New attempt @@ -259,12 +276,10 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots( - data = plot_data - ) + plots <- possible_plots(data = plot_data) plots_named <- get_plot_options(plots) |> - lapply(\(.x){ + lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) @@ -284,23 +299,19 @@ data_visuals_server <- function(id, output$secondary <- shiny::renderUI({ shiny::req(input$type) - cols <- c( - rv$plot.params()[["secondary.extra"]], - all_but( - colnames(subset_types( - data(), - rv$plot.params()[["secondary.type"]] - )), - input$primary - ) - ) + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) columnSelectInput( inputId = ns("secondary"), data = data, selected = cols[1], placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) i18n$t("Additional variables") else i18n$t("Secondary variable"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), multiple = rv$plot.params()[["secondary.multi"]], maxItems = rv$plot.params()[["secondary.max"]], col_subset = cols, @@ -319,10 +330,7 @@ data_visuals_server <- function(id, col_subset = c( "none", all_but( - colnames(subset_types( - data(), - rv$plot.params()[["tertiary.type"]] - )), + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), input$primary, input$secondary ) @@ -331,64 +339,59 @@ data_visuals_server <- function(id, ) }) - shiny::observeEvent(input$act_plot, - { - if (NROW(data()) > 0) { - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary - ) + ### Color option + output$color_palette <- shiny::renderUI({ + # shiny::req(input$type) + colorSelectInput( + inputId = ns("color_palette"), + label = i18n$t("Choose color palette"), + choices = palettes + ) + }) - ## If the dictionary holds additional arguments to pass to the - ## plotting function, these are included - if (!is.null(rv$plot.params()[["fun.args"]])){ - parameters <- modifyList(parameters,rv$plot.params()[["fun.args"]]) - } - - shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), { - rv$plot <- rlang::exec( - create_plot, - !!!append_list( - data(), - parameters, - "data" - ) - ) - }) - - rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") - }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - error = function(err) { - showNotification(paste0(err), type = "err") - } + shiny::observeEvent(input$act_plot, { + if (NROW(data()) > 0) { + tryCatch({ + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary, + color.palette = input$color_palette ) - } - }, - ignoreInit = TRUE - ) + + ## If the dictionary holds additional arguments to pass to the + ## plotting function, these are included + if (!is.null(rv$plot.params()[["fun.args"]])) { + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + } + + shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), + { + rv$plot <- rlang::exec(create_plot, + !!!append_list(data(), parameters, "data")) + }) + + rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") + }, # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + }) + } + }, ignoreInit = TRUE) output$code_plot <- shiny::renderUI({ shiny::req(rv$code) prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code)) }) - shiny::observeEvent( - list( - data() - ), - { - shiny::req(data()) + shiny::observeEvent(list(data()), { + shiny::req(data()) - rv$plot <- NULL - } - ) + rv$plot <- NULL + }) output$plot <- shiny::renderPlot({ # shiny::req(rv$plot) @@ -428,16 +431,15 @@ data_visuals_server <- function(id, width = input$width, height = input$height_slide, dpi = 300, - units = "mm", scale = 2 + units = "mm", + scale = 2 ) }) } ) - shiny::observe( - return(rv$plot) - ) + shiny::observe(return(rv$plot)) } ) } @@ -500,9 +502,11 @@ supported_plots <- function() { list( plot_bar_rel = list( fun = "plot_bar", - fun.args =list(style="fill"), + fun.args = list(style = "fill"), descr = i18n$t("Stacked relative barplot"), - note = i18n$t("Create relative stacked barplots to show the distribution of categorical levels"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -511,9 +515,11 @@ supported_plots <- function() { ), plot_bar_abs = list( fun = "plot_bar", - fun.args =list(style="dodge"), + fun.args = list(style = "dodge"), descr = i18n$t("Side-by-side barplot"), - note = i18n$t("Create side-by-side barplot to show the distribution of categorical levels"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -523,7 +529,9 @@ supported_plots <- function() { plot_hbars = list( fun = "plot_hbars", descr = i18n$t("Stacked horizontal bars"), - note = i18n$t("A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -533,7 +541,9 @@ supported_plots <- function() { plot_violin = list( fun = "plot_violin", descr = i18n$t("Violin plot"), - note = i18n$t("A modern alternative to the classic boxplot to visualise data distribution"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), primary.type = c("datatime", "continuous"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -581,7 +591,9 @@ supported_plots <- function() { plot_euler = list( fun = "plot_euler", descr = i18n$t("Euler diagram"), - note = i18n$t("Generate area-proportional Euler diagrams to display set relationships"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), primary.type = c("dichotomous"), secondary.type = c("dichotomous"), secondary.multi = TRUE, @@ -622,7 +634,7 @@ possible_plots <- function(data) { out <- type } else { out <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { if (type %in% .x$primary.type) { .x$descr } @@ -650,12 +662,12 @@ possible_plots <- function(data) { #' get_plot_options() get_plot_options <- function(data) { descrs <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { .x$descr }) |> unlist() supported_plots() |> - (\(.x){ + (\(.x) { .x[match(data, descrs)] })() } @@ -669,6 +681,7 @@ get_plot_options <- function(data) { #' @param sec secondary variable #' @param ter tertiary variable #' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. #' @param ... ignored for now #' #' @name data-plots @@ -678,7 +691,13 @@ get_plot_options <- function(data) { #' #' @examples #' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, type, pri, sec, ter = NULL, ...) { +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { if (!is.null(sec)) { if (!any(sec %in% names(data))) { sec <- NULL @@ -695,13 +714,11 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) { pri = pri, sec = sec, ter = ter, + color.palette = color.palette, ... ) - out <- do.call( - type, - modifyList(parameters, list(data = data)) - ) + out <- do.call(type, modifyList(parameters, list(data = data))) code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") @@ -758,10 +775,14 @@ get_label <- function(data, var = NULL) { #' @examples #' "Lorem ipsum... you know the routine" |> line_break() #' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, lineLength = 20, force = FALSE) { +line_break <- function(data, + lineLength = 20, + force = FALSE) { if (isTRUE(force)) { ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) } else { paste(strwrap(data, lineLength), collapse = "\n") } @@ -793,9 +814,9 @@ wrap_plot_list <- function(data, if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { out <- data |> - (\(.x){ + (\(.x) { if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i){ + purrr::imap(.x, \(.y, .i) { .y + ggplot2::ggtitle(.i) }) } else { @@ -803,12 +824,10 @@ wrap_plot_list <- function(data, } })() |> align_axes() |> - patchwork::wrap_plots( - guides = guides, - axes = axes, - axis_titles = axis_titles, - ... - ) + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) if (!is.null(tag_levels)) { out <- out + patchwork::plot_annotation(tag_levels = tag_levels) } @@ -847,7 +866,9 @@ wrap_plot_list <- function(data, #' @returns list of ggplot2 objects #' @export #' -align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -865,7 +886,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x){ + purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -889,7 +910,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { clean_common_axis <- function(p, axis) { purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> unlist() |> - (\(.x){ + (\(.x) { if (is.numeric(.x)) { range(.x) } else { diff --git a/R/generate_colors.R b/R/generate_colors.R new file mode 100644 index 00000000..ae9fa869 --- /dev/null +++ b/R/generate_colors.R @@ -0,0 +1,237 @@ +#' Generate N Colors from a Specified Color Palette +#' +#' A flexible wrapper around multiple color palette libraries, returning N +#' colors as a character vector of hex codes. Supports palettes from +#' \pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}. +#' +#' @param n \code{integer}. Number of colors to generate. Must be a positive +#' integer. +#' @param palette \code{character(1)}. Name of the color palette to use. +#' Case-insensitive. Supported options: +#' \describe{ +#' \item{\strong{viridisLite}}{`"viridis"`, `"magma"`, `"plasma"`, +#' `"inferno"`, `"cividis"`, `"mako"`, `"rocket"`, `"turbo"`} +#' \item{\strong{grDevices}}{`"hcl"`, `"rainbow"`, `"heat"`, +#' `"terrain"`, `"topo"`} +#' \item{\strong{RColorBrewer}}{Any palette name from +#' \code{RColorBrewer::brewer.pal.info}, e.g. `"Set1"`, `"Blues"`, +#' `"Dark2"`. If \code{n} exceeds the palette maximum, colors are +#' interpolated via \code{\link[grDevices]{colorRampPalette}}.} +#' } +#' @param ... Additional arguments passed to the underlying palette function. +#' For example, \code{alpha}, \code{direction}, \code{begin}, \code{end} +#' are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is +#' forwarded to \code{\link[grDevices]{hcl.colors}}. +#' +#' @return A \code{character} vector of length \code{n} containing hex color +#' codes (e.g. \code{"#440154FF"}). +#' +#' @examples +#' # viridisLite palettes +#' generate_colors(5, "viridis") +#' generate_colors(5, "plasma") +#' generate_colors(5, "viridis", alpha = 0.8, direction = -1) +#' +#' # Base R grDevices +#' generate_colors(5, "rainbow") +#' generate_colors(8, "hcl", palette = "Dark 3") +#' +#' # RColorBrewer +#' generate_colors(5, "Set1") +#' generate_colors(5, "Blues") +#' generate_colors(12, "Set1") # interpolates beyond palette max of 9 +#' +#' # Drop-in replacement for viridisLite::viridis() +#' # generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis") +#' +#' @seealso +#' \code{\link[viridisLite]{viridis}}, +#' \code{\link[grDevices]{hcl.colors}}, +#' \code{\link[RColorBrewer]{brewer.pal}} +#' +#' @importFrom viridisLite viridis +#' @importFrom grDevices hcl.colors rainbow heat.colors terrain.colors +#' topo.colors colorRampPalette +#' @importFrom RColorBrewer brewer.pal brewer.pal.info +#' +#' @export +generate_colors <- function(n, palette = "viridis", ...) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + + # Function passthrough — call directly with n and ... + if (is.function(palette)) { + return(palette(n, ...)) + } + + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + + palette_lower <- tolower(palette) + + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) + + if (palette_lower %in% viridis_palettes) { + viridisLite::viridis(n = n, option = palette_lower, ...) + + } else if (palette_lower == "hcl") { + grDevices::hcl.colors(n = n, ...) + + } else if (palette_lower == "rainbow") { + grDevices::rainbow(n = n, ...) + + } else if (palette_lower == "heat") { + grDevices::heat.colors(n = n, ...) + + } else if (palette_lower == "terrain") { + grDevices::terrain.colors(n = n, ...) + + } else if (palette_lower == "topo") { + grDevices::topo.colors(n = n, ...) + + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) + } +} + + +#' Create a Continuous Color Function from a Palette +#' +#' Wraps \code{\link{generate_colors}} into a function that accepts a value +#' between 0 and 1 and returns the corresponding color. Useful for mapping +#' continuous variables to colors. +#' +#' @param palette Passed directly to [generate_colors()]. Either a palette +#' name string or a function. +#' @param n \code{integer}. Resolution of the underlying color ramp — higher +#' values give smoother gradients. Defaults to 256. +#' @param ... Additional arguments passed to [generate_colors()]. +#' +#' @return A function that takes a numeric vector of values in \code{[0, 1]} +#' and returns a character vector of hex colors. +#' +#' @examples +#' pal <- continuous_colors("viridis") +#' pal(0) # first color +#' pal(1) # last color +#' pal(0.5) # midpoint +#' +#' # Map a continuous variable to colors +#' values <- seq(0, 1, length.out = 10) +#' pal(values) +#' +#' # Works with any palette generate_colors() accepts +#' pal <- continuous_colors("plasma", direction = -1) +#' pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red")) +#' +#' @seealso [generate_colors()] +#' @export +continuous_colors <- function(palette = "viridis", n = 256, ...) { + colors <- generate_colors(n, palette, ...) + ramp <- grDevices::colorRamp(colors) + + function(x) { + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") + rgb_vals <- ramp(x) + grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) + } +} + + +#' Discrete and Continuous Fill Scale Using generate_colors +#' +#' Drop-in replacement for [viridis::scale_fill_viridis()] that works with +#' any palette supported by [generate_colors()]. +#' +#' @param palette Passed to [generate_colors()]. Either a palette name string +#' or a function. +#' @param discrete \code{logical}. If \code{TRUE} (default), a discrete scale +#' is returned. If \code{FALSE}, a continuous scale is returned. +#' @param ... Additional arguments passed to [ggplot2::scale_fill_manual()] +#' (discrete) or [ggplot2::scale_fill_gradientn()] (continuous). +#' +#' @examples +#' library(ggplot2) +#' +#' # Discrete +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) + +#' geom_col() + +#' scale_fill_generate(palette = "Set1") +#' +#' # Continuous +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) + +#' geom_point(shape = 21, size = 3) + +#' scale_fill_generate(palette = "viridis", discrete = FALSE) +#' +#' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] +#' @export +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "fill", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} + +#' @rdname scale_fill_generate +#' @examples +#' ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) + +#' geom_point() + +#' scale_color_generate(palette = "Set1") +#' @export +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "colour", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} diff --git a/R/plot_bar.R b/R/plot_bar.R index 4e76550d..909c9edd 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -1,4 +1,5 @@ -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), max_level = 30, ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -13,7 +14,8 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi pri = pri, sec = sec, style = style, - max_level = max_level + max_level = max_level, + color.palette = color.palette ) }) @@ -38,8 +40,9 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar_single(pri = "cyl", style = "stack") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30) { +#' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, + color.palette = "viridis") { style <- match.arg(style) if (identical(sec, "none")) { @@ -98,6 +101,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " ) + ggplot2::geom_bar(position = style, stat = "identity") + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + ggplot2::ylab("Percentage") + ggplot2::xlab(get_label(data,pri))+ ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) diff --git a/R/plot_box.R b/R/plot_box.R index 072a8095..01911aac 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -20,7 +20,7 @@ #' mtcars |> #' default_parsing() |> #' plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") -plot_box <- function(data, pri, sec, ter = NULL,...) { +plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -31,7 +31,8 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { plot_box_single( data = .ds, pri = pri, - sec = sec + sec = sec, + color.palette=color.palette ) }) @@ -48,9 +49,10 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { #' #' @examples #' mtcars |> plot_box_single("mpg") -#' mtcars |> plot_box_single("mpg","cyl") +#' mtcars |> plot_box_single("mpg","cyl",color.palette="Blues") +#' stRoke::trial |> plot_box_single("age","active",color.palette="Blues") #' gtsummary::trial |> plot_box_single("age","trt") -plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { +plot_box_single <- function(data, pri, sec=NULL, seed = 2103,color.palette="viridis") { set.seed(seed) if (is.null(sec)) { @@ -68,7 +70,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { ggplot2::xlab(get_label(data,pri))+ ggplot2::ylab(get_label(data,sec)) + ggplot2::coord_flip() + - viridis::scale_fill_viridis(discrete = discrete, option = "D") + + scale_fill_generate(discrete = discrete,palette = color.palette) + # ggplot2::theme_void() + ggplot2::theme_bw(base_size = 24) + ggplot2::theme( diff --git a/R/plot_euler.R b/R/plot_euler.R index 17345020..27cdf02f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -102,7 +102,7 @@ ggeulerr <- function( #' plot_euler("mfi_cut", "mdi_cut") #' stRoke::trial |> #' plot_euler(pri="male", sec=c("hypertension")) -plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="viridis") { set.seed(seed = seed) if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -112,7 +112,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { out <- lapply(ds, \(.x){ .x[c(pri, sec)] |> na.omit() |> - plot_euler_single() + plot_euler_single(color.palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) @@ -130,16 +130,12 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { #' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() -#' mtcars[c("vs", "am")] |> plot_euler_single() -plot_euler_single <- function(data) { - # if (any("categorical" %in% data_type(data))){ - # shape <- "ellipse" - # } else { - # shape <- "circle" - # } +#' mtcars[c("vs", "am")] |> plot_euler_single("magma") +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + + scale_fill_generate(palette=color.palette) + ggplot2::theme_void() + ggplot2::theme( legend.position = "none", diff --git a/R/plot_hbar.R b/R/plot_hbar.R index 5e71d745..0a0ec320 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -8,11 +8,21 @@ #' @examples #' mtcars |> plot_hbars(pri = "carb", sec = "cyl") #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_hbars(pri = "carb", sec = NULL) -plot_hbars <- function(data, pri, sec, ter = NULL) { - out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) - - out +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") +plot_hbars <- function(data, + pri, + sec, + ter = NULL, + color.palette = "viridis") { + vertical_stacked_bars( + data = data, + score = pri, + group = sec, + strata = ter, + color.palette = color.palette + ) } @@ -35,7 +45,9 @@ vertical_stacked_bars <- function(data, l.color = "black", l.size = .5, draw.lines = TRUE, - label.str="{n}\n{round(100 * p,0)}%") { + label.str = "{n}\n{round(100 * p,0)}%", + color.palette = "viridis", + reverse = TRUE) { if (is.null(group)) { df.table <- data[c(score, group, strata)] |> dplyr::mutate("All" = 1) |> @@ -60,15 +72,19 @@ vertical_stacked_bars <- function(data, returnData = TRUE ) - colors <- viridisLite::viridis(nrow(df.table)) + colors <- generate_colors(n = nrow(df.table), palette = color.palette) + ## Colors are reversed by default as that usually gives the best result + if (isTRUE(reverse)) { + colors <- rev(colors) + } contrast_cut <- - sum(contrast_text(colors, threshold = .3) == "white") + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) p |> - (\(.x){ + (\(.x) { .x$plot + ggplot2::geom_text( data = .x$rectData[which(.x$rectData$n > @@ -78,20 +94,18 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = as.numeric(score) > contrast_cut, + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) ) ) + ggplot2::labs(fill = score_label) + - ggplot2::scale_fill_manual(values = rev(colors)) + - ggplot2::theme( - legend.position = "bottom", - axis.title = ggplot2::element_text(), + ggplot2::scale_fill_manual(values = colors) + + ggplot2::theme(legend.position = "bottom", + axis.title = ggplot2::element_text(), ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) - # viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D") })() } diff --git a/R/plot_ridge.R b/R/plot_ridge.R index cff6c29b..ba7a3da5 100644 --- a/R/plot_ridge.R +++ b/R/plot_ridge.R @@ -10,7 +10,7 @@ #' default_parsing() |> #' plot_ridge(x = "mpg", y = "cyl") #' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") -plot_ridge <- function(data, x, y, z = NULL, ...) { +plot_ridge <- function(data, x, y, z = NULL, color.palette="viridis", ...) { if (!is.null(z)) { ds <- split(data, data[z]) } else { @@ -21,6 +21,7 @@ plot_ridge <- function(data, x, y, z = NULL, ...) { ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) + ggridges::geom_density_ridges() + ggridges::theme_ridges() + + scale_fill_generate(palette=color.palette) + ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa() }) diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 4fd879b8..23c1a13a 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -19,7 +19,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(pri, sec)] <- data[c(pri, sec)] |> + data <- data[c(pri, sec)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE) @@ -84,16 +84,17 @@ str_remove_last <- function(data, pattern = "\n") { #' ## Dont know why... #' mtcars |> #' default_parsing() |> -#' plot_sankey("cyl", "gear", "vs", color.group = "pri") -#' -#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") -#' # stRoke::trial |> plot_sankey("active", "male") +#' plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno") plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL, + color.palette = "viridis", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -101,12 +102,14 @@ plot_sankey <- function(data, ds <- list(data) } + # browser() out <- lapply(ds, \(.ds) { plot_sankey_single( .ds, pri = pri, sec = sec, + color.palette = color.palette, color.group = color.group, colors = colors, missing.level = missing.level @@ -144,12 +147,22 @@ plot_sankey <- function(data, #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") +#' +#' +#' # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma") +#' # stRoke::trial |> plot_sankey_single("active", "male") +#' # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec") +#' # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo") plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), - colors = NULL, + color.palette = "viridis", + colors=NULL, missing.level = "Missing", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", ...) { color.group <- match.arg(color.group) @@ -157,53 +170,35 @@ plot_sankey_single <- function(data, data[c(pri, sec)] <- with_labels(data,{ data[c(pri, sec)] |> - dplyr::mutate( - dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop), - dplyr::across(dplyr::where(is.factor), \(.x) { - if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.level) else .x - }) - ) + to_clean_levels() |> + missing_to_text_levels(missing.text=missing.level) }) - ## Aggregate data data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...) - na.color <- "#2986cc" - box.color <- "#1E4B66" + default.color = default.color + box.color = box.color + na.color = na.color if (is.null(colors)) { if (color.group == "sec") { - if (anyNA(data_orig[[sec]])){ - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) - } else { - main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) - } - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[sec]]), levels(data[[sec]]))] + main.colors <- color_levels_gen(data_orig[[sec]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + secondary.colors <- rep(default.color, length(levels(data[[pri]]))) label.colors <- Reduce(c, lapply(list( secondary.colors, rev(main.colors) ), contrast_text)) } else { - if (anyNA(data_orig[[sec]])){ - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) - } else { - main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) - } - # main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[pri]]), levels(data[[pri]]))] + main.colors <- color_levels_gen(data_orig[[pri]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + secondary.colors <- rep(default.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list( rev(main.colors), secondary.colors ), contrast_text)) } - colors <- c(na.color, main.colors, secondary.colors) - colors[is.na(colors)] <- "grey80" + colors <- c(default.color, main.colors, secondary.colors) + colors[is.na(colors)] <- na.color } else { label.colors <- contrast_text(colors) } @@ -212,8 +207,6 @@ plot_sankey_single <- function(data, sapply(line_break) |> unname() - # browser() - p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) if (color.group == "sec") { @@ -275,3 +268,48 @@ plot_sankey_single <- function(data, panel.border = ggplot2::element_blank() ) } + + +# stRoke::trial["male"] |> to_clean_levels() +to_clean_levels <- function(data,missing.text="Missing"){ + if (is.data.frame(data)){ + data |> + lapply(all_levels_clean) |> + dplyr::bind_cols() + } else { + data |> + all_levels_clean() + } + + + +} + +# stRoke::trial["mrs_1"] |> missing_to_text_levels() +missing_to_text_levels <- function(data,missing.text="Missing"){ + data |> + dplyr::mutate( + dplyr::across(dplyr::where(is.factor), \(.x) { + if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.text) else .x + }) + ) +} + +all_levels_clean <- function(data){ + data |> + (\(.x){ + if (is.logical(.x)) as.factor(.x) else .x + })() |> + (\(.x){ + if (is.factor(.x)) forcats::fct_drop(.x) else .x + })() +} + +# stRoke::trial$mrs_1 |> color_levels_gen() +color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ + out <- generate_colors(n = length(levels(to_clean_levels(data))),palette = palette) + if (anyNA(data)){ + out <- c(out,na.color) + } + out +} diff --git a/R/plot_scatter.R b/R/plot_scatter.R index c2389b08..142c30fd 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -7,7 +7,8 @@ #' #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") -plot_scatter <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -24,6 +25,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { group = ter, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_color_generate(palette=color.palette) } } diff --git a/R/plot_violin.R b/R/plot_violin.R index 4695f4ab..83d11d2a 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -1,4 +1,4 @@ -#' Beatiful violin plot +#' Beautiful violin plot #' #' @returns ggplot2 object #' @export @@ -6,8 +6,9 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") -plot_violin <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl") +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -23,7 +24,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) { response = pri, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_fill_generate(palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) diff --git a/man/colorSelectInput.Rd b/man/colorSelectInput.Rd new file mode 100644 index 00000000..37561b0f --- /dev/null +++ b/man/colorSelectInput.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_SelectInput.R +\name{colorSelectInput} +\alias{colorSelectInput} +\title{A selectizeInput customized for named vectors of color names supported by +\code{\link{generate_colors}}} +\usage{ +colorSelectInput( + inputId, + label, + choices, + selected = "", + previews = 4, + ..., + placeholder = "" +) +} +\arguments{ +\item{inputId}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{label}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{choices}{A named \code{vector} from which fields should be populated} + +\item{selected}{default selection} + +\item{previews}{number of preview colors. Default is 4.} + +\item{...}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{placeholder}{passed to \code{\link[shiny]{selectizeInput}} options} + +\item{onInitialize}{passed to \code{\link[shiny]{selectizeInput}} options} +} +\value{ +a \code{\link[shiny]{selectizeInput}} dropdown element +} +\description{ +A selectizeInput customized for named vectors of color names supported by +\code{\link{generate_colors}} +} +\examples{ +if (shiny::interactive()) { +top_palettes <- c( +"Perceptual (blue-yellow)" = "viridis", +"Perceptual (fire)" = "plasma", +"Colour-blind friendly" = "Okabe-Ito", +"Qualitative (bold)" = "Dark 2", +"Qualitative (paired)" = "Paired", +"Sequential (blues)" = "Blues", +"Diverging (red-blue)" = "RdBu", +"Tableau style" = "Tableau 10", +"Pastel" = "Pastel 1", +"Rainbow" = "rainbow" +) + shinyApp( + ui = fluidPage( + titlePanel("Color Palette Select Test"), + colorSelectInput( + inputId = "palette", + label = "Color palette", + choices = top_palettes, + selected = "viridis" + ), + verbatimTextOutput("selected") + ), + server = function(input, output, session) { + output$selected <- renderPrint(input$palette) + } + ) +} +} diff --git a/man/continuous_colors.Rd b/man/continuous_colors.Rd new file mode 100644 index 00000000..a9568f11 --- /dev/null +++ b/man/continuous_colors.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate_colors.R +\name{continuous_colors} +\alias{continuous_colors} +\title{Create a Continuous Color Function from a Palette} +\usage{ +continuous_colors(palette = "viridis", n = 256, ...) +} +\arguments{ +\item{palette}{Passed directly to \code{\link[=generate_colors]{generate_colors()}}. Either a palette +name string or a function.} + +\item{n}{\code{integer}. Resolution of the underlying color ramp — higher +values give smoother gradients. Defaults to 256.} + +\item{...}{Additional arguments passed to \code{\link[=generate_colors]{generate_colors()}}.} +} +\value{ +A function that takes a numeric vector of values in \code{[0, 1]} +and returns a character vector of hex colors. +} +\description{ +Wraps \code{\link{generate_colors}} into a function that accepts a value +between 0 and 1 and returns the corresponding color. Useful for mapping +continuous variables to colors. +} +\examples{ +pal <- continuous_colors("viridis") +pal(0) # first color +pal(1) # last color +pal(0.5) # midpoint + +# Map a continuous variable to colors +values <- seq(0, 1, length.out = 10) +pal(values) + +# Works with any palette generate_colors() accepts +pal <- continuous_colors("plasma", direction = -1) +pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red")) + +} +\seealso{ +\code{\link[=generate_colors]{generate_colors()}} +} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index cd9efdfd..5229751a 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -20,25 +20,35 @@ \usage{ data_visuals_ui(id, tab_title = "Plots", ...) -data_visuals_server(id, data, ...) +data_visuals_server( + id, + data, + palettes = c(`Perceptual (blue-yellow)` = "viridis", `Perceptual (fire)` = "plasma", + `Colour-blind friendly` = "Okabe-Ito", `Qualitative (bold)` = "Dark 2", + `Qualitative (paired)` = "Paired", `Sequential (blues)` = "Blues", + `Diverging (red-blue)` = "RdBu", `Tableau style` = "Tableau 10", Pastel = "Pastel 1", + Rainbow = "rainbow"), + ... +) -create_plot(data, type, pri, sec, ter = NULL, ...) +create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) plot_bar_single( data, pri, sec = NULL, style = c("stack", "dodge", "fill"), - max_level = 30 + max_level = 30, + color.palette = "viridis" ) -plot_box(data, pri, sec, ter = NULL, ...) +plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_box_single(data, pri, sec = NULL, seed = 2103) +plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") -plot_hbars(data, pri, sec, ter = NULL) +plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") -plot_ridge(data, x, y, z = NULL, ...) +plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) sankey_ready(data, pri, sec, numbers = "count", ...) @@ -49,12 +59,16 @@ plot_sankey( ter = NULL, color.group = "pri", colors = NULL, + color.palette = "viridis", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", missing.level = "Missing" ) -plot_scatter(data, pri, sec, ter = NULL) +plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis") -plot_violin(data, pri, sec, ter = NULL) +plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis") } \arguments{ \item{id}{Module id. (Use 'ns("id")')} @@ -71,6 +85,8 @@ plot_violin(data, pri, sec, ter = NULL) \item{ter}{tertiary variable} +\item{color.palette}{choose color palette. See \code{\link{plot_colors}} for support.} + \item{style}{barplot style passed to geom_bar position argument. One of c("stack", "dodge", "fill")} } @@ -120,7 +136,7 @@ Beautiful sankey plot with option to split by a tertiary group Beautiful violin plot -Beatiful violin plot +Beautiful violin plot } \examples{ create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() @@ -130,7 +146,7 @@ mtcars |> mtcars |> dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> - plot_bar_single(pri = "cyl", style = "stack") + plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") mtcars |> plot_box(pri = "mpg", sec = "gear") mtcars |> plot_box(pri = "mpg", sec="cyl") mtcars |> @@ -140,11 +156,14 @@ mtcars |> default_parsing() |> plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") mtcars |> plot_box_single("mpg") -mtcars |> plot_box_single("mpg","cyl") +mtcars |> plot_box_single("mpg","cyl",color.palette="Blues") +stRoke::trial |> plot_box_single("age","active",color.palette="Blues") gtsummary::trial |> plot_box_single("age","trt") mtcars |> plot_hbars(pri = "carb", sec = "cyl") mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") -mtcars |> plot_hbars(pri = "carb", sec = NULL) +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") mtcars |> default_parsing() |> plot_ridge(x = "mpg", y = "cyl") @@ -169,9 +188,9 @@ mtcars |> ## Dont know why... mtcars |> default_parsing() |> - plot_sankey("cyl", "gear", "vs", color.group = "pri") - - # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") + plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno") mtcars |> plot_scatter(pri = "mpg", sec = "wt") -mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") +mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") +mtcars |> plot_violin(pri = "mpg", sec = "cyl") +mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") } diff --git a/man/generate_colors.Rd b/man/generate_colors.Rd new file mode 100644 index 00000000..94e3bf27 --- /dev/null +++ b/man/generate_colors.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate_colors.R +\name{generate_colors} +\alias{generate_colors} +\title{Generate N Colors from a Specified Color Palette} +\usage{ +generate_colors(n, palette = "viridis", ...) +} +\arguments{ +\item{n}{\code{integer}. Number of colors to generate. Must be a positive +integer.} + +\item{palette}{\code{character(1)}. Name of the color palette to use. +Case-insensitive. Supported options: +\describe{ +\item{\strong{viridisLite}}{\code{"viridis"}, \code{"magma"}, \code{"plasma"}, +\code{"inferno"}, \code{"cividis"}, \code{"mako"}, \code{"rocket"}, \code{"turbo"}} +\item{\strong{grDevices}}{\code{"hcl"}, \code{"rainbow"}, \code{"heat"}, +\code{"terrain"}, \code{"topo"}} +\item{\strong{RColorBrewer}}{Any palette name from +\code{RColorBrewer::brewer.pal.info}, e.g. \code{"Set1"}, \code{"Blues"}, +\code{"Dark2"}. If \code{n} exceeds the palette maximum, colors are +interpolated via \code{\link[grDevices]{colorRampPalette}}.} +}} + +\item{...}{Additional arguments passed to the underlying palette function. +For example, \code{alpha}, \code{direction}, \code{begin}, \code{end} +are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is +forwarded to \code{\link[grDevices]{hcl.colors}}.} +} +\value{ +A \code{character} vector of length \code{n} containing hex color +codes (e.g. \code{"#440154FF"}). +} +\description{ +A flexible wrapper around multiple color palette libraries, returning N +colors as a character vector of hex codes. Supports palettes from +\pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}. +} +\examples{ +# viridisLite palettes +generate_colors(5, "viridis") +generate_colors(5, "plasma") +generate_colors(5, "viridis", alpha = 0.8, direction = -1) + +# Base R grDevices +generate_colors(5, "rainbow") +generate_colors(8, "hcl", palette = "Dark 3") + +# RColorBrewer +generate_colors(5, "Set1") +generate_colors(5, "Blues") +generate_colors(12, "Set1") # interpolates beyond palette max of 9 + +# Drop-in replacement for viridisLite::viridis() +# generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis") + +} +\seealso{ +\code{\link[viridisLite]{viridis}}, +\code{\link[grDevices]{hcl.colors}}, +\code{\link[RColorBrewer]{brewer.pal}} +} diff --git a/man/plot_euler.Rd b/man/plot_euler.Rd index 4f387162..1713585b 100644 --- a/man/plot_euler.Rd +++ b/man/plot_euler.Rd @@ -4,7 +4,7 @@ \alias{plot_euler} \title{Easily plot euler diagrams} \usage{ -plot_euler(data, pri, sec, ter = NULL, seed = 2103) +plot_euler(data, pri, sec, ter = NULL, seed = 2103, color.palette = "viridis") } \arguments{ \item{data}{data} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd index c41d1166..f481d5af 100644 --- a/man/plot_euler_single.Rd +++ b/man/plot_euler_single.Rd @@ -4,7 +4,7 @@ \alias{plot_euler_single} \title{Easily plot single euler diagrams} \usage{ -plot_euler_single(data) +plot_euler_single(data, color.palette = "viridis") } \value{ ggplot2 object @@ -19,5 +19,5 @@ data.frame( C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) ) |> plot_euler_single() -mtcars[c("vs", "am")] |> plot_euler_single() +mtcars[c("vs", "am")] |> plot_euler_single("magma") } diff --git a/man/plot_sankey_single.Rd b/man/plot_sankey_single.Rd index 3ff729ac..75ee1086 100644 --- a/man/plot_sankey_single.Rd +++ b/man/plot_sankey_single.Rd @@ -9,8 +9,12 @@ plot_sankey_single( pri, sec, color.group = c("pri", "sec"), + color.palette = "viridis", colors = NULL, missing.level = "Missing", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", ... ) } @@ -44,4 +48,10 @@ mtcars |> stRoke::trial |> default_parsing() |> plot_sankey_single("diabetes", "hypertension") + + + # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma") + # stRoke::trial |> plot_sankey_single("active", "male") + # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec") + # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo") } diff --git a/man/scale_fill_generate.Rd b/man/scale_fill_generate.Rd new file mode 100644 index 00000000..c558722e --- /dev/null +++ b/man/scale_fill_generate.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate_colors.R +\name{scale_fill_generate} +\alias{scale_fill_generate} +\alias{scale_color_generate} +\title{Discrete and Continuous Fill Scale Using generate_colors} +\usage{ +scale_fill_generate(palette = "viridis", discrete = TRUE, ...) + +scale_color_generate(palette = "viridis", discrete = TRUE, ...) +} +\arguments{ +\item{palette}{Passed to \code{\link[=generate_colors]{generate_colors()}}. Either a palette name string +or a function.} + +\item{discrete}{\code{logical}. If \code{TRUE} (default), a discrete scale +is returned. If \code{FALSE}, a continuous scale is returned.} + +\item{...}{Additional arguments passed to \code{\link[ggplot2:scale_manual]{ggplot2::scale_fill_manual()}} +(discrete) or \code{\link[ggplot2:scale_gradient]{ggplot2::scale_fill_gradientn()}} (continuous).} +} +\description{ +Drop-in replacement for \code{\link[viridis:scale_viridis]{viridis::scale_fill_viridis()}} that works with +any palette supported by \code{\link[=generate_colors]{generate_colors()}}. +} +\examples{ +library(ggplot2) + +# Discrete +ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) + + geom_col() + + scale_fill_generate(palette = "Set1") + +# Continuous +ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) + + geom_point(shape = 21, size = 3) + + scale_fill_generate(palette = "viridis", discrete = FALSE) + +ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) + + geom_point() + + scale_color_generate(palette = "Set1") +} +\seealso{ +\code{\link[=scale_color_generate]{scale_color_generate()}}, \code{\link[=generate_colors]{generate_colors()}}, \code{\link[=continuous_colors]{continuous_colors()}} +} diff --git a/man/vertical_stacked_bars.Rd b/man/vertical_stacked_bars.Rd index 52f3c5c0..495588fe 100644 --- a/man/vertical_stacked_bars.Rd +++ b/man/vertical_stacked_bars.Rd @@ -13,7 +13,9 @@ vertical_stacked_bars( l.color = "black", l.size = 0.5, draw.lines = TRUE, - label.str = "{n}\\n{round(100 * p,0)}\%" + label.str = "{n}\\n{round(100 * p,0)}\%", + color.palette = "viridis", + reverse = TRUE ) } \arguments{ diff --git a/tests/testthat/test-plot_colors.R b/tests/testthat/test-plot_colors.R new file mode 100644 index 00000000..c37ea166 --- /dev/null +++ b/tests/testthat/test-plot_colors.R @@ -0,0 +1,146 @@ +library(testthat) + +# ── Helpers ─────────────────────────────────────────────────────────────────── + +is_hex_color <- function(x) { + all(grepl("^#[0-9A-Fa-f]{6}([0-9A-Fa-f]{2})?$", x)) +} + +# ── Input validation ────────────────────────────────────────────────────────── + +test_that("n must be a single positive integer", { + expect_error(generate_colors(0), "`n` must be a single positive integer") + expect_error(generate_colors(-1), "`n` must be a single positive integer") + expect_error(generate_colors(1.5), "`n` must be a single positive integer") + expect_error(generate_colors(c(2, 3)), "`n` must be a single positive integer") + expect_error(generate_colors("5"), "`n` must be a single positive integer") +}) + +test_that("palette must be a single character string or function", { + expect_error(generate_colors(5, 123), "`palette` must be a single character string") + expect_error(generate_colors(5, c("a", "b")), "`palette` must be a single character string") +}) + +test_that("unknown palette falls back to hcl.colors with a message", { + expect_message( + result <- generate_colors(5, "notapalette"), + "Unknown palette: 'notapalette'" + ) + expect_equal(length(result), 5) + expect_true(is_hex_color(result)) +}) + +# ── Return type and length ──────────────────────────────────────────────────── + +test_that("output is a character vector of correct length for each palette family", { + palettes <- c("viridis", "plasma", "rainbow", "heat", "terrain", "topo", "Set1", "Blues") + for (pal in palettes) { + result <- generate_colors(5, pal) + expect_true(is.character(result), label = paste0("is.character [", pal, "]")) + expect_equal(length(result), 5, label = paste0("length == 5 [", pal, "]")) + } +}) + +test_that("output colors are valid hex codes", { + palettes <- c("viridis", "magma", "rainbow", "hcl", "Set1", "Blues") + for (pal in palettes) { + result <- generate_colors(5, pal) + expect_true(is_hex_color(result), label = paste0("hex check [", pal, "]")) + } +}) + +test_that("n = 1 works for all palette families", { + expect_equal(length(generate_colors(1, "viridis")), 1) + expect_equal(length(generate_colors(1, "rainbow")), 1) + expect_equal(length(generate_colors(1, "Set1")), 1) +}) + +# ── viridisLite ─────────────────────────────────────────────────────────────── + +test_that("all viridisLite palettes return correct length", { + viridis_palettes <- c("viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo") + for (pal in viridis_palettes) { + expect_equal(length(generate_colors(6, pal)), 6, label = paste0("length [", pal, "]")) + } +}) + +test_that("viridisLite palette names are case-insensitive", { + expect_equal(generate_colors(5, "VIRIDIS"), generate_colors(5, "viridis")) + expect_equal(generate_colors(5, "Plasma"), generate_colors(5, "plasma")) +}) + +test_that("extra args are forwarded to viridisLite (direction)", { + fwd <- generate_colors(5, "viridis", direction = 1) + rev <- generate_colors(5, "viridis", direction = -1) + expect_false(identical(fwd, rev)) +}) + +# ── grDevices ───────────────────────────────────────────────────────────────── + +test_that("grDevices palettes return correct length", { + for (pal in c("hcl", "rainbow", "heat", "terrain", "topo")) { + expect_equal(length(generate_colors(7, pal)), 7, label = paste0("length [", pal, "]")) + } +}) + +test_that("grDevices palette names are case-insensitive", { + expect_equal(generate_colors(5, "Rainbow"), generate_colors(5, "rainbow")) + expect_equal(generate_colors(5, "HEAT"), generate_colors(5, "heat")) +}) + +# ── RColorBrewer ────────────────────────────────────────────────────────────── + +test_that("RColorBrewer returns exactly n colors for any n >= 1", { + expect_equal(length(generate_colors(1, "Set1")), 1) # below brewer min, slices + expect_equal(length(generate_colors(2, "Set1")), 2) # below brewer min, slices + expect_equal(length(generate_colors(3, "Set1")), 3) # at brewer min + expect_equal(length(generate_colors(9, "Set1")), 9) # at brewer max + expect_equal(length(generate_colors(15, "Set1")), 15) # above brewer max, interpolates +}) + +test_that("RColorBrewer n < 3 does not warn or error", { + expect_no_warning(generate_colors(1, "Set1")) + expect_no_warning(generate_colors(2, "Blues")) +}) + +test_that("RColorBrewer output is valid hex for all n", { + expect_true(is_hex_color(generate_colors(1, "Blues"))) + expect_true(is_hex_color(generate_colors(9, "Blues"))) + expect_true(is_hex_color(generate_colors(20, "Blues"))) +}) + +test_that("RColorBrewer sequential and diverging palettes work", { + expect_equal(length(generate_colors(5, "Blues")), 5) + expect_equal(length(generate_colors(5, "RdBu")), 5) +}) + +# ── Function passthrough ────────────────────────────────────────────────────── + +test_that("palette accepts a function directly", { + result <- generate_colors(5, viridisLite::viridis) + expect_equal(length(result), 5) + expect_true(is_hex_color(result)) +}) + +test_that("palette accepts an anonymous function", { + result <- generate_colors(5, \(n) rep("#FF0000FF", n)) + expect_equal(result, rep("#FF0000FF", 5)) +}) + +test_that("error message mentions function as valid input type", { + expect_error(generate_colors(5, 123), "single character string or a function") +}) + +# ── Fallback ────────────────────────────────────────────────────────────────── + +test_that("fallback message includes available options", { + expect_message(generate_colors(5, "notapalette"), "viridisLite") + expect_message(generate_colors(5, "notapalette"), "RColorBrewer") +}) + +test_that("fallback returns correct length and valid hex colors", { + result <- suppressMessages(generate_colors(8, "notapalette")) + expect_equal(length(result), 8) + expect_true(is_hex_color(result)) +}) From 9a223f4c546fb3be7082487ee68228c9097d9db3 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 24 Mar 2026 12:05:16 +0100 Subject: [PATCH 24/62] rerender for publishing --- DESCRIPTION | 1 + NAMESPACE | 14 + NEWS.md | 4 +- R/hosted_version.R | 2 +- R/sysdata.rda | Bin 2731 -> 2685 bytes SESSION.md | 12 +- app_docker/app.R | 925 ++++++++++++++++----- app_docker/translations/translation_da.csv | 7 +- app_docker/translations/translation_sw.csv | 7 +- inst/apps/FreesearchR/app.R | 925 ++++++++++++++++----- inst/translations/translation_da.csv | 7 +- inst/translations/translation_sw.csv | 7 +- 12 files changed, 1427 insertions(+), 484 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5a9d85b9..def9fc81 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -108,6 +108,7 @@ Collate: 'data_plots.R' 'datagrid-infos-mod.R' 'footer_ui.R' + 'generate_colors.R' 'helpers.R' 'hosted_version.R' 'html_dependency_freesearchr.R' diff --git a/NAMESPACE b/NAMESPACE index e7e642c1..97775d14 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,8 +21,10 @@ export(class_icons) export(clean_common_axis) export(clean_date) export(clean_sep) +export(colorSelectInput) export(columnSelectInput) export(compare_missings) +export(continuous_colors) export(contrast_text) export(corr_pairs_validate) export(correlation_pairs) @@ -59,6 +61,7 @@ export(factor_new_levels_labels) export(factorize) export(file_export) export(format_writer) +export(generate_colors) export(get_data_packages) export(get_fun_options) export(get_label) @@ -139,6 +142,8 @@ export(remove_nested_list) export(repeated_instruments) export(restore_labels) export(sankey_ready) +export(scale_color_generate) +export(scale_fill_generate) export(selectInputIcon) export(separate_string) export(set_column_label) @@ -174,9 +179,17 @@ export(winbox_update_factor) export(with_labels) export(wrap_plot_list) export(write_quarto) +importFrom(RColorBrewer,brewer.pal) +importFrom(RColorBrewer,brewer.pal.info) importFrom(classInt,classIntervals) importFrom(data.table,as.data.table) importFrom(data.table,data.table) +importFrom(grDevices,colorRampPalette) +importFrom(grDevices,hcl.colors) +importFrom(grDevices,heat.colors) +importFrom(grDevices,rainbow) +importFrom(grDevices,terrain.colors) +importFrom(grDevices,topo.colors) importFrom(graphics,abline) importFrom(graphics,axis) importFrom(graphics,hist) @@ -239,3 +252,4 @@ importFrom(toastui,renderDatagrid) importFrom(toastui,renderDatagrid2) importFrom(utils,data) importFrom(utils,type.convert) +importFrom(viridisLite,viridis) diff --git a/NEWS.md b/NEWS.md index 3cfed098..3476df1d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,10 @@ # FreesearchR 26.3.4 +*NEW* Color select for plotting across all plots for even more option. Ten palettes have been chosen, to provide varied and interpretable options. The selector will always show a preview of four colors. + *NEW* Added app version check against latest release on GitHub. Only runs if internet connection present. No other polling. -*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size. +*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size. And fixed support for dichotomous data. # FreesearchR 26.3.3 diff --git a/R/hosted_version.R b/R/hosted_version.R index 17135440..6935edfb 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.4-260323' +hosted_version <- function()'v26.3.4-260324' diff --git a/R/sysdata.rda b/R/sysdata.rda index efea72cf58fc1738966ab77c2a0f106f5c8e661a..4e2466e66542431c55aacefa9da334dcbe7447a6 100644 GIT binary patch literal 2685 zcmV-@3WD`QT4*^jL0KkKS(8lDJOCN2f5iX)Xaz!l|KNXb-@w2B|L{Nn00;;H;0ym3 zI~Fa+f#4*l&?Er)=g}onyI@rphNeK783REyGzm7Ej6~W`L@_h~XvhqhAk{nwO#+!T z%~MZknrW$~gFt8i00000YM+UrNl*YZ4FRA40000002&E2k`htrsPuy%)M7Jg001KZ zOln{N0BKD@p`ZZJ02%-Q0002fKma09CWt*uP(33}292lyGyu>BY6C&F0h08qgqX@2 zNMSCZ7Fk3UErKd+YS9s1AHAhO5v@pQ`2M+Z%jjSX92>km1`#(Rml9b(DGfs0Q?+hB z#h2A^MMOqKbMNnQ?%)4tXYO0=_5An`WG)tV`78~6Ul=Jg)II)}RsH#GjN;lSnpN*P z6o?T~7Y!guORqz*oNlXTofK9nTI^akazS+qr+rc=88>a%vSQlGpxUp4dD(fwvnuS4 zP-1m=WOFxiXETwgAqPcJi7DmHb~5KM#qZtwg)M^@K$m_elI3M~T9wGf#I`LW_TU)S z1i7v$gBr0_R8+6`-Lm^KdGB&`qgfiv)4J>Jk~C^JJLKuopkCsoMx_%gW_=~@bAd}` z3B%@OHS3#F=ETEG7p8U|MPqQ%A3ucr35EvUg13RnCOX@r(w&J zE-4RLi>{cB*3{cmr4hT)^OBj&uoD#l{?vbd#gKA;Abh0pt*b3y1_zRAk8TUcA5t)KNsrAc({e0tAGH)dWyl)`%h@ z`+}h8#SjZNWetzOh&cCi7`1=^)`B66X6xOZ%$M~&d{_z&frk=O3=tJXMHLvZSfHpP zED%_vQC2Y#R6$lKqYy68$&0Ikmfr|m;sd5S z*4dy1(WDmF5VACmDDWuYm@!B}8c`sfId)|hctkzc=>Z5N0aPl~+?ZBh6jdR!cdA*- zF>+WolnaMc=;3#a%DY_in1(KIn#`;>m9B;o*x8tJ14TNzqRy40N_U}DbMVqB4TlMR zH;#(lByGFQfO2f6zRi)4X2^k0$%%yd%ZfbA2OLu7&#ntXWD}rq@ zOC;eE)e_R~M{qiwZoBRJnbq6>U7g{6sGZ3OXCN$u7(gULBmvcmA)ysZ$&wX?VscdfOU$$tt|*;30cGp7**FMXef@uF?=3LCIlRMpQ(t7=wdQ z8es@Bc6)^S`^s3CLD)`5Vcjx~r;T7@*k=)Eio#9{PO@`8r+;LE~Pa+9^#-c9ys zS+>^{WQs#A5*24hD>}@FM1%;;=d-!Z@L}CEteQz)etnB!Qnr;)o}jt*uHevWT{dMI_gd!)Lxe&XNQHCOW3Fo0CjcybvG@ zm|tZ8q}QFUABA~>R@En;Q7DpN^W#uraweqBvH*bqPEIpD8LCYPUx4foAPGcb0t5jm z!dfdSc&&`F>(AOLoL!-gp5MWME|`;tj`)?dZ$*Jrf@|3aDviqvtlAYLTr8{9YEbV5g z#E|zs!6cznBNMGpLC*;BT#$u9uyHFk)gF00tbMQ&p{XNTKCZULkiM=$6B23#SC#f$ zR$UgRK!rD<8PQClf5*tTR$_hg<&6S*N+&U=O3^kWSKQU#QZ>xAoc>ctE%pdB*DKll zHHVJ9CMPOu%jwQ_>{nxmY9p-dW$*mTTyTPisaML>0|+Q`qh4b{u>vK^r-p2~O?ex- zRnRwq49J|-!5m2j32#a%K%{qwOpV0E_9iuV7t!`Mnw>Rf)$YAZ%LOGQm=Bt%=j7ZNQ_cgHE^flR_41zZ@gLPSyzPNXY1a+(u&cZ^ODaQ#1FH_5NUR*pkkSCANPSC6;Kb}z zEM0+ZWo%xZGPZ=96C`b^7oKsml~1Nc3s-e0ZZnw>bu4ZPnU$}xNWMy=ySjerBrQP$ zHRH8IfRuT!>c>}k@gY*vUR1*|qbuRBkDbci>*tYZC{-4v=)x4)ZecyLTuGgC6vm5c rrdJgdl5Q>0WQxTFb16`^OuFW9-hqb83k0z0AMtl2Q-ui$G|e->Aa~z$ literal 2731 zcmV;c3RLw%T4*^jL0KkKS)61t6#yD1f5iX)Xaz!l|KNXb-@w2B|L{Nn004*q;0zxZ z5!h}#4gpGl4FDfJK7b|m!6`3>ra&fu&`d)~rkNQ{sg%t%G8l~jG&Z1ZOwtiBK$>KX zl>Id^qK_!`00E#h000008lE6ZRP>CViRldkAY>Xaj7)$40}vT7lSv^JJu+xW_MnW6 zHl%0+2yG)kW`F`|qd}DjXlT$+O*EJRG|7T6nlJzYX^H9>0EtPdqMI5`LqX~QJfHy3 z00EkS2Gj;i(#Ih(lrV{q$3QDuDyeKyQ=7!13cKHXO92tG!W!Nmu8gw!7y}0G-uCH` zO{fksO3(^I;@mT_Zog8u&6pHGg(+n?=iUPgQU-fPGEJaYNZ(O7JUNbs3y zqLKQxi$0jmAkSQ|eU)fC3c>{PrD>(2N?-gARO>NOFqsC_#ySRtRL#}R7a^Wzt8j95!z(k*SljbKaK@^E8TD56>w{rBZ;aFF%AJTr|XmKmpA*{rn~Xg9y) z_$5HQ%9R?FOp7wHMeuG zR$l{V2nuKr6k-Aa0zyM(h@vf)P*p@fa6ubls0DM%9M8b0I{SJ|nUny{6hl6Ice?vr zJNJ6H5CRjK-Rprx6pI8@RA4MvDk!jEh_F~9#T7&qVyqBiDlCGKRYVjNQAI^T6jW2y z>hrm0cY3OJ&k`Und90IXHs{-KZun^2s0%nPDxxPFT-I@TYnu~hEi87-naf-6D}%7@ zP8y4?EYq^tbtHg8(}auEEU7Fh)PsgxMnp`c0H`p6$kdib5vV#4Y)y-9WP_|IkWLw@ zGX;={d5yt9Nd$l)h^0AmWnF3tgfeqIGR)aBwpgI0lcXtzGPTp3S#{4^LO{(_ zh7+Y0`?KY}1rLdX=k8MQGH^#@ujg zn|OA)%Cx4W01^;2pc2zT7>M53bP!66BG{;`xdJpzTvrw0Hs4s~zFFWqJx{+o{h8b1 z^t(5FfF1T7NEMLpFs-AO+SM{Z0+A95&&rV}y8F2PB&v*X1hSIRD5S9_WyC5ckR&sZ z6eJiBBLl*LI}ngLunGJ(Ct_)uL(M`|9HjHS-14P6xm$3`CT)f+(MUFmp^UbLR!WE+ zGo~=6nXDnH{T&z*-tJ;dh@@CdOiZ?aoG765ND0{30}z6&K?%#2U>I5{3oQnF78q^p zZ8}nHuW>Kop`K@%*X0SK){RQrb_oHfIV>wE%81I*h&VL?rU^P=Arg2}bZj!zH}+9w z`V_=sf$0zfOhpYgCN>Nv=UxGl8CFoy1}er!v&YxQ`}VgQQ7;E7TH4l)jS|``j1s*AI_0Lf@#N}$*Ido{+f^D|7)?z) znr&rog72+wZE8_imX)+pDJP}0Hhi<@@Df0uIraSeRb3hhYy^-G;BoMvW`r;MY2a{( zooOxkv=(P?38yBTq!>rlSIPoN1!NIdK3cRwm!d8SAQo7V2_P1J)`a;5tavK5{dsqa zAT7bIVm%wZp3i{f=@V#W($0wR@pw9gdf1Jd*2Mw5k7u2xJ<=7ryVOvv@YaKLdmlgm@8o>2gX!P2M$38-al zB)6EQn7qB~DpO%F`$yro#;6hmdhD><*DeXyex>LmGud0{-WKVoE@WXG#|kT1lhJx- z5J9LXlJUx~DTe#2s2@hUXp*bnigc*$nIil^`TkUuYp<8gK3m{tN zc;u{a9@&##Vrf#SJQ61RX-y8Z;WAeASBygfW@WVsj;mTC=Wg^JQ#MA8awbtz=q)fe zVU|^BZj$Tt>e*~8Av|!Guy%2s5g{P36gH@aj8lti`^S*3!dW=NH=d^dcZg(!XZ=@fh-3J*fX)~7zjrL z5++6uFXM48T8u+vF}_g>3UhI%I?(I%eXU*8qf3^vhtz2WvLa@pF?0M7`XuuMBM^?K zG4T_~jEm5X5MlB)&G!&ocH{=h6UwXt5iny#o3oLI^8-5(3mo^}Ny5G1t%1i7$cgP- z+~j~@mm*O@0%#p19F1hu_9l9EucPeGXq*V(dP}IQk-5CCdaocwm5EMkGmlY>MyZ@e z8r;@-pRWM!Xkc;N~3FIh?nar*8=FXJ@ljnXw^`XvKszZw>fkI zs-wE~plVv!-E2AzN}8N;d%xr&R( zR}_v?v({pI@MmU$vZyW6#RfGvsAY3WhkWud4GDr8hJy)-M;(T^wO<-Rb;3ffSHOd6 zvgW8)u%se`TyZ&UsOIrd)rv2-qXyTF__VRcG@@aRQl*s|Zxy=LRP+kTB2}6js@D({ z2VGztK#5)M$hC2&I#8<@ZJF1AERqohf`E0M)RCftNQI6T0KCFBDXnciX-tl8P;1?l ztD{6Mk&{m5Y_S&}Q^$QWQDIG5?V%0621Fl28<{R;OY*4~SgCkxhXhzFK?614$f2-V zKQ+^FzekD`6+}x;G!)qkF}htm{;3tp`=McAHPUW2vlm8m&J|iIl=UU!P-~>43k8uA l!7O^b-l1L@zH4;R$TbG287oqvROuh_cO+AV2?@qSAyD*!+=KuC diff --git a/SESSION.md b/SESSION.md index 44778018..0f0edad0 100644 --- a/SESSION.md +++ b/SESSION.md @@ -11,11 +11,11 @@ |collate |en_US.UTF-8 | |ctype |en_US.UTF-8 | |tz |Europe/Copenhagen | -|date |2026-03-23 | +|date |2026-03-24 | |rstudio |2026.01.1+403 Apple Blossom (desktop) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |quarto |1.7.30 @ /usr/local/bin/quarto | -|FreesearchR |26.3.4.260323 | +|FreesearchR |26.3.4.260324 | -------------------------------------------------------------------------------- @@ -44,7 +44,6 @@ |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | -|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | @@ -54,7 +53,6 @@ |colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) | -|curl |7.0.0 |2025-08-19 |CRAN (R 4.5.0) | |data.table |1.18.2.1 |2026-01-27 |CRAN (R 4.5.2) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.5.0) | |datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) | @@ -113,7 +111,6 @@ |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.5.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.5.0) | -|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.5.0) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.5.0) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | @@ -127,6 +124,7 @@ |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | |Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.0) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | +|mgcv |1.9-4 |2025-11-07 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | |mvtnorm |1.3-2 |2024-11-04 |CRAN (R 4.5.2) | @@ -150,6 +148,7 @@ |pkgload |1.5.0 |2026-02-03 |CRAN (R 4.5.2) | |plyr |1.8.9 |2023-10-02 |CRAN (R 4.5.0) | |polyclip |1.10-7 |2024-07-23 |CRAN (R 4.5.0) | +|polylabelr |1.0.0 |2026-01-19 |CRAN (R 4.5.2) | |pracma |2.4.6 |2025-10-22 |CRAN (R 4.5.0) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.5.0) | |promises |1.5.0 |2025-11-01 |CRAN (R 4.5.0) | @@ -162,7 +161,6 @@ |R6 |2.6.1 |2025-02-15 |CRAN (R 4.5.0) | |ragg |1.5.1 |2026-03-06 |CRAN (R 4.5.2) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.5.0) | -|rappdirs |0.3.4 |2026-01-17 |CRAN (R 4.5.2) | |rbibutils |2.4.1 |2026-01-21 |CRAN (R 4.5.2) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.5.0) | |Rcpp |1.1.1 |2026-01-10 |CRAN (R 4.5.2) | @@ -216,9 +214,7 @@ |twosamples |2.0.1 |2023-06-23 |CRAN (R 4.5.0) | |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.5.0) | |usethis |3.2.1 |2025-09-06 |CRAN (R 4.5.0) | -|utf8 |1.2.6 |2025-06-08 |CRAN (R 4.5.0) | |uuid |1.2-2 |2026-01-23 |CRAN (R 4.5.2) | -|V8 |8.0.1 |2025-10-10 |CRAN (R 4.5.0) | |vctrs |0.7.1 |2026-01-23 |CRAN (R 4.5.2) | |viridis |0.6.5 |2024-01-29 |CRAN (R 4.5.0) | |viridisLite |0.4.3 |2026-02-04 |CRAN (R 4.5.2) | diff --git a/app_docker/app.R b/app_docker/app.R index 7d30c295..fb454111 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprPVhaz/file70562aff8e9e.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b6eb25f5.R ######## i18n_path <- here::here("translations") @@ -871,30 +871,36 @@ make_choices_with_infos <- function(data) { #' @importFrom shiny selectizeInput #' @export #' -columnSelectInput <- function( - inputId, - label, - data, - selected = "", - ..., - col_subset = NULL, - placeholder = "", - onInitialize, - none_label = "No variable selected", - maxItems = NULL -) { - datar <- if (is.reactive(data)) data else reactive(data) - col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) +columnSelectInput <- function(inputId, + label, + data, + selected = "", + ..., + col_subset = NULL, + placeholder = "", + onInitialize, + none_label = "No variable selected", + maxItems = NULL) { + datar <- if (is.reactive(data)) + data + else + reactive(data) + col_subsetr <- if (is.reactive(col_subset)) + col_subset + else + reactive(col_subset) labels <- Map(function(col) { json <- sprintf( - IDEAFilter:::strip_leading_ws(' + IDEAFilter:::strip_leading_ws( + ' { "name": "%s", "label": "%s", "dataclass": "%s", "datatype": "%s" - }'), + }' + ), col, attr(datar()[[col]], "label") %||% "", IDEAFilter:::get_dataFilter_class(datar()[[col]]), @@ -903,12 +909,25 @@ columnSelectInput <- function( }, col = names(datar())) if (!"none" %in% names(datar())) { - labels <- c("none" = list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', none_label)), labels) + labels <- c("none" = list( + sprintf( + '\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', + none_label + ) + ), labels) choices <- setNames(names(labels), labels) - choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] + choices <- choices[match(if (length(col_subsetr()) == 0 || + isTRUE(col_subsetr() == "")) + names(datar()) + else + col_subsetr(), choices)] } else { choices <- setNames(names(datar()), labels) - choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] + choices <- choices[match(if (length(col_subsetr()) == 0 || + isTRUE(col_subsetr() == "")) + choices + else + col_subsetr(), choices)] } shiny::selectizeInput( @@ -917,8 +936,9 @@ columnSelectInput <- function( choices = choices, selected = selected, ..., - options = c( - list(render = I("{ + options = c(list( + render = I( + "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); @@ -946,9 +966,10 @@ columnSelectInput <- function( escape(item.data.name) + ''; } - }")), - if (!is.null(maxItems)) list(maxItems = maxItems) - ) + }" + ) + ), if (!is.null(maxItems)) + list(maxItems = maxItems)) ) } @@ -1001,7 +1022,10 @@ vectorSelectInput <- function(inputId, ..., placeholder = "", onInitialize) { - datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices) + datar <- if (shiny::is.reactive(choices)) + data + else + shiny::reactive(choices) labels <- sprintf( IDEAFilter:::strip_leading_ws(' @@ -1021,8 +1045,9 @@ vectorSelectInput <- function(inputId, choices = choices_new, selected = selected, ..., - options = c( - list(render = I("{ + options = c(list( + render = I( + "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); @@ -1041,7 +1066,123 @@ vectorSelectInput <- function(inputId, escape(item.data.name) + ''; } - }")) + }" + ) + )) + ) +} + + +#' A selectizeInput customized for named vectors of color names supported by +#' \code{\link{generate_colors}} +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param choices A named \code{vector} from which fields should be populated +#' @param selected default selection +#' @param previews number of preview colors. Default is 4. +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' +#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element +#' @export +#' +#' @examples +#' if (shiny::interactive()) { +#'top_palettes <- c( +#'"Perceptual (blue-yellow)" = "viridis", +#'"Perceptual (fire)" = "plasma", +#'"Colour-blind friendly" = "Okabe-Ito", +#'"Qualitative (bold)" = "Dark 2", +#'"Qualitative (paired)" = "Paired", +#'"Sequential (blues)" = "Blues", +#'"Diverging (red-blue)" = "RdBu", +#'"Tableau style" = "Tableau 10", +#'"Pastel" = "Pastel 1", +#'"Rainbow" = "rainbow" +#') +#' shinyApp( +#' ui = fluidPage( +#' titlePanel("Color Palette Select Test"), +#' colorSelectInput( +#' inputId = "palette", +#' label = "Color palette", +#' choices = top_palettes, +#' selected = "viridis" +#' ), +#' verbatimTextOutput("selected") +#' ), +#' server = function(input, output, session) { +#' output$selected <- renderPrint(input$palette) +#' } +#' ) +#' } +colorSelectInput <- function(inputId, + label, + choices, + selected = "", + previews = 4, + ..., + placeholder = "") { + vals <- if (shiny::is.reactive(choices)) { + choices() + } else{ + choices + } + + swatch_html <- function(palette_name) { + colors <- tryCatch( + suppressMessages(generate_colors(previews, palette_name)), + error = function(e) + rep("#cccccc", 3) + ) + # Strip alpha channel to ensure valid 6-digit CSS hex + colors <- substr(colors, 1, 7) + paste0( + sprintf( + "", + colors + ), + collapse = "" + ) + } + + labels <- sprintf( + '{"name": "%s", "label": "%s", "swatch": "%s"}', + vals, + names(vals) %||% "", + vapply(vals, swatch_html, character(1)) + ) + + choices_new <- stats::setNames(vals, labels) + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices_new, + selected = selected, + ..., + options = list( + render = I( + "{ + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" + ) ) ) } @@ -1998,11 +2139,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { title = "Create plot", icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), - shiny::helpText(i18n$t('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.')), + shiny::helpText( + i18n$t( + 'Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.' + ) + ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), shiny::uiOutput(outputId = ns("secondary")), shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("color_palette")), shiny::br(), shiny::actionButton( inputId = ns("act_plot"), @@ -2048,14 +2194,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::selectInput( inputId = ns("plot_type"), label = i18n$t("File format"), - choices = list( - "png", - "tiff", - "eps", - "pdf", - "jpeg", - "svg" - ) + choices = list("png", "tiff", "eps", "pdf", "jpeg", "svg") ), shiny::br(), # Button @@ -2066,12 +2205,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ) ) ), - shiny::p("We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", - "View notes in new tab", - target = "_blank", - rel = "noopener noreferrer" - )) + shiny::p( + "We have collected a few notes on visualising data and details on the options included in FreesearchR:", + shiny::tags$a( + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + "View notes in new tab", + target = "_blank", + rel = "noopener noreferrer" + ) + ) ), shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), @@ -2092,21 +2234,37 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @export data_visuals_server <- function(id, data, + palettes = c( + "Perceptual (blue-yellow)" = "viridis", + "Perceptual (fire)" = "plasma", + "Colour-blind friendly" = "Okabe-Ito", + "Qualitative (bold)" = "Dark 2", + "Qualitative (paired)" = "Paired", + "Sequential (blues)" = "Blues", + "Diverging (red-blue)" = "RdBu", + "Tableau style" = "Tableau 10", + "Pastel" = "Pastel 1", + "Rainbow" = "rainbow" + ), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { ns <- session$ns - rv <- shiny::reactiveValues( - plot.params = NULL, - plot = NULL, - code = NULL - ) + rv <- shiny::reactiveValues(plot.params = NULL, + plot = NULL, + code = NULL) shiny::observe({ - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_plot",title = i18n$t("Create plot")) - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_download",title = i18n$t("Download")) + bslib::accordion_panel_update( + id = "acc_plot", + target = "acc_pan_plot", + title = i18n$t("Create plot") + ) + bslib::accordion_panel_update(id = "acc_plot", + target = "acc_pan_download", + title = i18n$t("Download")) }) # ## --- New attempt @@ -2235,12 +2393,10 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots( - data = plot_data - ) + plots <- possible_plots(data = plot_data) plots_named <- get_plot_options(plots) |> - lapply(\(.x){ + lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) @@ -2260,23 +2416,19 @@ data_visuals_server <- function(id, output$secondary <- shiny::renderUI({ shiny::req(input$type) - cols <- c( - rv$plot.params()[["secondary.extra"]], - all_but( - colnames(subset_types( - data(), - rv$plot.params()[["secondary.type"]] - )), - input$primary - ) - ) + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) columnSelectInput( inputId = ns("secondary"), data = data, selected = cols[1], placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) i18n$t("Additional variables") else i18n$t("Secondary variable"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), multiple = rv$plot.params()[["secondary.multi"]], maxItems = rv$plot.params()[["secondary.max"]], col_subset = cols, @@ -2295,10 +2447,7 @@ data_visuals_server <- function(id, col_subset = c( "none", all_but( - colnames(subset_types( - data(), - rv$plot.params()[["tertiary.type"]] - )), + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), input$primary, input$secondary ) @@ -2307,64 +2456,59 @@ data_visuals_server <- function(id, ) }) - shiny::observeEvent(input$act_plot, - { - if (NROW(data()) > 0) { - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary - ) + ### Color option + output$color_palette <- shiny::renderUI({ + # shiny::req(input$type) + colorSelectInput( + inputId = ns("color_palette"), + label = i18n$t("Choose color palette"), + choices = palettes + ) + }) - ## If the dictionary holds additional arguments to pass to the - ## plotting function, these are included - if (!is.null(rv$plot.params()[["fun.args"]])){ - parameters <- modifyList(parameters,rv$plot.params()[["fun.args"]]) - } - - shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), { - rv$plot <- rlang::exec( - create_plot, - !!!append_list( - data(), - parameters, - "data" - ) - ) - }) - - rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") - }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - error = function(err) { - showNotification(paste0(err), type = "err") - } + shiny::observeEvent(input$act_plot, { + if (NROW(data()) > 0) { + tryCatch({ + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary, + color.palette = input$color_palette ) - } - }, - ignoreInit = TRUE - ) + + ## If the dictionary holds additional arguments to pass to the + ## plotting function, these are included + if (!is.null(rv$plot.params()[["fun.args"]])) { + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + } + + shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), + { + rv$plot <- rlang::exec(create_plot, + !!!append_list(data(), parameters, "data")) + }) + + rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") + }, # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + }) + } + }, ignoreInit = TRUE) output$code_plot <- shiny::renderUI({ shiny::req(rv$code) prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code)) }) - shiny::observeEvent( - list( - data() - ), - { - shiny::req(data()) + shiny::observeEvent(list(data()), { + shiny::req(data()) - rv$plot <- NULL - } - ) + rv$plot <- NULL + }) output$plot <- shiny::renderPlot({ # shiny::req(rv$plot) @@ -2404,16 +2548,15 @@ data_visuals_server <- function(id, width = input$width, height = input$height_slide, dpi = 300, - units = "mm", scale = 2 + units = "mm", + scale = 2 ) }) } ) - shiny::observe( - return(rv$plot) - ) + shiny::observe(return(rv$plot)) } ) } @@ -2476,9 +2619,11 @@ supported_plots <- function() { list( plot_bar_rel = list( fun = "plot_bar", - fun.args =list(style="fill"), + fun.args = list(style = "fill"), descr = i18n$t("Stacked relative barplot"), - note = i18n$t("Create relative stacked barplots to show the distribution of categorical levels"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2487,9 +2632,11 @@ supported_plots <- function() { ), plot_bar_abs = list( fun = "plot_bar", - fun.args =list(style="dodge"), + fun.args = list(style = "dodge"), descr = i18n$t("Side-by-side barplot"), - note = i18n$t("Create side-by-side barplot to show the distribution of categorical levels"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2499,7 +2646,9 @@ supported_plots <- function() { plot_hbars = list( fun = "plot_hbars", descr = i18n$t("Stacked horizontal bars"), - note = i18n$t("A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2509,7 +2658,9 @@ supported_plots <- function() { plot_violin = list( fun = "plot_violin", descr = i18n$t("Violin plot"), - note = i18n$t("A modern alternative to the classic boxplot to visualise data distribution"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), primary.type = c("datatime", "continuous"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2557,7 +2708,9 @@ supported_plots <- function() { plot_euler = list( fun = "plot_euler", descr = i18n$t("Euler diagram"), - note = i18n$t("Generate area-proportional Euler diagrams to display set relationships"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), primary.type = c("dichotomous"), secondary.type = c("dichotomous"), secondary.multi = TRUE, @@ -2598,7 +2751,7 @@ possible_plots <- function(data) { out <- type } else { out <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { if (type %in% .x$primary.type) { .x$descr } @@ -2626,12 +2779,12 @@ possible_plots <- function(data) { #' get_plot_options() get_plot_options <- function(data) { descrs <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { .x$descr }) |> unlist() supported_plots() |> - (\(.x){ + (\(.x) { .x[match(data, descrs)] })() } @@ -2645,6 +2798,7 @@ get_plot_options <- function(data) { #' @param sec secondary variable #' @param ter tertiary variable #' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. #' @param ... ignored for now #' #' @name data-plots @@ -2654,7 +2808,13 @@ get_plot_options <- function(data) { #' #' @examples #' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, type, pri, sec, ter = NULL, ...) { +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { if (!is.null(sec)) { if (!any(sec %in% names(data))) { sec <- NULL @@ -2671,13 +2831,11 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) { pri = pri, sec = sec, ter = ter, + color.palette = color.palette, ... ) - out <- do.call( - type, - modifyList(parameters, list(data = data)) - ) + out <- do.call(type, modifyList(parameters, list(data = data))) code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") @@ -2734,10 +2892,14 @@ get_label <- function(data, var = NULL) { #' @examples #' "Lorem ipsum... you know the routine" |> line_break() #' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, lineLength = 20, force = FALSE) { +line_break <- function(data, + lineLength = 20, + force = FALSE) { if (isTRUE(force)) { ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) } else { paste(strwrap(data, lineLength), collapse = "\n") } @@ -2769,9 +2931,9 @@ wrap_plot_list <- function(data, if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { out <- data |> - (\(.x){ + (\(.x) { if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i){ + purrr::imap(.x, \(.y, .i) { .y + ggplot2::ggtitle(.i) }) } else { @@ -2779,12 +2941,10 @@ wrap_plot_list <- function(data, } })() |> align_axes() |> - patchwork::wrap_plots( - guides = guides, - axes = axes, - axis_titles = axis_titles, - ... - ) + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) if (!is.null(tag_levels)) { out <- out + patchwork::plot_annotation(tag_levels = tag_levels) } @@ -2823,7 +2983,9 @@ wrap_plot_list <- function(data, #' @returns list of ggplot2 objects #' @export #' -align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -2841,7 +3003,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x){ + purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -2865,7 +3027,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { clean_common_axis <- function(p, axis) { purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> unlist() |> - (\(.x){ + (\(.x) { if (is.numeric(.x)) { range(.x) } else { @@ -3662,6 +3824,249 @@ footer_ui <- function(i18n) { } +######## +#### Current file: /Users/au301842/FreesearchR/R//generate_colors.R +######## + +#' Generate N Colors from a Specified Color Palette +#' +#' A flexible wrapper around multiple color palette libraries, returning N +#' colors as a character vector of hex codes. Supports palettes from +#' \pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}. +#' +#' @param n \code{integer}. Number of colors to generate. Must be a positive +#' integer. +#' @param palette \code{character(1)}. Name of the color palette to use. +#' Case-insensitive. Supported options: +#' \describe{ +#' \item{\strong{viridisLite}}{`"viridis"`, `"magma"`, `"plasma"`, +#' `"inferno"`, `"cividis"`, `"mako"`, `"rocket"`, `"turbo"`} +#' \item{\strong{grDevices}}{`"hcl"`, `"rainbow"`, `"heat"`, +#' `"terrain"`, `"topo"`} +#' \item{\strong{RColorBrewer}}{Any palette name from +#' \code{RColorBrewer::brewer.pal.info}, e.g. `"Set1"`, `"Blues"`, +#' `"Dark2"`. If \code{n} exceeds the palette maximum, colors are +#' interpolated via \code{\link[grDevices]{colorRampPalette}}.} +#' } +#' @param ... Additional arguments passed to the underlying palette function. +#' For example, \code{alpha}, \code{direction}, \code{begin}, \code{end} +#' are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is +#' forwarded to \code{\link[grDevices]{hcl.colors}}. +#' +#' @return A \code{character} vector of length \code{n} containing hex color +#' codes (e.g. \code{"#440154FF"}). +#' +#' @examples +#' # viridisLite palettes +#' generate_colors(5, "viridis") +#' generate_colors(5, "plasma") +#' generate_colors(5, "viridis", alpha = 0.8, direction = -1) +#' +#' # Base R grDevices +#' generate_colors(5, "rainbow") +#' generate_colors(8, "hcl", palette = "Dark 3") +#' +#' # RColorBrewer +#' generate_colors(5, "Set1") +#' generate_colors(5, "Blues") +#' generate_colors(12, "Set1") # interpolates beyond palette max of 9 +#' +#' # Drop-in replacement for viridisLite::viridis() +#' # generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis") +#' +#' @seealso +#' \code{\link[viridisLite]{viridis}}, +#' \code{\link[grDevices]{hcl.colors}}, +#' \code{\link[RColorBrewer]{brewer.pal}} +#' +#' @importFrom viridisLite viridis +#' @importFrom grDevices hcl.colors rainbow heat.colors terrain.colors +#' topo.colors colorRampPalette +#' @importFrom RColorBrewer brewer.pal brewer.pal.info +#' +#' @export +generate_colors <- function(n, palette = "viridis", ...) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + + # Function passthrough — call directly with n and ... + if (is.function(palette)) { + return(palette(n, ...)) + } + + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + + palette_lower <- tolower(palette) + + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) + + if (palette_lower %in% viridis_palettes) { + viridisLite::viridis(n = n, option = palette_lower, ...) + + } else if (palette_lower == "hcl") { + grDevices::hcl.colors(n = n, ...) + + } else if (palette_lower == "rainbow") { + grDevices::rainbow(n = n, ...) + + } else if (palette_lower == "heat") { + grDevices::heat.colors(n = n, ...) + + } else if (palette_lower == "terrain") { + grDevices::terrain.colors(n = n, ...) + + } else if (palette_lower == "topo") { + grDevices::topo.colors(n = n, ...) + + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) + } +} + + +#' Create a Continuous Color Function from a Palette +#' +#' Wraps \code{\link{generate_colors}} into a function that accepts a value +#' between 0 and 1 and returns the corresponding color. Useful for mapping +#' continuous variables to colors. +#' +#' @param palette Passed directly to [generate_colors()]. Either a palette +#' name string or a function. +#' @param n \code{integer}. Resolution of the underlying color ramp — higher +#' values give smoother gradients. Defaults to 256. +#' @param ... Additional arguments passed to [generate_colors()]. +#' +#' @return A function that takes a numeric vector of values in \code{[0, 1]} +#' and returns a character vector of hex colors. +#' +#' @examples +#' pal <- continuous_colors("viridis") +#' pal(0) # first color +#' pal(1) # last color +#' pal(0.5) # midpoint +#' +#' # Map a continuous variable to colors +#' values <- seq(0, 1, length.out = 10) +#' pal(values) +#' +#' # Works with any palette generate_colors() accepts +#' pal <- continuous_colors("plasma", direction = -1) +#' pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red")) +#' +#' @seealso [generate_colors()] +#' @export +continuous_colors <- function(palette = "viridis", n = 256, ...) { + colors <- generate_colors(n, palette, ...) + ramp <- grDevices::colorRamp(colors) + + function(x) { + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") + rgb_vals <- ramp(x) + grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) + } +} + + +#' Discrete and Continuous Fill Scale Using generate_colors +#' +#' Drop-in replacement for [viridis::scale_fill_viridis()] that works with +#' any palette supported by [generate_colors()]. +#' +#' @param palette Passed to [generate_colors()]. Either a palette name string +#' or a function. +#' @param discrete \code{logical}. If \code{TRUE} (default), a discrete scale +#' is returned. If \code{FALSE}, a continuous scale is returned. +#' @param ... Additional arguments passed to [ggplot2::scale_fill_manual()] +#' (discrete) or [ggplot2::scale_fill_gradientn()] (continuous). +#' +#' @examples +#' library(ggplot2) +#' +#' # Discrete +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) + +#' geom_col() + +#' scale_fill_generate(palette = "Set1") +#' +#' # Continuous +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) + +#' geom_point(shape = 21, size = 3) + +#' scale_fill_generate(palette = "viridis", discrete = FALSE) +#' +#' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] +#' @export +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "fill", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} + +#' @rdname scale_fill_generate +#' @examples +#' ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) + +#' geom_point() + +#' scale_color_generate(palette = "Set1") +#' @export +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "colour", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## @@ -4514,7 +4919,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.4-260323' +hosted_version <- function()'v26.3.4-260324' ######## @@ -6495,7 +6900,8 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), max_level = 30, ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6510,7 +6916,8 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi pri = pri, sec = sec, style = style, - max_level = max_level + max_level = max_level, + color.palette = color.palette ) }) @@ -6535,8 +6942,9 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar_single(pri = "cyl", style = "stack") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30) { +#' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, + color.palette = "viridis") { style <- match.arg(style) if (identical(sec, "none")) { @@ -6595,6 +7003,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " ) + ggplot2::geom_bar(position = style, stat = "identity") + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + ggplot2::ylab("Percentage") + ggplot2::xlab(get_label(data,pri))+ ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) @@ -6648,7 +7057,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " #' mtcars |> #' default_parsing() |> #' plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") -plot_box <- function(data, pri, sec, ter = NULL,...) { +plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -6659,7 +7068,8 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { plot_box_single( data = .ds, pri = pri, - sec = sec + sec = sec, + color.palette=color.palette ) }) @@ -6676,9 +7086,10 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { #' #' @examples #' mtcars |> plot_box_single("mpg") -#' mtcars |> plot_box_single("mpg","cyl") +#' mtcars |> plot_box_single("mpg","cyl",color.palette="Blues") +#' stRoke::trial |> plot_box_single("age","active",color.palette="Blues") #' gtsummary::trial |> plot_box_single("age","trt") -plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { +plot_box_single <- function(data, pri, sec=NULL, seed = 2103,color.palette="viridis") { set.seed(seed) if (is.null(sec)) { @@ -6696,7 +7107,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { ggplot2::xlab(get_label(data,pri))+ ggplot2::ylab(get_label(data,sec)) + ggplot2::coord_flip() + - viridis::scale_fill_viridis(discrete = discrete, option = "D") + + scale_fill_generate(discrete = discrete,palette = color.palette) + # ggplot2::theme_void() + ggplot2::theme_bw(base_size = 24) + ggplot2::theme( @@ -6827,7 +7238,7 @@ ggeulerr <- function( #' plot_euler("mfi_cut", "mdi_cut") #' stRoke::trial |> #' plot_euler(pri="male", sec=c("hypertension")) -plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="viridis") { set.seed(seed = seed) if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -6837,7 +7248,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { out <- lapply(ds, \(.x){ .x[c(pri, sec)] |> na.omit() |> - plot_euler_single() + plot_euler_single(color.palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) @@ -6855,16 +7266,12 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { #' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() -#' mtcars[c("vs", "am")] |> plot_euler_single() -plot_euler_single <- function(data) { - # if (any("categorical" %in% data_type(data))){ - # shape <- "ellipse" - # } else { - # shape <- "circle" - # } +#' mtcars[c("vs", "am")] |> plot_euler_single("magma") +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + + scale_fill_generate(palette=color.palette) + ggplot2::theme_void() + ggplot2::theme( legend.position = "none", @@ -6896,11 +7303,21 @@ plot_euler_single <- function(data) { #' @examples #' mtcars |> plot_hbars(pri = "carb", sec = "cyl") #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_hbars(pri = "carb", sec = NULL) -plot_hbars <- function(data, pri, sec, ter = NULL) { - out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) - - out +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") +plot_hbars <- function(data, + pri, + sec, + ter = NULL, + color.palette = "viridis") { + vertical_stacked_bars( + data = data, + score = pri, + group = sec, + strata = ter, + color.palette = color.palette + ) } @@ -6923,7 +7340,9 @@ vertical_stacked_bars <- function(data, l.color = "black", l.size = .5, draw.lines = TRUE, - label.str="{n}\n{round(100 * p,0)}%") { + label.str = "{n}\n{round(100 * p,0)}%", + color.palette = "viridis", + reverse = TRUE) { if (is.null(group)) { df.table <- data[c(score, group, strata)] |> dplyr::mutate("All" = 1) |> @@ -6948,15 +7367,19 @@ vertical_stacked_bars <- function(data, returnData = TRUE ) - colors <- viridisLite::viridis(nrow(df.table)) + colors <- generate_colors(n = nrow(df.table), palette = color.palette) + ## Colors are reversed by default as that usually gives the best result + if (isTRUE(reverse)) { + colors <- rev(colors) + } contrast_cut <- - sum(contrast_text(colors, threshold = .3) == "white") + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) p |> - (\(.x){ + (\(.x) { .x$plot + ggplot2::geom_text( data = .x$rectData[which(.x$rectData$n > @@ -6966,21 +7389,19 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = as.numeric(score) > contrast_cut, + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) ) ) + ggplot2::labs(fill = score_label) + - ggplot2::scale_fill_manual(values = rev(colors)) + - ggplot2::theme( - legend.position = "bottom", - axis.title = ggplot2::element_text(), + ggplot2::scale_fill_manual(values = colors) + + ggplot2::theme(legend.position = "bottom", + axis.title = ggplot2::element_text(), ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) - # viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D") })() } @@ -7001,7 +7422,7 @@ vertical_stacked_bars <- function(data, #' default_parsing() |> #' plot_ridge(x = "mpg", y = "cyl") #' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") -plot_ridge <- function(data, x, y, z = NULL, ...) { +plot_ridge <- function(data, x, y, z = NULL, color.palette="viridis", ...) { if (!is.null(z)) { ds <- split(data, data[z]) } else { @@ -7012,6 +7433,7 @@ plot_ridge <- function(data, x, y, z = NULL, ...) { ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) + ggridges::geom_density_ridges() + ggridges::theme_ridges() + + scale_fill_generate(palette=color.palette) + ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa() }) @@ -7044,7 +7466,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(pri, sec)] <- data[c(pri, sec)] |> + data <- data[c(pri, sec)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE) @@ -7109,15 +7531,17 @@ str_remove_last <- function(data, pattern = "\n") { #' ## Dont know why... #' mtcars |> #' default_parsing() |> -#' plot_sankey("cyl", "gear", "vs", color.group = "pri") -#' -#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") +#' plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno") plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL, + color.palette = "viridis", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -7125,12 +7549,14 @@ plot_sankey <- function(data, ds <- list(data) } + # browser() out <- lapply(ds, \(.ds) { plot_sankey_single( .ds, pri = pri, sec = sec, + color.palette = color.palette, color.group = color.group, colors = colors, missing.level = missing.level @@ -7168,67 +7594,67 @@ plot_sankey <- function(data, #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") +#' +#' +#' # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma") +#' # stRoke::trial |> plot_sankey_single("active", "male") +#' # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec") +#' # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo") plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), - colors = NULL, + color.palette = "viridis", + colors=NULL, missing.level = "Missing", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", ...) { color.group <- match.arg(color.group) - - # browser() - # if (is.na(ds[c(pri,sec)])) - - # browser() data_orig <- data - data[c(pri, sec)] <- data[c(pri, sec)] |> - dplyr::mutate( - dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop), - dplyr::across(dplyr::where(is.factor), \(.x) { - forcats::fct_na_value_to_level(.x, missing.level) - }) - ) + data[c(pri, sec)] <- with_labels(data,{ + data[c(pri, sec)] |> + to_clean_levels() |> + missing_to_text_levels(missing.text=missing.level) + }) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) + ## Aggregate data + data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...) - na.color <- "#2986cc" - box.color <- "#1E4B66" + default.color = default.color + box.color = box.color + na.color = na.color if (is.null(colors)) { if (color.group == "sec") { - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] + main.colors <- color_levels_gen(data_orig[[sec]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + secondary.colors <- rep(default.color, length(levels(data[[pri]]))) label.colors <- Reduce(c, lapply(list( secondary.colors, rev(main.colors) ), contrast_text)) } else { - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] + main.colors <- color_levels_gen(data_orig[[pri]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + secondary.colors <- rep(default.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list( rev(main.colors), secondary.colors ), contrast_text)) } - colors <- c(na.color, main.colors, secondary.colors) - colors[is.na(colors)] <- "grey80" + colors <- c(default.color, main.colors, secondary.colors) + colors[is.na(colors)] <- na.color } else { label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |> + group_labels <- c(get_label(data, pri), get_label(data, sec)) |> sapply(line_break) |> unname() - p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) + p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) if (color.group == "sec") { p <- p + @@ -7291,6 +7717,51 @@ plot_sankey_single <- function(data, } +# stRoke::trial["male"] |> to_clean_levels() +to_clean_levels <- function(data,missing.text="Missing"){ + if (is.data.frame(data)){ + data |> + lapply(all_levels_clean) |> + dplyr::bind_cols() + } else { + data |> + all_levels_clean() + } + + + +} + +# stRoke::trial["mrs_1"] |> missing_to_text_levels() +missing_to_text_levels <- function(data,missing.text="Missing"){ + data |> + dplyr::mutate( + dplyr::across(dplyr::where(is.factor), \(.x) { + if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.text) else .x + }) + ) +} + +all_levels_clean <- function(data){ + data |> + (\(.x){ + if (is.logical(.x)) as.factor(.x) else .x + })() |> + (\(.x){ + if (is.factor(.x)) forcats::fct_drop(.x) else .x + })() +} + +# stRoke::trial$mrs_1 |> color_levels_gen() +color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ + out <- generate_colors(n = length(levels(to_clean_levels(data))),palette = palette) + if (anyNA(data)){ + out <- c(out,na.color) + } + out +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//plot_scatter.R ######## @@ -7304,7 +7775,8 @@ plot_sankey_single <- function(data, #' #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") -plot_scatter <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -7321,7 +7793,8 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { group = ter, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_color_generate(palette=color.palette) } } @@ -7330,7 +7803,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_violin.R ######## -#' Beatiful violin plot +#' Beautiful violin plot #' #' @returns ggplot2 object #' @export @@ -7338,8 +7811,9 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { #' @name data-plots #' #' @examples -#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") -plot_violin <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl") +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7355,7 +7829,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) { response = pri, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_fill_generate(palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 15991bfe..ce9abc8e 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -89,7 +89,6 @@ "No variables have a correlation measure above the threshold.","Ingen variabler er korrelerede over den angivne tærskelværdi." "and","og" "from each pair","fra hvert par" -"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Kun variabler, der ikke er klassificerede som tekst er tilgængelige. Gå til fanen ""Forbered"" for at ændre klassifikationer." "Plot","Tegn" "Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" @@ -108,9 +107,7 @@ "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" -"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","En klassisk visualisering af fordelingen af observationer på en ordinal kategorisk skala. Typisk brugt til modified Rankin Scale og kendes også som 'Grotta bars'" "Violin plot","Violin-diagram" -"A modern alternative to the classic boxplot to visualise data distribution","Moderne alternativ til den klassiske box-plot og velegnet til at visualisere fordelingen af observationer" "Sankey plot","Sankey-diagram" "A way of visualising change between groups","Visualiserer ændring mellem grupper for samme type observationer" "Scatter plot","Punkt-diagram" @@ -118,7 +115,6 @@ "Box plot","Kasse-diagram" "A classic way to plot data distribution by groups","Klassik måde at visualisere fordeling" "Euler diagram","Eulerdiagram" -"Generate area-proportional Euler diagrams to display set relationships","Generer proportionelt Euler-diagram for at vise forhold mellem forskellige kategoriske observationer" "Documentation","Dokumentation" "Data is only stored for analyses and deleted when the app is closed.","Data opbevares alene til brug i analyser og slettes så snart appen lukkes." "Feedback","Feedback" @@ -232,9 +228,7 @@ "Split text","Opdel tekst" "Apply split","Anvend opdeling" "Stacked relative barplot","Stablet relativt søjlediagram" -"Create relative stacked barplots to show the distribution of categorical levels","Opret relative stablede søjlediagrammer for at vise fordelingen af kategoriske niveauer" "Side-by-side barplot","Side om side barplot" -"Create side-by-side barplot to show the distribution of categorical levels","Opret et side-om-side søjlediagram for at vise fordelingen af kategoriske niveauer" "Select table theme","Vælg tema" "Letters","Bogstaver" "Words","Ord" @@ -328,3 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" +"Choose color palette","Choose color palette" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 4388ae6e..96a7a109 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -89,7 +89,6 @@ "No variables have a correlation measure above the threshold.","Hakuna vigezo vyenye kipimo cha uhusiano kilicho juu ya kizingiti." "and","na" "from each pair","kutoka kwa kila jozi" -"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Vigezo visivyo vya maandishi pekee ndivyo vinavyopatikana kwa ajili ya kupanga. Nenda kwenye ""Data"" ili kupanga upya data ili kupanga." "Plot","Kipande cha habari" "Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" @@ -108,9 +107,7 @@ "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" -"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","Njia ya kitamaduni ya kuibua usambazaji wa mizani ya kawaida kama vile Mizani ya Nafasi iliyorekebishwa na inayojulikana kama baa za Grotta" "Violin plot","Hadithi ya violin" -"A modern alternative to the classic boxplot to visualise data distribution","Njia mbadala ya kisasa ya mpangilio wa kisanduku wa kawaida ili kuibua usambazaji wa data" "Sankey plot","Njama ya Sankey" "A way of visualising change between groups","Njia ya kuibua mabadiliko kati ya vikundi" "Scatter plot","Njama ya kutawanya" @@ -118,7 +115,6 @@ "Box plot","Kipande cha sanduku" "A classic way to plot data distribution by groups","Njia ya kawaida ya kupanga usambazaji wa data kwa vikundi" "Euler diagram","Mchoro wa Euler" -"Generate area-proportional Euler diagrams to display set relationships","Tengeneza michoro ya Euler inayolingana na eneo ili kuonyesha uhusiano uliowekwa" "Documentation","Nyaraka" "Data is only stored for analyses and deleted when the app is closed.","Data huhifadhiwa kwa ajili ya uchambuzi na kufutwa tu wakati programu imefungwa." "Feedback","Maoni" @@ -232,9 +228,7 @@ "No character variables with accepted delimiters detected.","Hakuna vigezo vya herufi vilivyo na vidhibiti vinavyokubalika vilivyogunduliwa." "Apply split","Tumia mgawanyiko" "Stacked relative barplot","Kipande cha baruni kilichopangwa kwa mirundiko" -"Create relative stacked barplots to show the distribution of categorical levels","Unda viwanja vya baruni vilivyopangwa ili kuonyesha usambazaji wa viwango vya kategoria" "Side-by-side barplot","Kipande cha baruni cha kando kwa kando" -"Create side-by-side barplot to show the distribution of categorical levels","Unda mpangilio wa barufa kando ili kuonyesha usambazaji wa viwango vya kategoria" "Select table theme","Chagua mandhari ya jedwali" "Letters","Barua" "Words","Maneno" @@ -328,3 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" +"Choose color palette","Choose color palette" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 68fad36f..a269e9d6 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//RtmprPVhaz/file70565b30c8af.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b2f3ac087.R ######## i18n_path <- system.file("translations", package = "FreesearchR") @@ -871,30 +871,36 @@ make_choices_with_infos <- function(data) { #' @importFrom shiny selectizeInput #' @export #' -columnSelectInput <- function( - inputId, - label, - data, - selected = "", - ..., - col_subset = NULL, - placeholder = "", - onInitialize, - none_label = "No variable selected", - maxItems = NULL -) { - datar <- if (is.reactive(data)) data else reactive(data) - col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) +columnSelectInput <- function(inputId, + label, + data, + selected = "", + ..., + col_subset = NULL, + placeholder = "", + onInitialize, + none_label = "No variable selected", + maxItems = NULL) { + datar <- if (is.reactive(data)) + data + else + reactive(data) + col_subsetr <- if (is.reactive(col_subset)) + col_subset + else + reactive(col_subset) labels <- Map(function(col) { json <- sprintf( - IDEAFilter:::strip_leading_ws(' + IDEAFilter:::strip_leading_ws( + ' { "name": "%s", "label": "%s", "dataclass": "%s", "datatype": "%s" - }'), + }' + ), col, attr(datar()[[col]], "label") %||% "", IDEAFilter:::get_dataFilter_class(datar()[[col]]), @@ -903,12 +909,25 @@ columnSelectInput <- function( }, col = names(datar())) if (!"none" %in% names(datar())) { - labels <- c("none" = list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', none_label)), labels) + labels <- c("none" = list( + sprintf( + '\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }', + none_label + ) + ), labels) choices <- setNames(names(labels), labels) - choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] + choices <- choices[match(if (length(col_subsetr()) == 0 || + isTRUE(col_subsetr() == "")) + names(datar()) + else + col_subsetr(), choices)] } else { choices <- setNames(names(datar()), labels) - choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] + choices <- choices[match(if (length(col_subsetr()) == 0 || + isTRUE(col_subsetr() == "")) + choices + else + col_subsetr(), choices)] } shiny::selectizeInput( @@ -917,8 +936,9 @@ columnSelectInput <- function( choices = choices, selected = selected, ..., - options = c( - list(render = I("{ + options = c(list( + render = I( + "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); @@ -946,9 +966,10 @@ columnSelectInput <- function( escape(item.data.name) + ''; } - }")), - if (!is.null(maxItems)) list(maxItems = maxItems) - ) + }" + ) + ), if (!is.null(maxItems)) + list(maxItems = maxItems)) ) } @@ -1001,7 +1022,10 @@ vectorSelectInput <- function(inputId, ..., placeholder = "", onInitialize) { - datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices) + datar <- if (shiny::is.reactive(choices)) + data + else + shiny::reactive(choices) labels <- sprintf( IDEAFilter:::strip_leading_ws(' @@ -1021,8 +1045,9 @@ vectorSelectInput <- function(inputId, choices = choices_new, selected = selected, ..., - options = c( - list(render = I("{ + options = c(list( + render = I( + "{ // format the way that options are rendered option: function(item, escape) { item.data = JSON.parse(item.label); @@ -1041,7 +1066,123 @@ vectorSelectInput <- function(inputId, escape(item.data.name) + ''; } - }")) + }" + ) + )) + ) +} + + +#' A selectizeInput customized for named vectors of color names supported by +#' \code{\link{generate_colors}} +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param choices A named \code{vector} from which fields should be populated +#' @param selected default selection +#' @param previews number of preview colors. Default is 4. +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' +#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element +#' @export +#' +#' @examples +#' if (shiny::interactive()) { +#'top_palettes <- c( +#'"Perceptual (blue-yellow)" = "viridis", +#'"Perceptual (fire)" = "plasma", +#'"Colour-blind friendly" = "Okabe-Ito", +#'"Qualitative (bold)" = "Dark 2", +#'"Qualitative (paired)" = "Paired", +#'"Sequential (blues)" = "Blues", +#'"Diverging (red-blue)" = "RdBu", +#'"Tableau style" = "Tableau 10", +#'"Pastel" = "Pastel 1", +#'"Rainbow" = "rainbow" +#') +#' shinyApp( +#' ui = fluidPage( +#' titlePanel("Color Palette Select Test"), +#' colorSelectInput( +#' inputId = "palette", +#' label = "Color palette", +#' choices = top_palettes, +#' selected = "viridis" +#' ), +#' verbatimTextOutput("selected") +#' ), +#' server = function(input, output, session) { +#' output$selected <- renderPrint(input$palette) +#' } +#' ) +#' } +colorSelectInput <- function(inputId, + label, + choices, + selected = "", + previews = 4, + ..., + placeholder = "") { + vals <- if (shiny::is.reactive(choices)) { + choices() + } else{ + choices + } + + swatch_html <- function(palette_name) { + colors <- tryCatch( + suppressMessages(generate_colors(previews, palette_name)), + error = function(e) + rep("#cccccc", 3) + ) + # Strip alpha channel to ensure valid 6-digit CSS hex + colors <- substr(colors, 1, 7) + paste0( + sprintf( + "", + colors + ), + collapse = "" + ) + } + + labels <- sprintf( + '{"name": "%s", "label": "%s", "swatch": "%s"}', + vals, + names(vals) %||% "", + vapply(vals, swatch_html, character(1)) + ) + + choices_new <- stats::setNames(vals, labels) + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices_new, + selected = selected, + ..., + options = list( + render = I( + "{ + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" + ) ) ) } @@ -1998,11 +2139,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { title = "Create plot", icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), - shiny::helpText(i18n$t('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.')), + shiny::helpText( + i18n$t( + 'Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.' + ) + ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), shiny::uiOutput(outputId = ns("secondary")), shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("color_palette")), shiny::br(), shiny::actionButton( inputId = ns("act_plot"), @@ -2048,14 +2194,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::selectInput( inputId = ns("plot_type"), label = i18n$t("File format"), - choices = list( - "png", - "tiff", - "eps", - "pdf", - "jpeg", - "svg" - ) + choices = list("png", "tiff", "eps", "pdf", "jpeg", "svg") ), shiny::br(), # Button @@ -2066,12 +2205,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ) ) ), - shiny::p("We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", - "View notes in new tab", - target = "_blank", - rel = "noopener noreferrer" - )) + shiny::p( + "We have collected a few notes on visualising data and details on the options included in FreesearchR:", + shiny::tags$a( + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + "View notes in new tab", + target = "_blank", + rel = "noopener noreferrer" + ) + ) ), shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), @@ -2092,21 +2234,37 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @export data_visuals_server <- function(id, data, + palettes = c( + "Perceptual (blue-yellow)" = "viridis", + "Perceptual (fire)" = "plasma", + "Colour-blind friendly" = "Okabe-Ito", + "Qualitative (bold)" = "Dark 2", + "Qualitative (paired)" = "Paired", + "Sequential (blues)" = "Blues", + "Diverging (red-blue)" = "RdBu", + "Tableau style" = "Tableau 10", + "Pastel" = "Pastel 1", + "Rainbow" = "rainbow" + ), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { ns <- session$ns - rv <- shiny::reactiveValues( - plot.params = NULL, - plot = NULL, - code = NULL - ) + rv <- shiny::reactiveValues(plot.params = NULL, + plot = NULL, + code = NULL) shiny::observe({ - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_plot",title = i18n$t("Create plot")) - bslib::accordion_panel_update(id = "acc_plot", target = "acc_pan_download",title = i18n$t("Download")) + bslib::accordion_panel_update( + id = "acc_plot", + target = "acc_pan_plot", + title = i18n$t("Create plot") + ) + bslib::accordion_panel_update(id = "acc_plot", + target = "acc_pan_download", + title = i18n$t("Download")) }) # ## --- New attempt @@ -2235,12 +2393,10 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots( - data = plot_data - ) + plots <- possible_plots(data = plot_data) plots_named <- get_plot_options(plots) |> - lapply(\(.x){ + lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) @@ -2260,23 +2416,19 @@ data_visuals_server <- function(id, output$secondary <- shiny::renderUI({ shiny::req(input$type) - cols <- c( - rv$plot.params()[["secondary.extra"]], - all_but( - colnames(subset_types( - data(), - rv$plot.params()[["secondary.type"]] - )), - input$primary - ) - ) + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) columnSelectInput( inputId = ns("secondary"), data = data, selected = cols[1], placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) i18n$t("Additional variables") else i18n$t("Secondary variable"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), multiple = rv$plot.params()[["secondary.multi"]], maxItems = rv$plot.params()[["secondary.max"]], col_subset = cols, @@ -2295,10 +2447,7 @@ data_visuals_server <- function(id, col_subset = c( "none", all_but( - colnames(subset_types( - data(), - rv$plot.params()[["tertiary.type"]] - )), + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), input$primary, input$secondary ) @@ -2307,64 +2456,59 @@ data_visuals_server <- function(id, ) }) - shiny::observeEvent(input$act_plot, - { - if (NROW(data()) > 0) { - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary - ) + ### Color option + output$color_palette <- shiny::renderUI({ + # shiny::req(input$type) + colorSelectInput( + inputId = ns("color_palette"), + label = i18n$t("Choose color palette"), + choices = palettes + ) + }) - ## If the dictionary holds additional arguments to pass to the - ## plotting function, these are included - if (!is.null(rv$plot.params()[["fun.args"]])){ - parameters <- modifyList(parameters,rv$plot.params()[["fun.args"]]) - } - - shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), { - rv$plot <- rlang::exec( - create_plot, - !!!append_list( - data(), - parameters, - "data" - ) - ) - }) - - rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") - }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - error = function(err) { - showNotification(paste0(err), type = "err") - } + shiny::observeEvent(input$act_plot, { + if (NROW(data()) > 0) { + tryCatch({ + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary, + color.palette = input$color_palette ) - } - }, - ignoreInit = TRUE - ) + + ## If the dictionary holds additional arguments to pass to the + ## plotting function, these are included + if (!is.null(rv$plot.params()[["fun.args"]])) { + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + } + + shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), + { + rv$plot <- rlang::exec(create_plot, + !!!append_list(data(), parameters, "data")) + }) + + rv$code <- glue::glue("FreesearchR::create_plot(df,{list2str(parameters)})") + }, # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + }) + } + }, ignoreInit = TRUE) output$code_plot <- shiny::renderUI({ shiny::req(rv$code) prismCodeBlock(paste0(i18n$t("#Plotting\n"), rv$code)) }) - shiny::observeEvent( - list( - data() - ), - { - shiny::req(data()) + shiny::observeEvent(list(data()), { + shiny::req(data()) - rv$plot <- NULL - } - ) + rv$plot <- NULL + }) output$plot <- shiny::renderPlot({ # shiny::req(rv$plot) @@ -2404,16 +2548,15 @@ data_visuals_server <- function(id, width = input$width, height = input$height_slide, dpi = 300, - units = "mm", scale = 2 + units = "mm", + scale = 2 ) }) } ) - shiny::observe( - return(rv$plot) - ) + shiny::observe(return(rv$plot)) } ) } @@ -2476,9 +2619,11 @@ supported_plots <- function() { list( plot_bar_rel = list( fun = "plot_bar", - fun.args =list(style="fill"), + fun.args = list(style = "fill"), descr = i18n$t("Stacked relative barplot"), - note = i18n$t("Create relative stacked barplots to show the distribution of categorical levels"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2487,9 +2632,11 @@ supported_plots <- function() { ), plot_bar_abs = list( fun = "plot_bar", - fun.args =list(style="dodge"), + fun.args = list(style = "dodge"), descr = i18n$t("Side-by-side barplot"), - note = i18n$t("Create side-by-side barplot to show the distribution of categorical levels"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2499,7 +2646,9 @@ supported_plots <- function() { plot_hbars = list( fun = "plot_hbars", descr = i18n$t("Stacked horizontal bars"), - note = i18n$t("A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), primary.type = c("dichotomous", "categorical"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2509,7 +2658,9 @@ supported_plots <- function() { plot_violin = list( fun = "plot_violin", descr = i18n$t("Violin plot"), - note = i18n$t("A modern alternative to the classic boxplot to visualise data distribution"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), primary.type = c("datatime", "continuous"), secondary.type = c("dichotomous", "categorical"), secondary.multi = FALSE, @@ -2557,7 +2708,9 @@ supported_plots <- function() { plot_euler = list( fun = "plot_euler", descr = i18n$t("Euler diagram"), - note = i18n$t("Generate area-proportional Euler diagrams to display set relationships"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), primary.type = c("dichotomous"), secondary.type = c("dichotomous"), secondary.multi = TRUE, @@ -2598,7 +2751,7 @@ possible_plots <- function(data) { out <- type } else { out <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { if (type %in% .x$primary.type) { .x$descr } @@ -2626,12 +2779,12 @@ possible_plots <- function(data) { #' get_plot_options() get_plot_options <- function(data) { descrs <- supported_plots() |> - lapply(\(.x){ + lapply(\(.x) { .x$descr }) |> unlist() supported_plots() |> - (\(.x){ + (\(.x) { .x[match(data, descrs)] })() } @@ -2645,6 +2798,7 @@ get_plot_options <- function(data) { #' @param sec secondary variable #' @param ter tertiary variable #' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. #' @param ... ignored for now #' #' @name data-plots @@ -2654,7 +2808,13 @@ get_plot_options <- function(data) { #' #' @examples #' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, type, pri, sec, ter = NULL, ...) { +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { if (!is.null(sec)) { if (!any(sec %in% names(data))) { sec <- NULL @@ -2671,13 +2831,11 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) { pri = pri, sec = sec, ter = ter, + color.palette = color.palette, ... ) - out <- do.call( - type, - modifyList(parameters, list(data = data)) - ) + out <- do.call(type, modifyList(parameters, list(data = data))) code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") @@ -2734,10 +2892,14 @@ get_label <- function(data, var = NULL) { #' @examples #' "Lorem ipsum... you know the routine" |> line_break() #' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, lineLength = 20, force = FALSE) { +line_break <- function(data, + lineLength = 20, + force = FALSE) { if (isTRUE(force)) { ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) } else { paste(strwrap(data, lineLength), collapse = "\n") } @@ -2769,9 +2931,9 @@ wrap_plot_list <- function(data, if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { out <- data |> - (\(.x){ + (\(.x) { if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i){ + purrr::imap(.x, \(.y, .i) { .y + ggplot2::ggtitle(.i) }) } else { @@ -2779,12 +2941,10 @@ wrap_plot_list <- function(data, } })() |> align_axes() |> - patchwork::wrap_plots( - guides = guides, - axes = axes, - axis_titles = axis_titles, - ... - ) + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) if (!is.null(tag_levels)) { out <- out + patchwork::plot_annotation(tag_levels = tag_levels) } @@ -2823,7 +2983,9 @@ wrap_plot_list <- function(data, #' @returns list of ggplot2 objects #' @export #' -align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -2841,7 +3003,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x){ + purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -2865,7 +3027,7 @@ align_axes <- function(..., x.axis = TRUE, y.axis = TRUE) { clean_common_axis <- function(p, axis) { purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> unlist() |> - (\(.x){ + (\(.x) { if (is.numeric(.x)) { range(.x) } else { @@ -3662,6 +3824,249 @@ footer_ui <- function(i18n) { } +######## +#### Current file: /Users/au301842/FreesearchR/R//generate_colors.R +######## + +#' Generate N Colors from a Specified Color Palette +#' +#' A flexible wrapper around multiple color palette libraries, returning N +#' colors as a character vector of hex codes. Supports palettes from +#' \pkg{viridisLite}, base R \pkg{grDevices}, and \pkg{RColorBrewer}. +#' +#' @param n \code{integer}. Number of colors to generate. Must be a positive +#' integer. +#' @param palette \code{character(1)}. Name of the color palette to use. +#' Case-insensitive. Supported options: +#' \describe{ +#' \item{\strong{viridisLite}}{`"viridis"`, `"magma"`, `"plasma"`, +#' `"inferno"`, `"cividis"`, `"mako"`, `"rocket"`, `"turbo"`} +#' \item{\strong{grDevices}}{`"hcl"`, `"rainbow"`, `"heat"`, +#' `"terrain"`, `"topo"`} +#' \item{\strong{RColorBrewer}}{Any palette name from +#' \code{RColorBrewer::brewer.pal.info}, e.g. `"Set1"`, `"Blues"`, +#' `"Dark2"`. If \code{n} exceeds the palette maximum, colors are +#' interpolated via \code{\link[grDevices]{colorRampPalette}}.} +#' } +#' @param ... Additional arguments passed to the underlying palette function. +#' For example, \code{alpha}, \code{direction}, \code{begin}, \code{end} +#' are forwarded to \code{\link[viridisLite]{viridis}}; \code{palette} is +#' forwarded to \code{\link[grDevices]{hcl.colors}}. +#' +#' @return A \code{character} vector of length \code{n} containing hex color +#' codes (e.g. \code{"#440154FF"}). +#' +#' @examples +#' # viridisLite palettes +#' generate_colors(5, "viridis") +#' generate_colors(5, "plasma") +#' generate_colors(5, "viridis", alpha = 0.8, direction = -1) +#' +#' # Base R grDevices +#' generate_colors(5, "rainbow") +#' generate_colors(8, "hcl", palette = "Dark 3") +#' +#' # RColorBrewer +#' generate_colors(5, "Set1") +#' generate_colors(5, "Blues") +#' generate_colors(12, "Set1") # interpolates beyond palette max of 9 +#' +#' # Drop-in replacement for viridisLite::viridis() +#' # generate_colors(n = length(levels(data_orig[[pri]])), palette = "viridis") +#' +#' @seealso +#' \code{\link[viridisLite]{viridis}}, +#' \code{\link[grDevices]{hcl.colors}}, +#' \code{\link[RColorBrewer]{brewer.pal}} +#' +#' @importFrom viridisLite viridis +#' @importFrom grDevices hcl.colors rainbow heat.colors terrain.colors +#' topo.colors colorRampPalette +#' @importFrom RColorBrewer brewer.pal brewer.pal.info +#' +#' @export +generate_colors <- function(n, palette = "viridis", ...) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + + # Function passthrough — call directly with n and ... + if (is.function(palette)) { + return(palette(n, ...)) + } + + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + + palette_lower <- tolower(palette) + + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) + + if (palette_lower %in% viridis_palettes) { + viridisLite::viridis(n = n, option = palette_lower, ...) + + } else if (palette_lower == "hcl") { + grDevices::hcl.colors(n = n, ...) + + } else if (palette_lower == "rainbow") { + grDevices::rainbow(n = n, ...) + + } else if (palette_lower == "heat") { + grDevices::heat.colors(n = n, ...) + + } else if (palette_lower == "terrain") { + grDevices::terrain.colors(n = n, ...) + + } else if (palette_lower == "topo") { + grDevices::topo.colors(n = n, ...) + + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) + } +} + + +#' Create a Continuous Color Function from a Palette +#' +#' Wraps \code{\link{generate_colors}} into a function that accepts a value +#' between 0 and 1 and returns the corresponding color. Useful for mapping +#' continuous variables to colors. +#' +#' @param palette Passed directly to [generate_colors()]. Either a palette +#' name string or a function. +#' @param n \code{integer}. Resolution of the underlying color ramp — higher +#' values give smoother gradients. Defaults to 256. +#' @param ... Additional arguments passed to [generate_colors()]. +#' +#' @return A function that takes a numeric vector of values in \code{[0, 1]} +#' and returns a character vector of hex colors. +#' +#' @examples +#' pal <- continuous_colors("viridis") +#' pal(0) # first color +#' pal(1) # last color +#' pal(0.5) # midpoint +#' +#' # Map a continuous variable to colors +#' values <- seq(0, 1, length.out = 10) +#' pal(values) +#' +#' # Works with any palette generate_colors() accepts +#' pal <- continuous_colors("plasma", direction = -1) +#' pal <- continuous_colors(\(n) hcl.colors(n, palette = "Blue-Red")) +#' +#' @seealso [generate_colors()] +#' @export +continuous_colors <- function(palette = "viridis", n = 256, ...) { + colors <- generate_colors(n, palette, ...) + ramp <- grDevices::colorRamp(colors) + + function(x) { + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") + rgb_vals <- ramp(x) + grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) + } +} + + +#' Discrete and Continuous Fill Scale Using generate_colors +#' +#' Drop-in replacement for [viridis::scale_fill_viridis()] that works with +#' any palette supported by [generate_colors()]. +#' +#' @param palette Passed to [generate_colors()]. Either a palette name string +#' or a function. +#' @param discrete \code{logical}. If \code{TRUE} (default), a discrete scale +#' is returned. If \code{FALSE}, a continuous scale is returned. +#' @param ... Additional arguments passed to [ggplot2::scale_fill_manual()] +#' (discrete) or [ggplot2::scale_fill_gradientn()] (continuous). +#' +#' @examples +#' library(ggplot2) +#' +#' # Discrete +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = factor(cyl))) + +#' geom_col() + +#' scale_fill_generate(palette = "Set1") +#' +#' # Continuous +#' ggplot(mtcars, aes(x = wt, y = mpg, fill = mpg)) + +#' geom_point(shape = 21, size = 3) + +#' scale_fill_generate(palette = "viridis", discrete = FALSE) +#' +#' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] +#' @export +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "fill", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} + +#' @rdname scale_fill_generate +#' @examples +#' ggplot(mtcars, aes(x = wt, y = mpg, color = factor(cyl))) + +#' geom_point() + +#' scale_color_generate(palette = "Set1") +#' @export +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { + if (discrete) { + ggplot2::discrete_scale( + aesthetics = "colour", + palette = function(n) generate_colors(n, palette), + ... + ) + } else { + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## @@ -4514,7 +4919,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.4-260323' +hosted_version <- function()'v26.3.4-260324' ######## @@ -6495,7 +6900,8 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), max_level = 30, ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6510,7 +6916,8 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi pri = pri, sec = sec, style = style, - max_level = max_level + max_level = max_level, + color.palette = color.palette ) }) @@ -6535,8 +6942,9 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar_single(pri = "cyl", style = "stack") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30) { +#' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, + color.palette = "viridis") { style <- match.arg(style) if (identical(sec, "none")) { @@ -6595,6 +7003,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " ) + ggplot2::geom_bar(position = style, stat = "identity") + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + ggplot2::ylab("Percentage") + ggplot2::xlab(get_label(data,pri))+ ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) @@ -6648,7 +7057,7 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " #' mtcars |> #' default_parsing() |> #' plot_box(pri = "mpg", sec = "cyl", ter = "gear",axis.font.family="mono") -plot_box <- function(data, pri, sec, ter = NULL,...) { +plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -6659,7 +7068,8 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { plot_box_single( data = .ds, pri = pri, - sec = sec + sec = sec, + color.palette=color.palette ) }) @@ -6676,9 +7086,10 @@ plot_box <- function(data, pri, sec, ter = NULL,...) { #' #' @examples #' mtcars |> plot_box_single("mpg") -#' mtcars |> plot_box_single("mpg","cyl") +#' mtcars |> plot_box_single("mpg","cyl",color.palette="Blues") +#' stRoke::trial |> plot_box_single("age","active",color.palette="Blues") #' gtsummary::trial |> plot_box_single("age","trt") -plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { +plot_box_single <- function(data, pri, sec=NULL, seed = 2103,color.palette="viridis") { set.seed(seed) if (is.null(sec)) { @@ -6696,7 +7107,7 @@ plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { ggplot2::xlab(get_label(data,pri))+ ggplot2::ylab(get_label(data,sec)) + ggplot2::coord_flip() + - viridis::scale_fill_viridis(discrete = discrete, option = "D") + + scale_fill_generate(discrete = discrete,palette = color.palette) + # ggplot2::theme_void() + ggplot2::theme_bw(base_size = 24) + ggplot2::theme( @@ -6827,7 +7238,7 @@ ggeulerr <- function( #' plot_euler("mfi_cut", "mdi_cut") #' stRoke::trial |> #' plot_euler(pri="male", sec=c("hypertension")) -plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="viridis") { set.seed(seed = seed) if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -6837,7 +7248,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { out <- lapply(ds, \(.x){ .x[c(pri, sec)] |> na.omit() |> - plot_euler_single() + plot_euler_single(color.palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) @@ -6855,16 +7266,12 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { #' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() -#' mtcars[c("vs", "am")] |> plot_euler_single() -plot_euler_single <- function(data) { - # if (any("categorical" %in% data_type(data))){ - # shape <- "ellipse" - # } else { - # shape <- "circle" - # } +#' mtcars[c("vs", "am")] |> plot_euler_single("magma") +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + + scale_fill_generate(palette=color.palette) + ggplot2::theme_void() + ggplot2::theme( legend.position = "none", @@ -6896,11 +7303,21 @@ plot_euler_single <- function(data) { #' @examples #' mtcars |> plot_hbars(pri = "carb", sec = "cyl") #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_hbars(pri = "carb", sec = NULL) -plot_hbars <- function(data, pri, sec, ter = NULL) { - out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) - - out +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") +plot_hbars <- function(data, + pri, + sec, + ter = NULL, + color.palette = "viridis") { + vertical_stacked_bars( + data = data, + score = pri, + group = sec, + strata = ter, + color.palette = color.palette + ) } @@ -6923,7 +7340,9 @@ vertical_stacked_bars <- function(data, l.color = "black", l.size = .5, draw.lines = TRUE, - label.str="{n}\n{round(100 * p,0)}%") { + label.str = "{n}\n{round(100 * p,0)}%", + color.palette = "viridis", + reverse = TRUE) { if (is.null(group)) { df.table <- data[c(score, group, strata)] |> dplyr::mutate("All" = 1) |> @@ -6948,15 +7367,19 @@ vertical_stacked_bars <- function(data, returnData = TRUE ) - colors <- viridisLite::viridis(nrow(df.table)) + colors <- generate_colors(n = nrow(df.table), palette = color.palette) + ## Colors are reversed by default as that usually gives the best result + if (isTRUE(reverse)) { + colors <- rev(colors) + } contrast_cut <- - sum(contrast_text(colors, threshold = .3) == "white") + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) p |> - (\(.x){ + (\(.x) { .x$plot + ggplot2::geom_text( data = .x$rectData[which(.x$rectData$n > @@ -6966,21 +7389,19 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = as.numeric(score) > contrast_cut, + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) ) ) + ggplot2::labs(fill = score_label) + - ggplot2::scale_fill_manual(values = rev(colors)) + - ggplot2::theme( - legend.position = "bottom", - axis.title = ggplot2::element_text(), + ggplot2::scale_fill_manual(values = colors) + + ggplot2::theme(legend.position = "bottom", + axis.title = ggplot2::element_text(), ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) - # viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D") })() } @@ -7001,7 +7422,7 @@ vertical_stacked_bars <- function(data, #' default_parsing() |> #' plot_ridge(x = "mpg", y = "cyl") #' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") -plot_ridge <- function(data, x, y, z = NULL, ...) { +plot_ridge <- function(data, x, y, z = NULL, color.palette="viridis", ...) { if (!is.null(z)) { ds <- split(data, data[z]) } else { @@ -7012,6 +7433,7 @@ plot_ridge <- function(data, x, y, z = NULL, ...) { ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) + ggridges::geom_density_ridges() + ggridges::theme_ridges() + + scale_fill_generate(palette=color.palette) + ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa() }) @@ -7044,7 +7466,7 @@ sankey_ready <- function(data, pri, sec, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(pri, sec)] <- data[c(pri, sec)] |> + data <- data[c(pri, sec)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE) @@ -7109,15 +7531,17 @@ str_remove_last <- function(data, pattern = "\n") { #' ## Dont know why... #' mtcars |> #' default_parsing() |> -#' plot_sankey("cyl", "gear", "vs", color.group = "pri") -#' -#' # stRoke::trial |> plot_sankey("mrs_1", "mrs_6") +#' plot_sankey("cyl", "gear", "vs", color.group = "pri",color.palette="inferno") plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL, + color.palette = "viridis", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) @@ -7125,12 +7549,14 @@ plot_sankey <- function(data, ds <- list(data) } + # browser() out <- lapply(ds, \(.ds) { plot_sankey_single( .ds, pri = pri, sec = sec, + color.palette = color.palette, color.group = color.group, colors = colors, missing.level = missing.level @@ -7168,67 +7594,67 @@ plot_sankey <- function(data, #' stRoke::trial |> #' default_parsing() |> #' plot_sankey_single("diabetes", "hypertension") +#' +#' +#' # stRoke::trial |> plot_sankey_single("mrs_1", "mrs_6", color.palette="magma") +#' # stRoke::trial |> plot_sankey_single("active", "male") +#' # stRoke::trial |> plot_sankey_single("diabetes", "active", color.group="sec") +#' # stRoke::trial |> plot_sankey_single("active", "diabetes", color.group="sec", color.palette="topo") plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), - colors = NULL, + color.palette = "viridis", + colors=NULL, missing.level = "Missing", + default.color = "#2986cc", + box.color = "#1E4B66", + na.color = "grey80", ...) { color.group <- match.arg(color.group) - - # browser() - # if (is.na(ds[c(pri,sec)])) - - # browser() data_orig <- data - data[c(pri, sec)] <- data[c(pri, sec)] |> - dplyr::mutate( - dplyr::across(dplyr::where(is.logical), as.factor), - dplyr::across(dplyr::where(is.factor), forcats::fct_drop), - dplyr::across(dplyr::where(is.factor), \(.x) { - forcats::fct_na_value_to_level(.x, missing.level) - }) - ) + data[c(pri, sec)] <- with_labels(data,{ + data[c(pri, sec)] |> + to_clean_levels() |> + missing_to_text_levels(missing.text=missing.level) + }) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) + ## Aggregate data + data_aggr <- data |> sankey_ready(pri = pri, sec = sec, ...) - na.color <- "#2986cc" - box.color <- "#1E4B66" + default.color = default.color + box.color = box.color + na.color = na.color if (is.null(colors)) { if (color.group == "sec") { - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] + main.colors <- color_levels_gen(data_orig[[sec]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + secondary.colors <- rep(default.color, length(levels(data[[pri]]))) label.colors <- Reduce(c, lapply(list( secondary.colors, rev(main.colors) ), contrast_text)) } else { - main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) - ## Only keep colors for included levels - main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] + main.colors <- color_levels_gen(data_orig[[pri]],palette=color.palette) - secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + secondary.colors <- rep(default.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list( rev(main.colors), secondary.colors ), contrast_text)) } - colors <- c(na.color, main.colors, secondary.colors) - colors[is.na(colors)] <- "grey80" + colors <- c(default.color, main.colors, secondary.colors) + colors[is.na(colors)] <- na.color } else { label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data_orig, pri), get_label(data_orig, sec)) |> + group_labels <- c(get_label(data, pri), get_label(data, sec)) |> sapply(line_break) |> unname() - p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) + p <- ggplot2::ggplot(data_aggr, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) if (color.group == "sec") { p <- p + @@ -7291,6 +7717,51 @@ plot_sankey_single <- function(data, } +# stRoke::trial["male"] |> to_clean_levels() +to_clean_levels <- function(data,missing.text="Missing"){ + if (is.data.frame(data)){ + data |> + lapply(all_levels_clean) |> + dplyr::bind_cols() + } else { + data |> + all_levels_clean() + } + + + +} + +# stRoke::trial["mrs_1"] |> missing_to_text_levels() +missing_to_text_levels <- function(data,missing.text="Missing"){ + data |> + dplyr::mutate( + dplyr::across(dplyr::where(is.factor), \(.x) { + if (anyNA(.x)) forcats::fct_na_value_to_level(.x, missing.text) else .x + }) + ) +} + +all_levels_clean <- function(data){ + data |> + (\(.x){ + if (is.logical(.x)) as.factor(.x) else .x + })() |> + (\(.x){ + if (is.factor(.x)) forcats::fct_drop(.x) else .x + })() +} + +# stRoke::trial$mrs_1 |> color_levels_gen() +color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ + out <- generate_colors(n = length(levels(to_clean_levels(data))),palette = palette) + if (anyNA(data)){ + out <- c(out,na.color) + } + out +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//plot_scatter.R ######## @@ -7304,7 +7775,8 @@ plot_sankey_single <- function(data, #' #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") -plot_scatter <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -7321,7 +7793,8 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { group = ter, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_color_generate(palette=color.palette) } } @@ -7330,7 +7803,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_violin.R ######## -#' Beatiful violin plot +#' Beautiful violin plot #' #' @returns ggplot2 object #' @export @@ -7338,8 +7811,9 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { #' @name data-plots #' #' @examples -#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") -plot_violin <- function(data, pri, sec, ter = NULL) { +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl") +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7355,7 +7829,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) { response = pri, xtitle = get_label(data, var = sec), ytitle = get_label(data, var = pri) - ) + )+ + scale_fill_generate(palette=color.palette) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 15991bfe..ce9abc8e 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -89,7 +89,6 @@ "No variables have a correlation measure above the threshold.","Ingen variabler er korrelerede over den angivne tærskelværdi." "and","og" "from each pair","fra hvert par" -"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Kun variabler, der ikke er klassificerede som tekst er tilgængelige. Gå til fanen ""Forbered"" for at ændre klassifikationer." "Plot","Tegn" "Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" @@ -108,9 +107,7 @@ "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" -"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","En klassisk visualisering af fordelingen af observationer på en ordinal kategorisk skala. Typisk brugt til modified Rankin Scale og kendes også som 'Grotta bars'" "Violin plot","Violin-diagram" -"A modern alternative to the classic boxplot to visualise data distribution","Moderne alternativ til den klassiske box-plot og velegnet til at visualisere fordelingen af observationer" "Sankey plot","Sankey-diagram" "A way of visualising change between groups","Visualiserer ændring mellem grupper for samme type observationer" "Scatter plot","Punkt-diagram" @@ -118,7 +115,6 @@ "Box plot","Kasse-diagram" "A classic way to plot data distribution by groups","Klassik måde at visualisere fordeling" "Euler diagram","Eulerdiagram" -"Generate area-proportional Euler diagrams to display set relationships","Generer proportionelt Euler-diagram for at vise forhold mellem forskellige kategoriske observationer" "Documentation","Dokumentation" "Data is only stored for analyses and deleted when the app is closed.","Data opbevares alene til brug i analyser og slettes så snart appen lukkes." "Feedback","Feedback" @@ -232,9 +228,7 @@ "Split text","Opdel tekst" "Apply split","Anvend opdeling" "Stacked relative barplot","Stablet relativt søjlediagram" -"Create relative stacked barplots to show the distribution of categorical levels","Opret relative stablede søjlediagrammer for at vise fordelingen af kategoriske niveauer" "Side-by-side barplot","Side om side barplot" -"Create side-by-side barplot to show the distribution of categorical levels","Opret et side-om-side søjlediagram for at vise fordelingen af kategoriske niveauer" "Select table theme","Vælg tema" "Letters","Bogstaver" "Words","Ord" @@ -328,3 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" +"Choose color palette","Choose color palette" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 4388ae6e..96a7a109 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -89,7 +89,6 @@ "No variables have a correlation measure above the threshold.","Hakuna vigezo vyenye kipimo cha uhusiano kilicho juu ya kizingiti." "and","na" "from each pair","kutoka kwa kila jozi" -"Only non-text variables are available for plotting. Go the ""Data"" to reclass data to plot.","Vigezo visivyo vya maandishi pekee ndivyo vinavyopatikana kwa ajili ya kupanga. Nenda kwenye ""Data"" ili kupanga upya data ili kupanga." "Plot","Kipande cha habari" "Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" @@ -108,9 +107,7 @@ "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" -"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars","Njia ya kitamaduni ya kuibua usambazaji wa mizani ya kawaida kama vile Mizani ya Nafasi iliyorekebishwa na inayojulikana kama baa za Grotta" "Violin plot","Hadithi ya violin" -"A modern alternative to the classic boxplot to visualise data distribution","Njia mbadala ya kisasa ya mpangilio wa kisanduku wa kawaida ili kuibua usambazaji wa data" "Sankey plot","Njama ya Sankey" "A way of visualising change between groups","Njia ya kuibua mabadiliko kati ya vikundi" "Scatter plot","Njama ya kutawanya" @@ -118,7 +115,6 @@ "Box plot","Kipande cha sanduku" "A classic way to plot data distribution by groups","Njia ya kawaida ya kupanga usambazaji wa data kwa vikundi" "Euler diagram","Mchoro wa Euler" -"Generate area-proportional Euler diagrams to display set relationships","Tengeneza michoro ya Euler inayolingana na eneo ili kuonyesha uhusiano uliowekwa" "Documentation","Nyaraka" "Data is only stored for analyses and deleted when the app is closed.","Data huhifadhiwa kwa ajili ya uchambuzi na kufutwa tu wakati programu imefungwa." "Feedback","Maoni" @@ -232,9 +228,7 @@ "No character variables with accepted delimiters detected.","Hakuna vigezo vya herufi vilivyo na vidhibiti vinavyokubalika vilivyogunduliwa." "Apply split","Tumia mgawanyiko" "Stacked relative barplot","Kipande cha baruni kilichopangwa kwa mirundiko" -"Create relative stacked barplots to show the distribution of categorical levels","Unda viwanja vya baruni vilivyopangwa ili kuonyesha usambazaji wa viwango vya kategoria" "Side-by-side barplot","Kipande cha baruni cha kando kwa kando" -"Create side-by-side barplot to show the distribution of categorical levels","Unda mpangilio wa barufa kando ili kuonyesha usambazaji wa viwango vya kategoria" "Select table theme","Chagua mandhari ya jedwali" "Letters","Barua" "Words","Maneno" @@ -328,3 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" +"Choose color palette","Choose color palette" From 8961bc6a5dc1aca802a7fab702c12d8dd138b8ee Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 24 Mar 2026 12:19:01 +0100 Subject: [PATCH 25/62] update for docker --- app_docker/Dockerfile | 2 +- app_docker/app.R | 2 +- inst/apps/FreesearchR/app.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/app_docker/Dockerfile b/app_docker/Dockerfile index 029da51f..9ef0df98 100644 --- a/app_docker/Dockerfile +++ b/app_docker/Dockerfile @@ -1,5 +1,5 @@ FROM rocker/tidyverse:4.5.2 -RUN apt-get update -y && apt-get install -y cmake make libcurl4-openssl-dev libicu-dev libssl-dev pandoc zlib1g-dev libsecret-1-dev libxml2-dev libx11-dev libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev libharfbuzz-dev libjpeg-dev libpng-dev libtiff-dev libwebp-dev libfftw3-dev && rm -rf /var/lib/apt/lists/* +RUN apt-get update -y && apt-get install -y cmake make libcurl4-openssl-dev libicu-dev libuv1-dev libssl-dev pandoc zlib1g-dev libsecret-1-dev libxml2-dev libx11-dev libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev libharfbuzz-dev libjpeg-dev libpng-dev libtiff-dev libwebp-dev libfftw3-dev && rm -rf /var/lib/apt/lists/* RUN mkdir -p /usr/local/lib/R/etc/ /usr/lib/R/etc/ RUN echo "options(renv.config.pak.enabled = FALSE, repos = c(CRAN = 'https://cran.rstudio.com/'), download.file.method = 'libcurl', Ncpus = 4)" | tee /usr/local/lib/R/etc/Rprofile.site | tee /usr/lib/R/etc/Rprofile.site RUN R -e 'install.packages("remotes")' diff --git a/app_docker/app.R b/app_docker/app.R index fb454111..c63e5dbc 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b6eb25f5.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b70a52556.R ######## i18n_path <- here::here("translations") diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index a269e9d6..1b6bf0c1 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//RtmpoawSeD/fileab3b2f3ac087.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b7554cf72.R ######## i18n_path <- system.file("translations", package = "FreesearchR") From 692776a85798414a9bcebea81acc98c2adf3a16f Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 24 Mar 2026 12:36:59 +0100 Subject: [PATCH 26/62] new renv --- app_docker/app.R | 2 +- app_docker/renv.lock | 18 ++++++++---------- renv.lock | 18 ++++++++---------- 3 files changed, 17 insertions(+), 21 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index c63e5dbc..f0730264 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b70a52556.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp6ZofsJ/filec1211b275686.R ######## i18n_path <- here::here("translations") diff --git a/app_docker/renv.lock b/app_docker/renv.lock index 96709a25..0672c287 100644 --- a/app_docker/renv.lock +++ b/app_docker/renv.lock @@ -35,12 +35,12 @@ }, "DHARMa": { "Package": "DHARMa", - "Version": "0.4.7", + "Version": "0.4.6", "Source": "Repository", "Title": "Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models", - "Date": "2024-10-16", - "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"), person(\"Melina\", \"de Souza leite\", role = \"ctb\"))", - "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB', 'GLMMadaptive', and 'spaMM'; phylogenetic linear models from 'phylolm' (classes 'phylolm' and 'phyloglm'); generalized additive models ('gam' from 'mgcv'); 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial, phylogenetic and temporal autocorrelation.", + "Date": "2022-09-08", + "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"))", + "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB' 'GLMMadaptive' and 'spaMM', generalized additive models ('gam' from 'mgcv'), 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial and temporal autocorrelation.", "Depends": [ "R (>= 3.0.2)" ], @@ -59,7 +59,7 @@ ], "Suggests": [ "knitr", - "testthat (>= 3.0.0)", + "testthat", "rmarkdown", "KernSmooth", "sfsmisc", @@ -68,8 +68,7 @@ "mgcViz (>= 0.1.9)", "spaMM (>= 3.2.0)", "GLMMadaptive", - "glmmTMB (>= 1.1.2.3)", - "phylolm (>= 2.6.5)" + "glmmTMB (>= 1.1.2.3)" ], "Enhances": [ "phyr", @@ -81,12 +80,11 @@ "URL": "http://florianhartig.github.io/DHARMa/", "LazyData": "TRUE", "BugReports": "https://github.com/florianhartig/DHARMa/issues", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.2.1", "VignetteBuilder": "knitr", "Encoding": "UTF-8", - "Config/testthat/edition": "3", "NeedsCompilation": "no", - "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb], Melina de Souza leite [ctb]", + "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb]", "Maintainer": "Florian Hartig ", "Repository": "CRAN" }, diff --git a/renv.lock b/renv.lock index 96709a25..0672c287 100644 --- a/renv.lock +++ b/renv.lock @@ -35,12 +35,12 @@ }, "DHARMa": { "Package": "DHARMa", - "Version": "0.4.7", + "Version": "0.4.6", "Source": "Repository", "Title": "Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models", - "Date": "2024-10-16", - "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"), person(\"Melina\", \"de Souza leite\", role = \"ctb\"))", - "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB', 'GLMMadaptive', and 'spaMM'; phylogenetic linear models from 'phylolm' (classes 'phylolm' and 'phyloglm'); generalized additive models ('gam' from 'mgcv'); 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial, phylogenetic and temporal autocorrelation.", + "Date": "2022-09-08", + "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"))", + "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB' 'GLMMadaptive' and 'spaMM', generalized additive models ('gam' from 'mgcv'), 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial and temporal autocorrelation.", "Depends": [ "R (>= 3.0.2)" ], @@ -59,7 +59,7 @@ ], "Suggests": [ "knitr", - "testthat (>= 3.0.0)", + "testthat", "rmarkdown", "KernSmooth", "sfsmisc", @@ -68,8 +68,7 @@ "mgcViz (>= 0.1.9)", "spaMM (>= 3.2.0)", "GLMMadaptive", - "glmmTMB (>= 1.1.2.3)", - "phylolm (>= 2.6.5)" + "glmmTMB (>= 1.1.2.3)" ], "Enhances": [ "phyr", @@ -81,12 +80,11 @@ "URL": "http://florianhartig.github.io/DHARMa/", "LazyData": "TRUE", "BugReports": "https://github.com/florianhartig/DHARMa/issues", - "RoxygenNote": "7.3.2", + "RoxygenNote": "7.2.1", "VignetteBuilder": "knitr", "Encoding": "UTF-8", - "Config/testthat/edition": "3", "NeedsCompilation": "no", - "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb], Melina de Souza leite [ctb]", + "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb]", "Maintainer": "Florian Hartig ", "Repository": "CRAN" }, From 7408227788c5054cc6144085d2257aff2a87ebb7 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 24 Mar 2026 13:51:24 +0100 Subject: [PATCH 27/62] updated renv --- app_docker/app.R | 2 +- app_docker/renv.lock | 8 ++++---- renv.lock | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index f0730264..c18c6f99 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp6ZofsJ/filec1211b275686.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmpn21sEQ/filec83e64988776.R ######## i18n_path <- here::here("translations") diff --git a/app_docker/renv.lock b/app_docker/renv.lock index 0672c287..567601cc 100644 --- a/app_docker/renv.lock +++ b/app_docker/renv.lock @@ -2345,7 +2345,7 @@ }, "datamods": { "Package": "datamods", - "Version": "1.5.3", + "Version": "1.5.2", "Source": "Repository", "Title": "Modules to Import and Manipulate Data in 'Shiny'", "Authors@R": "c(person(given = \"Victor\", family = \"Perrier\", role = c(\"aut\", \"cre\", \"cph\"), email = \"victor.perrier@dreamrs.fr\"), person(given = \"Fanny\", family = \"Meyer\", role = \"aut\"), person(given = \"Samra\", family = \"Goumri\", role = \"aut\"), person(given = \"Zauad Shahreer\", family = \"Abeer\", role = \"aut\", email = \"shahreyar.abeer@gmail.com\"), person(given = \"Eduard\", family = \"Szöcs\", role = \"ctb\", email = \"eduardszoecs@gmail.com\") )", @@ -8357,7 +8357,7 @@ }, "shinybusy": { "Package": "shinybusy", - "Version": "0.3.3", + "Version": "0.3.2", "Source": "Repository", "Title": "Busy Indicators and Notifications for 'Shiny' Applications", "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))", @@ -8370,8 +8370,8 @@ "jsonlite", "htmlwidgets" ], - "RoxygenNote": "7.3.1", - "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/", + "RoxygenNote": "7.2.3", + "URL": "https://github.com/dreamRs/shinybusy", "BugReports": "https://github.com/dreamRs/shinybusy/issues", "Suggests": [ "testthat", diff --git a/renv.lock b/renv.lock index 0672c287..567601cc 100644 --- a/renv.lock +++ b/renv.lock @@ -2345,7 +2345,7 @@ }, "datamods": { "Package": "datamods", - "Version": "1.5.3", + "Version": "1.5.2", "Source": "Repository", "Title": "Modules to Import and Manipulate Data in 'Shiny'", "Authors@R": "c(person(given = \"Victor\", family = \"Perrier\", role = c(\"aut\", \"cre\", \"cph\"), email = \"victor.perrier@dreamrs.fr\"), person(given = \"Fanny\", family = \"Meyer\", role = \"aut\"), person(given = \"Samra\", family = \"Goumri\", role = \"aut\"), person(given = \"Zauad Shahreer\", family = \"Abeer\", role = \"aut\", email = \"shahreyar.abeer@gmail.com\"), person(given = \"Eduard\", family = \"Szöcs\", role = \"ctb\", email = \"eduardszoecs@gmail.com\") )", @@ -8357,7 +8357,7 @@ }, "shinybusy": { "Package": "shinybusy", - "Version": "0.3.3", + "Version": "0.3.2", "Source": "Repository", "Title": "Busy Indicators and Notifications for 'Shiny' Applications", "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))", @@ -8370,8 +8370,8 @@ "jsonlite", "htmlwidgets" ], - "RoxygenNote": "7.3.1", - "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/", + "RoxygenNote": "7.2.3", + "URL": "https://github.com/dreamRs/shinybusy", "BugReports": "https://github.com/dreamRs/shinybusy/issues", "Suggests": [ "testthat", From 748a3c3e07a668974d4725fc3d45845e4111b7b1 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 27 Mar 2026 21:54:19 +0100 Subject: [PATCH 28/62] feat: dropped auto dropping empty factor levels --- R/helpers.R | 4 ++-- R/update-factor-ext.R | 44 +++++++++++++++++++++++++++++++++++++++---- 2 files changed, 42 insertions(+), 6 deletions(-) diff --git a/R/helpers.R b/R/helpers.R index adc12777..514cf6a4 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -230,8 +230,8 @@ default_parsing <- function(data) { REDCapCAST::as_factor() |> REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> - REDCapCAST::as_logical() |> - REDCapCAST::fct_drop() + REDCapCAST::as_logical() #|> + # REDCapCAST::fct_drop() }) # out <- # diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index ad1b263c..93f35910 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -29,15 +29,26 @@ update_factor_ui <- function(id) { ), fluidRow( column( - width = 6, + width = 3, shinyWidgets::virtualSelectInput( inputId = ns("variable"), - label = i18n$t("Factor variable to reorder:"), + label = i18n$t("Choose variable:"), choices = NULL, width = "100%", zIndex = 50 ) ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + disabled = TRUE, + inputId = ns("drop_levels"), + label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ), column( width = 3, class = "d-flex align-items-end", @@ -70,7 +81,9 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), + label = i18n$t( + "Create a new variable; otherwise replaces (Updating labels always creates new variable)" + ), value = FALSE, status = "primary", outline = TRUE, @@ -125,6 +138,20 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- grid }) + observeEvent(rv$data_grid, { + variable <- req(input$variable) + if (isTRUE(has_empty_levels(rv$data[[variable]]))) { + # browser() + updateActionButton(inputId = "drop_levels", disabled = FALSE) + } else { + updateActionButton(inputId = "drop_levels", disabled = TRUE) + } + }) + + observeEvent(input$drop_levels, { + rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,] + }) + observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -208,7 +235,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { ) data <- tryCatch({ - with_labels(data,{ + with_labels(data, { rlang::exec(factor_new_levels_labels, !!!modifyList(parameters, val = list(data = data))) }) @@ -370,3 +397,12 @@ unique_names <- function(new, existing = character()) { new_names[-seq_along(existing)] } + + +has_empty_levels <- function(x) { + if (is.factor(x)) { + any(!levels(x) %in% x) + } else { + return(FALSE) + } +} From 9b4ddafe6f086aa3a0e4aef011de4d4320d0d00e Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 27 Mar 2026 21:56:57 +0100 Subject: [PATCH 29/62] fix: keep level labels --- R/redcap_read_shiny_module.R | 378 ++++++++++++++++++----------------- 1 file changed, 194 insertions(+), 184 deletions(-) diff --git a/R/redcap_read_shiny_module.R b/R/redcap_read_shiny_module.R index a74c599a..2b26d929 100644 --- a/R/redcap_read_shiny_module.R +++ b/R/redcap_read_shiny_module.R @@ -11,10 +11,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4( - i18n$t("Import data from REDCap"), - class = "redcap-module-title" - ) + title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") } server_ui <- shiny::tagList( @@ -25,7 +22,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), + shiny::helpText( + i18n$t( + "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" + ) + ), shiny::br(), shiny::br(), shiny::passwordInput( @@ -34,7 +35,9 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), + shiny::helpText(i18n$t( + "The token is a string of 32 numbers and letters." + )), shiny::br(), shiny::br(), shiny::actionButton( @@ -51,7 +54,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) + tags$p( + phosphoricons::ph("info", weight = "bold"), + i18n$t("Please fill in web address and API token, then press 'Connect'.") + ) ), dismissible = TRUE ), @@ -64,8 +70,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" - )) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") + ) ) params_ui <- @@ -96,7 +102,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ) ) ), - shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), + shiny::helpText( + i18n$t( + "Select fields/variables to import and click the funnel to apply optional filters" + ) + ), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -115,7 +125,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") + tags$p( + phosphoricons::ph("info", weight = "bold"), + "Please specify data to download, then press 'Import'." + ) ), dismissible = TRUE ) @@ -126,11 +139,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel( - condition = "output.connect_success == true", - params_ui, - ns = ns - ), + shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), shiny::br() ) } @@ -162,7 +171,11 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") + uri <- paste0(ifelse( + endsWith(input$uri, "/"), + input$uri, + paste0(input$uri, "/") + ), "api/") } else { uri <- input$uri } @@ -176,75 +189,68 @@ m_redcap_readServer <- function(id) { }) - tryCatch( - { - shiny::observeEvent( - list( - input$data_connect - ), - { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch({ + shiny::observeEvent(list(input$data_connect), { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list( - redcap_uri = data_rv$uri, - token = input$api - ) + parameters <- list(redcap_uri = data_rv$uri, token = input$api) - # browser() - shiny::withProgress( - { - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) - }, - message = paste("Connecting to", data_rv$uri) - ) + # browser() + shiny::withProgress({ + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), + silent = TRUE) + }, message = paste("Connecting to", data_rv$uri)) - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || + NROW(imported) < 1 || + ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), + !isTRUE(imported$success), + FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" - data_rv$info <- REDCapR::redcap_project_info_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), - glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) - ), - btn_show_data = TRUE + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b( + phosphoricons::ph("check", weight = "bold"), + i18n$t("Connected to server!") + ), + glue::glue( + i18n$t( + "The {data_rv$info$project_title} project is loaded." + ) ) - ) + ), + btn_show_data = TRUE + ) + ) - data_rv$dd_list <- imported - } - }, - ignoreInit = TRUE - ) - }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - ) + data_rv$dd_list <- imported + } + }, ignoreInit = TRUE) + }, warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { + showNotification(paste0(err), type = "err") + }) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -275,10 +281,7 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data }) output$fields <- shiny::renderUI({ @@ -288,7 +291,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x){ + (\(.x) { split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -321,14 +324,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[ - data_rv$dd_list$data$form_name %in% repeated_instruments( - uri = data_rv$uri, - token = input$api - ) - ] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] - if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && + isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -370,7 +369,6 @@ m_redcap_readServer <- function(id) { # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] - parameters <- list( uri = data_rv$uri, token = input$api, @@ -386,26 +384,31 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) + imported <- tryCatch(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), + silent = TRUE) }) - parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] + # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) - code <- rlang::call2( - "easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST" - ) + parameters_code <- parameters[c("uri", + "fields", + "events", + "raw_or_label", + "filter_logic")] + + code <- rlang::call2("easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST") if (inherits(imported, "try-error") || NROW(imported) < 1) { data_rv$data_status <- "error" @@ -419,7 +422,6 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { - # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() @@ -442,78 +444,91 @@ m_redcap_readServer <- function(id) { } } - # browser() + ## Ensure correct factor labels + ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way + out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) + + in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) + sapply(names(out), \(.x) any(sapply( + parameters$fields, \(.y) startsWith(.x, .y) + ))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } data_rv$code <- code + ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() + } }) - shiny::observeEvent( - data_rv$data_status, - { - # browser() - if (identical(data_rv$data_status, "error")) { - datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) - ), - btn_show_data = TRUE - ) - ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), + shiny::observeEvent(data_rv$data_status, { + # browser() + if (identical(data_rv$data_status, "error")) { + datamods:::insert_error(mssg = data_rv$data_message, + selector = ns("retrieved")) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p(tags$b( + phosphoricons::ph("check", weight = "bold"), data_rv$data_message - ) + )), + btn_show_data = TRUE ) - } + ) + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message + ) + ) } - ) + }) - return(list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - )) + return( + list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + ) + ) } - shiny::moduleServer( - id = id, - module = module - ) + shiny::moduleServer(id = id, module = module) } #' @importFrom htmltools tagList tags @@ -524,14 +539,12 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList( - extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - ) - ) + success_message <- tagList(extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + )) } return(success_message) } @@ -583,20 +596,18 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { +is_valid_token <- function(token, + pattern_env = NULL, + nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, - any.missing = FALSE, - len = 1 - ) + checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">" - ) + .open = "<", + .close = ">") } if (is.na(token)) { @@ -636,10 +647,15 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") + generics <- c( + names(data)[1], + "redcap_event_name", + "redcap_repeat_instrument", + "redcap_repeat_instance" + ) filt <- split(data, data[[event]]) |> - lapply(\(.x){ + lapply(\(.x) { dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -667,16 +683,10 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable( - { - shiny::req(data_val$data) - data_val$data() - }, - options = list( - scrollX = TRUE, - pageLength = 5 - ), - ) + output$data <- DT::renderDataTable({ + shiny::req(data_val$data) + data_val$data() + }, options = list(scrollX = TRUE, pageLength = 5), ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code() From ce0ecef633ac2e56c6cbbbb52658bb07342a3b32 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:16:33 +0200 Subject: [PATCH 30/62] fix: adjusted to not allow typing --- R/custom_SelectInput.R | 48 +++++++++++++++++++++++++---------------- man/colorSelectInput.Rd | 2 +- 2 files changed, 31 insertions(+), 19 deletions(-) diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index 8ac469be..cd460b78 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -270,7 +270,7 @@ vectorSelectInput <- function(inputId, colorSelectInput <- function(inputId, label, choices, - selected = "", + selected = NULL, previews = 4, ..., placeholder = "") { @@ -306,31 +306,43 @@ colorSelectInput <- function(inputId, choices_new <- stats::setNames(vals, labels) + if (is.null(selected) || selected == "") { + selected <- vals[[1]] + } + shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., - options = list( + options = list( render = I( "{ - option: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '
' + escape(item.data.name) + '
' + - (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + - '
' + item.data.swatch + '
' + - '
'; - }, - item: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '' + escape(item.data.name) + '' + - item.data.swatch + - '
'; - } - }" + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" + ), + onInitialize = I( + "function() { + var self = this; + self.$control_input.prop('readonly', true); + self.$control_input.css('cursor', 'default'); + self.$control.css('cursor', 'pointer'); + }" ) ) ) diff --git a/man/colorSelectInput.Rd b/man/colorSelectInput.Rd index 37561b0f..0f673a0b 100644 --- a/man/colorSelectInput.Rd +++ b/man/colorSelectInput.Rd @@ -9,7 +9,7 @@ colorSelectInput( inputId, label, choices, - selected = "", + selected = NULL, previews = 4, ..., placeholder = "" From ba031094162a8eabdb95540fd276aafc7b6fe853 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:17:13 +0200 Subject: [PATCH 31/62] feat: new likert plot --- R/plot_likert.R | 50 +++++++++++++++++++++++++++++++++++++++++++++++ man/data-plots.Rd | 16 +++++++++++++-- 2 files changed, 64 insertions(+), 2 deletions(-) create mode 100644 R/plot_likert.R diff --git a/R/plot_likert.R b/R/plot_likert.R new file mode 100644 index 00000000..625bb844 --- /dev/null +++ b/R/plot_likert.R @@ -0,0 +1,50 @@ +#' Nice horizontal bar plot centred on the central category +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_likert(pri = "carb", sec = "cyl") +#' mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") +#' mtcars |> plot_likert(pri = "cyl",color.palette="Blues") +#' mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") +plot_likert <- function(data, + pri, + sec = NULL, + ter = NULL, + color.palette = "viridis") { + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + out <- lapply(ds, \(.x) { + .x[c(pri, sec)] |> + # na.omit() |> + plot_likert_single(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)+ + ggplot2::theme( + # legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = ggplot2::element_blank(), + # axis.title.y = ggplot2::element_blank(), + text = ggplot2::element_text(size = 12) + # axis.text = ggplot2::element_blank(), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + # plot.background = ggplot2::element_rect(fill = "white"), + # panel.border = ggplot2::element_blank() + ) +} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 5229751a..8f6534f4 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/data_plots.R, R/plot_bar.R, R/plot_box.R, -% R/plot_hbar.R, R/plot_ridge.R, R/plot_sankey.R, R/plot_scatter.R, -% R/plot_violin.R +% R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, R/plot_sankey.R, +% R/plot_scatter.R, R/plot_violin.R \name{data-plots} \alias{data-plots} \alias{data_visuals_ui} @@ -11,6 +11,7 @@ \alias{plot_box} \alias{plot_box_single} \alias{plot_hbars} +\alias{plot_likert} \alias{plot_ridge} \alias{sankey_ready} \alias{plot_sankey} @@ -48,6 +49,8 @@ plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis") + plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) sankey_ready(data, pri, sec, numbers = "count", ...) @@ -107,6 +110,8 @@ ggplot2 object ggplot2 object +ggplot2 object + data.frame ggplot2 object @@ -128,6 +133,8 @@ Create nice box-plots Nice horizontal stacked bars (Grotta bars) +Nice horizontal bar plot centred on the central category + Plot nice ridge plot Readying data for sankey plot @@ -164,6 +171,11 @@ 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_likert(pri = "carb", sec = "cyl") +mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") +mtcars |> plot_likert(pri = "cyl",color.palette="Blues") +mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") +mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") mtcars |> default_parsing() |> plot_ridge(x = "mpg", y = "cyl") From 163cbffeafa7223f7e3fb7cf7911f9bb6d24643d Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:18:10 +0200 Subject: [PATCH 32/62] chore: prepare baseline table for an even more compact version without empty levels in categorical --- R/baseline_table.R | 48 ++++++++++++++++++++++++------------------ man/create_baseline.Rd | 3 ++- 2 files changed, 30 insertions(+), 21 deletions(-) diff --git a/R/baseline_table.R b/R/baseline_table.R index 9d6f587f..39b51744 100644 --- a/R/baseline_table.R +++ b/R/baseline_table.R @@ -11,7 +11,10 @@ #' @examples #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) -baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) { +baseline_table <- function(data, + fun.args = NULL, + fun = gtsummary::tbl_summary, + vars = NULL) { out <- do.call(fun, c(list(data = data), fun.args)) return(out) } @@ -37,7 +40,15 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, #' mtcars |> create_baseline(by.var = "gear", detail_level = "extended",type = list(gtsummary::all_dichotomous() ~ "categorical"),theme="nejm") #' #' create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") -create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon"), detail_level = c("minimal", "extended")) { +create_baseline <- function(data, + ..., + by.var, + add.p = FALSE, + add.diff = FALSE, + add.overall = FALSE, + theme = c("jama", "lancet", "nejm", "qjecon"), + detail_level = c("minimal", "extended"), + drop_empty = FALSE) { theme <- match.arg(theme) detail_level <- match.arg(detail_level) @@ -64,31 +75,28 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=FALSE, ad if (!any(hasName(args, c("type", "statistic")))) { if (detail_level == "extended") { args <- - modifyList( - args, - list( - type = list(gtsummary::all_continuous() ~ "continuous2", - gtsummary::all_dichotomous() ~ "categorical"), - statistic = list(gtsummary::all_continuous() ~ c( - "{median} ({p25}, {p75})", - "{mean} ({sd})", - "{min}, {max}")) + modifyList(args, list( + type = list( + gtsummary::all_continuous() ~ "continuous2", + gtsummary::all_dichotomous() ~ "categorical" + ), + statistic = list( + gtsummary::all_continuous() ~ c("{median} ({p25}, {p75})", "{mean} ({sd})", "{min}, {max}") ) - ) + )) } } - parameters <- list( - data = data, - fun.args = purrr::list_flatten(list(by = by.var, args)) - ) + if (isTRUE(drop_empty)) { + ## Drops empty levels if minimal + data <- data |> REDCapCAST::fct_drop() + } + + parameters <- list(data = data, fun.args = purrr::list_flatten(list(by = by.var, args))) # browser() - out <- do.call( - baseline_table, - parameters - ) + out <- do.call(baseline_table, parameters) if (!is.null(by.var)) { diff --git a/man/create_baseline.Rd b/man/create_baseline.Rd index 23b3621f..bca41929 100644 --- a/man/create_baseline.Rd +++ b/man/create_baseline.Rd @@ -12,7 +12,8 @@ create_baseline( add.diff = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon"), - detail_level = c("minimal", "extended") + detail_level = c("minimal", "extended"), + drop_empty = FALSE ) } \arguments{ From 18eae4b3a317fa3272d45751f02c9492fbf9cd8d Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:18:28 +0200 Subject: [PATCH 33/62] feat: likert plot definitions --- R/data_plots.R | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index cd590cce..1ae13694 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -351,7 +351,7 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, @@ -377,7 +377,7 @@ data_visuals_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) } }, ignoreInit = TRUE) @@ -600,6 +600,18 @@ supported_plots <- function() { secondary.max = 4, tertiary.type = c("dichotomous"), secondary.extra = NULL + ), + plot_euler = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t( + "Plot survey results" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL ) ) } From 9122ce2663558bffdc8718c8382c58630309282b Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:19:11 +0200 Subject: [PATCH 34/62] fix: allow filtering data when character columns are present. --- R/helpers.R | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/R/helpers.R b/R/helpers.R index 514cf6a4..bd982c47 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -840,3 +840,54 @@ data_types <- function() { "Any other class") ) } + +non_character_cols <- function(df) { + if (shiny::is.reactive(df)) df <- df() + df[, !sapply(df, is.character), drop = FALSE] +} + +apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()) { + # If this ever brakes, the solution will have to be to modify the original filter function + if (shiny::is.reactive(df_target)) df_target <- df_target() + + result <- if (shiny::is.reactive(filtered_reactive)) filtered_reactive() else filtered_reactive + filter_code <- attr(result, "code") + + if (is.null(filter_code)) return(df_target) + + deparsed <- paste(deparse(filter_code), collapse = "") + + if (is.symbol(filter_code) || !grepl("filter(", deparsed, fixed = TRUE)) { + return(df_target) + } + + extract_filters <- function(code) { + filters <- list() + while (!is.symbol(code) && deparse(code[[1]]) == "%>%") { + rhs <- code[[3]] + if (deparse(rhs[[1]]) == "filter") { + filters <- c(list(rhs), filters) + } + code <- code[[2]] + } + if (!is.symbol(code) && deparse(code[[1]]) == "filter") { + filters <- c(list(code), filters) + } + filters + } + + tryCatch({ + out <- df_target + for (f in extract_filters(filter_code)) { + args <- lapply(rlang::call_args(f), function(arg) { + rlang::new_quosure(arg, env = env) + }) + out <- dplyr::filter(out, !!!args) + } + out + }, + error = function(e) { + warning("Could not apply filter: ", conditionMessage(e)) + df_target + }) +} From c28a3d0a6d1df26a167c2da7ab086db7e87ba330 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:19:52 +0200 Subject: [PATCH 35/62] feat: redcap server side export filter validation --- R/redcap_read_shiny_module.R | 411 +++++++++++++++++++++++++++++++++- man/validate_redcap_filter.Rd | 72 ++++++ 2 files changed, 471 insertions(+), 12 deletions(-) create mode 100644 man/validate_redcap_filter.Rd diff --git a/R/redcap_read_shiny_module.R b/R/redcap_read_shiny_module.R index 2b26d929..810cab0c 100644 --- a/R/redcap_read_shiny_module.R +++ b/R/redcap_read_shiny_module.R @@ -71,13 +71,17 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::textInput( inputId = ns("filter"), label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") - ) + ), + uiOutput(ns("filter_feedback")) ) params_ui <- shiny::tagList( shiny::tags$h4(i18n$t("Data import parameters")), shiny::tags$div( + #### + #### All below was deactivated to deactivate filtering + #### style = htmltools::css( display = "grid", gridTemplateColumns = "1fr 50px", @@ -164,7 +168,8 @@ m_redcap_readServer <- function(id) { dd_list = NULL, data = NULL, rep_fields = NULL, - code = NULL + code = NULL, + filter_valid = NULL ) shiny::observeEvent(list(input$api, input$uri), { @@ -249,7 +254,7 @@ m_redcap_readServer <- function(id) { }, warning = function(warn) { showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) @@ -363,19 +368,57 @@ m_redcap_readServer <- function(id) { } }) + + filter_validation <- reactive({ + val <- trimws(input$filter) + if (nchar(val) == 0) + return(NULL) + validate_redcap_filter(val, purrr::pluck(data_rv$dd_list, "data")) + }) + + output$filter_feedback <- renderUI({ + result <- filter_validation() + if (is.null(result)) { + data_rv$filter_valid <- NULL + return(NULL) + } + + if (result$valid) { + data_rv$filter_valid <- TRUE + tags$span(style = "color: green;", "\u2713 Filter is valid") + } else { + data_rv$filter_valid <- FALSE + + tags$span(style = "color: red;", + "\u2717 ", + line_break(result$message, lineLength = 30)) + } + }) + shiny::observeEvent(input$data_import, { shiny::req(input$fields) # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] + if (!is.null(data_rv$filter_valid)) { + if (isTRUE(data_rv$filter_valid)) { + filter <- trimws(input$filter) + } else { + filter <- "" + } + } else { + filter <- "" + } + parameters <- list( uri = data_rv$uri, token = input$api, fields = unique(c(record_id, input$fields)), events = input$arms, raw_or_label = "both", - filter_logic = input$filter, + filter_logic = filter, + # filter_logic = "", split_forms = ifelse( input$data_type == "long" && !is.null(input$data_type), "none", @@ -384,8 +427,17 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- tryCatch(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), - silent = TRUE) + imported <- try({ + rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters) + # if (nrow(out)==0){ + # stop("No data was exported") + # } else { + # out + # } + }, # error = function(err) { + # showNotification(i18n$t("An error was encountered exporting data. Please review data filter."), type = "error") + # }, + silent = TRUE) }) # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) @@ -410,10 +462,13 @@ m_redcap_readServer <- function(id) { ), .ns = "REDCapCAST") - if (inherits(imported, "try-error") || NROW(imported) < 1) { + if (inherits(imported, "try-error") | + NROW(imported) == 0 | + (length(imported) == 1 & !is.list(imported))) { data_rv$data_status <- "error" data_rv$data_list <- NULL - data_rv$data_message <- imported$raw_text + data_rv$data_message <- i18n$t("An empty data set was imported. Please review data filter.") + data_rv$data <- NULL } else { data_rv$data_status <- "success" data_rv$data_message <- i18n$t("Requested data was retrieved!") @@ -426,7 +481,7 @@ m_redcap_readServer <- function(id) { # redcap_wider() REDCapCAST::redcap_wider() } else { - if (input$fill == "yes") { + if (identical(input$fill, "yes")) { ## Repeated fields @@ -480,10 +535,21 @@ m_redcap_readServer <- function(id) { }) shiny::observeEvent(data_rv$data_status, { - # browser() if (identical(data_rv$data_status, "error")) { - datamods:::insert_error(mssg = data_rv$data_message, - selector = ns("retrieved")) + ## The insert error wouldn't work. Inserted through regular. + # datamods:::insert_error(mssg = data_rv$data_message, + # selector = ns("retrieved")) + datamods:::insert_alert( + selector = ns("retrieved"), + status = "danger", + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message + ) + ) } else if (identical(data_rv$data_status, "success")) { datamods:::insert_alert( selector = ns("retrieved"), @@ -665,6 +731,327 @@ drop_empty_event <- function(data, event = "redcap_event_name") { } +#' Validate a REDCap server-side filter string against a data dictionary +#' +#' Checks that a REDCap filter expression is syntactically correct and +#' consistent with the field types defined in the project data dictionary. +#' Plain text without field references is always rejected. Multi-clause +#' filters joined by \code{AND} or \code{OR} are supported. +#' +#' @param filter A single character string containing the filter expression, +#' e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}. +#' @param dictionary A data frame representing the REDCap data dictionary in +#' API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. +#' Must contain at least the columns \code{field_name} and \code{field_type}. +#' The columns \code{text_validation_type_or_show_slider_number} and +#' \code{select_choices_or_calculations} are used when present for stricter +#' type and choice validation. +#' +#' @return A named list with two elements: +#' \describe{ +#' \item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} +#' \item{\code{message}}{Character. \code{"Filter is valid."} on success, or +#' a newline-separated string of error messages describing every problem +#' found.} +#' } +#' +#' @details +#' Validation rules by field type: +#' \describe{ +#' \item{\code{calc}}{Numeric fields. Value must be an unquoted number. +#' All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, +#' \code{<=}, \code{>=}) are accepted.} +#' \item{\code{text} with date validation}{Fields with validation type +#' \code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be +#' a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All +#' comparison operators are accepted.} +#' \item{\code{text} with time validation}{Fields with validation type +#' \code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time +#' string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} +#' \item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a +#' quoted choice code (e.g. \code{'1'}) that exists in the field's choice +#' list. Only \code{=} and \code{!=} are accepted.} +#' \item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. +#' Only \code{=} and \code{!=} are accepted.} +#' } +#' +#' @examples +#' \dontrun{ +#' dict <- REDCapCAST::get_redcap_metadata( +#' uri = "https://redcap.example.com/api/", +#' token = Sys.getenv("REDCAP_TOKEN") +#' ) +#' +#' validate_redcap_filter("[age] > 18", dict) +#' #> list(valid = TRUE, message = "Filter is valid.") +#' +#' validate_redcap_filter("only plain text", dict) +#' #> list(valid = FALSE, message = "Filter must contain at least one field ...") +#' +#' validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) +#' #> list(valid = TRUE, message = "Filter is valid.") +#' } +#' +#' @export +# REDCap filter validation based on data dictionary +# +# REDCap filter format: [field_name] operator value +# Example: [age] > 18 +# [cohabitation] = '1' +# [inclusion] > '2020-01-01' +# +# Supported field types and their allowed operators/value formats: +# text (no validation) -> string values, = != operators only +# text (date_ymd/date_dmy) -> quoted date strings, all comparison operators +# text (time_hh_mm_ss) -> quoted time strings, all comparison operators +# text (datetime_*) -> quoted datetime strings, all comparison operators +# text (autocomplete) -> string values, = != operators only +# calc -> numeric values, all comparison operators +# radio/dropdown -> quoted numeric codes, = != operators only + +validate_redcap_filter <- function(filter, dictionary) { + # --- Input checks --- + if (!is.character(filter) || + length(filter) != 1 || nchar(trimws(filter)) == 0) { + return(list(valid = FALSE, message = "Filter must be a non-empty string.")) + } + + if (!grepl("\\[.+\\]", filter)) { + return( + list(valid = FALSE, message = "Filter must contain at least one field reference in [brackets]. Plain text is not accepted.") + ) + } + + # --- Column names (API export format) --- + col_field <- "field_name" + col_type <- "field_type" + col_val_type <- "text_validation_type_or_show_slider_number" + col_choices <- "select_choices_or_calculations" + + missing_cols <- setdiff(c(col_field, col_type), names(dictionary)) + if (length(missing_cols) > 0) { + stop("Dictionary is missing required columns: ", + paste(missing_cols, collapse = ", ")) + } + + # --- Build lookup index once for O(1) field access --- + field_idx <- setNames(seq_len(nrow(dictionary)), dictionary[[col_field]]) + has_val_type <- col_val_type %in% names(dictionary) + has_choices <- col_choices %in% names(dictionary) + + # --- Classify field types --- + numeric_types <- c("calc") + date_validations <- c( + "date_ymd", + "date_dmy", + "datetime_ymd", + "datetime_dmy", + "datetime_seconds_ymd", + "datetime_seconds_dmy" + ) + time_validations <- c("time_hh_mm_ss", "time_mm_ss") + categorical_types <- c("radio", "dropdown", "checkbox") + text_types <- c("text", "autocomplete") + + num_ops <- c("=", "!=", "<", ">", "<=", ">=") + cat_ops <- c("=", "!=") + text_ops <- c("=", "!=") + + # --- Parse filter into clauses --- + # Split on AND/OR (REDCap uses 'and'/'or' or 'AND'/'OR') + clauses <- trimws(strsplit(filter, "(?i)\\s+(and|or)\\s+", perl = TRUE)[[1]]) + + clause_pattern <- "^\\[([^\\]]+)\\]\\s*(=|!=|<=|>=|<|>)\\s*(.+)$" + + errors <- character(0) + + for (clause in clauses) { + if (!grepl(clause_pattern, clause, perl = TRUE)) { + errors <- c( + errors, + sprintf( + "Clause '%s' does not match expected format: [field] operator value", + clause + ) + ) + next + } + + parts <- regmatches(clause, regexec(clause_pattern, clause, perl = TRUE))[[1]] + field <- parts[2] + operator <- parts[3] + value <- trimws(parts[4]) + + # --- Check field exists using pre-built index --- + row_i <- field_idx[field] + if (is.na(row_i)) { + errors <- c(errors, sprintf("Unknown field: [%s]", field)) + next + } + + field_type <- dictionary[[col_type]][row_i] + val_type <- if (has_val_type) + dictionary[[col_val_type]][row_i] + else + "" + if (is.na(val_type)) + val_type <- "" + + # --- Determine expected value format and allowed operators --- + if (field_type %in% numeric_types || + grepl("^integer$|^number", val_type)) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is numeric — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl("^-?[0-9]+(\\.[0-9]+)?$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is numeric — value '%s' should be an unquoted number (e.g. 18 or 3.5)", + field, + value + ) + ) + } + + } else if (val_type %in% date_validations) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a date — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl( + "^'[0-9]{4}-[0-9]{2}-[0-9]{2}(\\s[0-9]{2}:[0-9]{2}(:[0-9]{2})?)?'$", + value + )) { + errors <- c( + errors, + sprintf( + "[%s] is a date — value '%s' should be a quoted date string, e.g. '2020-01-31'", + field, + value + ) + ) + } + + } else if (val_type %in% time_validations) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a time — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl("^'[0-9]{2}:[0-9]{2}(:[0-9]{2})?'$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is a time — value '%s' should be a quoted time string, e.g. '14:30:00'", + field, + value + ) + ) + } + + } else if (field_type %in% categorical_types) { + if (!operator %in% cat_ops) { + errors <- c( + errors, + sprintf( + "[%s] is categorical — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(cat_ops, collapse = ", ") + ) + ) + } + + # Validate value is a known choice code + choices_raw <- if (has_choices) + dictionary[[col_choices]][row_i] + else + NA + if (!is.na(choices_raw) && nchar(trimws(choices_raw)) > 0) { + choice_codes <- trimws(gsub(",.+?(\\||$)", "", gsub( + "^\\s*", "", strsplit(choices_raw, "\\|")[[1]] + ))) + value_unquoted <- gsub("^'|'$", "", value) + if (!value_unquoted %in% choice_codes) { + errors <- c( + errors, + sprintf( + "[%s] is categorical — '%s' is not a valid choice code. Valid codes: %s", + field, + value_unquoted, + paste(choice_codes, collapse = ", ") + ) + ) + } + } + + if (!grepl("^'.*'$", value)) { + errors <- c(errors, + sprintf( + "[%s] is categorical — value should be quoted, e.g. '1'", + field + )) + } + + } else { + # Plain text field + if (!operator %in% text_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a text field — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(text_ops, collapse = ", ") + ) + ) + } + if (!grepl("^'.*'$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is a text field — value should be quoted, e.g. 'some text'", + field + ) + ) + } + } + } + + if (length(errors) > 0) { + return(list( + valid = FALSE, + message = paste(errors, collapse = "\n") + )) + } + + list(valid = TRUE, message = "Filter is valid.") +} + + + #' Test app for the redcap_read_shiny_module #' #' @rdname redcap_read_shiny_module diff --git a/man/validate_redcap_filter.Rd b/man/validate_redcap_filter.Rd new file mode 100644 index 00000000..9fb42c5d --- /dev/null +++ b/man/validate_redcap_filter.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/redcap_read_shiny_module.R +\name{validate_redcap_filter} +\alias{validate_redcap_filter} +\title{Validate a REDCap server-side filter string against a data dictionary} +\usage{ +validate_redcap_filter(filter, dictionary) +} +\arguments{ +\item{filter}{A single character string containing the filter expression, +e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}.} + +\item{dictionary}{A data frame representing the REDCap data dictionary in +API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. +Must contain at least the columns \code{field_name} and \code{field_type}. +The columns \code{text_validation_type_or_show_slider_number} and +\code{select_choices_or_calculations} are used when present for stricter +type and choice validation.} +} +\value{ +A named list with two elements: +\describe{ +\item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} +\item{\code{message}}{Character. \code{"Filter is valid."} on success, or +a newline-separated string of error messages describing every problem +found.} +} +} +\description{ +Checks that a REDCap filter expression is syntactically correct and +consistent with the field types defined in the project data dictionary. +Plain text without field references is always rejected. Multi-clause +filters joined by \code{AND} or \code{OR} are supported. +} +\details{ +Validation rules by field type: +\describe{ +\item{\code{calc}}{Numeric fields. Value must be an unquoted number. +All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, +\code{<=}, \code{>=}) are accepted.} +\item{\code{text} with date validation}{Fields with validation type +\code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be +a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All +comparison operators are accepted.} +\item{\code{text} with time validation}{Fields with validation type +\code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time +string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} +\item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a +quoted choice code (e.g. \code{'1'}) that exists in the field's choice +list. Only \code{=} and \code{!=} are accepted.} +\item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. +Only \code{=} and \code{!=} are accepted.} +} +} +\examples{ +\dontrun{ +dict <- REDCapCAST::get_redcap_metadata( + uri = "https://redcap.example.com/api/", + token = Sys.getenv("REDCAP_TOKEN") +) + +validate_redcap_filter("[age] > 18", dict) +#> list(valid = TRUE, message = "Filter is valid.") + +validate_redcap_filter("only plain text", dict) +#> list(valid = FALSE, message = "Filter must contain at least one field ...") + +validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) +#> list(valid = TRUE, message = "Filter is valid.") +} + +} From fcf422bc4b9544f8d8ed7ac6e5e445a83e9ff3d8 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:20:05 +0200 Subject: [PATCH 36/62] render --- CITATION.cff | 2 +- DESCRIPTION | 3 ++- NAMESPACE | 2 ++ NEWS.md | 14 +++++++++++++- R/app_version.R | 2 +- R/cut-variable-ext.R | 2 +- R/hosted_version.R | 2 +- R/import-file-ext.R | 8 ++++---- R/missings-module.R | 2 +- R/regression-module.R | 10 +++++----- R/sysdata.rda | Bin 2685 -> 2704 bytes R/update-factor-ext.R | 2 +- SESSION.md | 11 ++++++----- inst/translations/translation_da.csv | 14 ++++++-------- inst/translations/translation_sw.csv | 14 ++++++-------- renv.lock | 26 ++++++++++++++------------ 16 files changed, 64 insertions(+), 50 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index f7e2ec6a..5578f1a5 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.4 +version: 26.3.5 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index def9fc81..3a60d461 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.3.4 +Version: 26.3.5 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), @@ -122,6 +122,7 @@ Collate: 'plot_box.R' 'plot_euler.R' 'plot_hbar.R' + 'plot_likert.R' 'plot_ridge.R' 'plot_sankey.R' 'plot_scatter.R' diff --git a/NAMESPACE b/NAMESPACE index 97775d14..9ede131b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -122,6 +122,7 @@ export(plot_box_single) export(plot_euler) export(plot_euler_single) export(plot_hbars) +export(plot_likert) export(plot_ridge) export(plot_sankey) export(plot_sankey_single) @@ -166,6 +167,7 @@ export(update_factor_server) export(update_factor_ui) export(update_variables_server) export(update_variables_ui) +export(validate_redcap_filter) export(validation_server) export(validation_ui) export(vectorSelectInput) diff --git a/NEWS.md b/NEWS.md index 3476df1d..7c2bbc32 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,10 +1,22 @@ +# FreesearchR 26.3.5 + +*FIX* Labelled categorical variables were not handled correctly importing from REDCap resulting in lost labels. Fixed! + +*CHANGE* Testing in new data I realised, that automatically removing empty levels in categorical variables/factors is not desired. It should be a concious decision to remove levels. This is now possible in the "Modify factor" pop-up. + +*CHANGE* REDCap export now throws an error if no data was exported. The server side filtering prior to export is now validated and feedback is printed. Only valid filter statements are used when exporting data from the REDCap server. This is an advanced use case, but a great way to ensure only the minimum required data is exported from the server. + +*FIX* Applying filters now works also when the data contains text variables. + +*NEW* Initial support for plotting Likert scale survey results. This is expected to be further improved. For based on ggstats::gglikert. + # FreesearchR 26.3.4 *NEW* Color select for plotting across all plots for even more option. Ten palettes have been chosen, to provide varied and interpretable options. The selector will always show a preview of four colors. *NEW* Added app version check against latest release on GitHub. Only runs if internet connection present. No other polling. -*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size. And fixed support for dichotomous data. +*NEW* Added a "Missing" level to the Sankey plot function and adjusted the label font size. And fixed support for dichotomous data. # FreesearchR 26.3.3 diff --git a/R/app_version.R b/R/app_version.R index c6d7307c..bdf15ee5 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.4' +app_version <- function()'26.3.5' diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index 508e846c..b7d8eb80 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -378,7 +378,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { rlang::exec(cut_var, !!!parameters) }, error = function(err) { - showNotification(paste("We encountered the following error creating the new factor:", err), type = "err") + showNotification(paste("We encountered the following error creating the new factor:", err), type = "error") } ) diff --git a/R/hosted_version.R b/R/hosted_version.R index 6935edfb..19c31921 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.4-260324' +hosted_version <- function()'v26.3.5-260330' diff --git a/R/import-file-ext.R b/R/import-file-ext.R index 745bbc0f..709a55c1 100644 --- a/R/import-file-ext.R +++ b/R/import-file-ext.R @@ -353,7 +353,7 @@ import_file_server <- function(id, # showNotification(warn, type = "warning") # }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") }) }) @@ -370,7 +370,7 @@ import_file_server <- function(id, minBodyHeight = 250 ) }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") }) }) @@ -485,7 +485,7 @@ import_xls <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) } @@ -513,7 +513,7 @@ import_ods <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + ?showNotification(paste0(err), type = "error") }) } diff --git a/R/missings-module.R b/R/missings-module.R index 8b9c1f50..003a35f4 100644 --- a/R/missings-module.R +++ b/R/missings-module.R @@ -172,7 +172,7 @@ data_missings_server <- function(id, data, max_level = 20, ...) { out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl))) }) }, error = function(err) { - showNotification(paste0("Error: ", err), type = "err") + showNotification(paste0("Error: ", err), type = "error") }) if (is.null(input$missings_var) || diff --git a/R/regression-module.R b/R/regression-module.R index e1bd364f..d569bd54 100644 --- a/R/regression-module.R +++ b/R/regression-module.R @@ -416,7 +416,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "error") } ) } @@ -481,7 +481,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "error") } ) } @@ -559,7 +559,7 @@ regression_server <- function(id, gg_theme_shiny() }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") } ) }) @@ -619,7 +619,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "error") } ) } @@ -690,7 +690,7 @@ regression_server <- function(id, out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") } ) diff --git a/R/sysdata.rda b/R/sysdata.rda index 4e2466e66542431c55aacefa9da334dcbe7447a6..e57187506ab34278de0c95073a5e1f6f763aa4ac 100644 GIT binary patch literal 2704 zcmV;B3UBp7T4*^jL0KkKSqf-34*(gYGvM^$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 literal 2685 zcmV-@3WD`QT4*^jL0KkKS(8lDJOCN2f5iX)Xaz!l|KNXb-@w2B|L{Nn00;;H;0ym3 zI~Fa+f#4*l&?Er)=g}onyI@rphNeK783REyGzm7Ej6~W`L@_h~XvhqhAk{nwO#+!T z%~MZknrW$~gFt8i00000YM+UrNl*YZ4FRA40000002&E2k`htrsPuy%)M7Jg001KZ zOln{N0BKD@p`ZZJ02%-Q0002fKma09CWt*uP(33}292lyGyu>BY6C&F0h08qgqX@2 zNMSCZ7Fk3UErKd+YS9s1AHAhO5v@pQ`2M+Z%jjSX92>km1`#(Rml9b(DGfs0Q?+hB z#h2A^MMOqKbMNnQ?%)4tXYO0=_5An`WG)tV`78~6Ul=Jg)II)}RsH#GjN;lSnpN*P z6o?T~7Y!guORqz*oNlXTofK9nTI^akazS+qr+rc=88>a%vSQlGpxUp4dD(fwvnuS4 zP-1m=WOFxiXETwgAqPcJi7DmHb~5KM#qZtwg)M^@K$m_elI3M~T9wGf#I`LW_TU)S z1i7v$gBr0_R8+6`-Lm^KdGB&`qgfiv)4J>Jk~C^JJLKuopkCsoMx_%gW_=~@bAd}` z3B%@OHS3#F=ETEG7p8U|MPqQ%A3ucr35EvUg13RnCOX@r(w&J zE-4RLi>{cB*3{cmr4hT)^OBj&uoD#l{?vbd#gKA;Abh0pt*b3y1_zRAk8TUcA5t)KNsrAc({e0tAGH)dWyl)`%h@ z`+}h8#SjZNWetzOh&cCi7`1=^)`B66X6xOZ%$M~&d{_z&frk=O3=tJXMHLvZSfHpP zED%_vQC2Y#R6$lKqYy68$&0Ikmfr|m;sd5S z*4dy1(WDmF5VACmDDWuYm@!B}8c`sfId)|hctkzc=>Z5N0aPl~+?ZBh6jdR!cdA*- zF>+WolnaMc=;3#a%DY_in1(KIn#`;>m9B;o*x8tJ14TNzqRy40N_U}DbMVqB4TlMR zH;#(lByGFQfO2f6zRi)4X2^k0$%%yd%ZfbA2OLu7&#ntXWD}rq@ zOC;eE)e_R~M{qiwZoBRJnbq6>U7g{6sGZ3OXCN$u7(gULBmvcmA)ysZ$&wX?VscdfOU$$tt|*;30cGp7**FMXef@uF?=3LCIlRMpQ(t7=wdQ z8es@Bc6)^S`^s3CLD)`5Vcjx~r;T7@*k=)Eio#9{PO@`8r+;LE~Pa+9^#-c9ys zS+>^{WQs#A5*24hD>}@FM1%;;=d-!Z@L}CEteQz)etnB!Qnr;)o}jt*uHevWT{dMI_gd!)Lxe&XNQHCOW3Fo0CjcybvG@ zm|tZ8q}QFUABA~>R@En;Q7DpN^W#uraweqBvH*bqPEIpD8LCYPUx4foAPGcb0t5jm z!dfdSc&&`F>(AOLoL!-gp5MWME|`;tj`)?dZ$*Jrf@|3aDviqvtlAYLTr8{9YEbV5g z#E|zs!6cznBNMGpLC*;BT#$u9uyHFk)gF00tbMQ&p{XNTKCZULkiM=$6B23#SC#f$ zR$UgRK!rD<8PQClf5*tTR$_hg<&6S*N+&U=O3^kWSKQU#QZ>xAoc>ctE%pdB*DKll zHHVJ9CMPOu%jwQ_>{nxmY9p-dW$*mTTyTPisaML>0|+Q`qh4b{u>vK^r-p2~O?ex- zRnRwq49J|-!5m2j32#a%K%{qwOpV0E_9iuV7t!`Mnw>Rf)$YAZ%LOGQm=Bt%=j7ZNQ_cgHE^flR_41zZ@gLPSyzPNXY1a+(u&cZ^ODaQ#1FH_5NUR*pkkSCANPSC6;Kb}z zEM0+ZWo%xZGPZ=96C`b^7oKsml~1Nc3s-e0ZZnw>bu4ZPnU$}xNWMy=ySjerBrQP$ zHRH8IfRuT!>c>}k@gY*vUR1*|qbuRBkDbci>*tYZC{-4v=)x4)ZecyLTuGgC6vm5c rrdJgdl5Q>0WQxTFb16`^OuFW9-hqb83k0z0AMtl2Q-ui$G|e->Aa~z$ diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index 93f35910..7f3380cd 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -245,7 +245,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { "We encountered the following error creating the new factor:", err ), - type = "err") + type = "error") }) # browser() diff --git a/SESSION.md b/SESSION.md index 0f0edad0..f232def3 100644 --- a/SESSION.md +++ b/SESSION.md @@ -11,11 +11,11 @@ |collate |en_US.UTF-8 | |ctype |en_US.UTF-8 | |tz |Europe/Copenhagen | -|date |2026-03-24 | +|date |2026-03-30 | |rstudio |2026.01.1+403 Apple Blossom (desktop) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |quarto |1.7.30 @ /usr/local/bin/quarto | -|FreesearchR |26.3.4.260324 | +|FreesearchR |26.3.5.260330 | -------------------------------------------------------------------------------- @@ -53,6 +53,7 @@ |colorspace |2.1-2 |2025-09-22 |CRAN (R 4.5.0) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.5.0) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.5.0) | +|curl |7.0.0 |2025-08-19 |CRAN (R 4.5.0) | |data.table |1.18.2.1 |2026-01-27 |CRAN (R 4.5.2) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.5.0) | |datawizard |1.3.0 |2025-10-11 |CRAN (R 4.5.0) | @@ -83,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.4 |NA |NA | +|FreesearchR |26.3.5 |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) | @@ -106,6 +107,7 @@ |htmltools |0.5.9 |2025-12-04 |CRAN (R 4.5.2) | |htmlwidgets |1.6.4 |2023-12-06 |CRAN (R 4.5.0) | |httpuv |1.6.16 |2025-04-16 |CRAN (R 4.5.0) | +|httr |1.4.8 |2026-02-13 |CRAN (R 4.5.2) | |IDEAFilter |0.2.1 |2025-07-29 |CRAN (R 4.5.0) | |insight |1.4.6 |2026-02-04 |CRAN (R 4.5.2) | |iterators |1.0.14 |2022-02-05 |CRAN (R 4.5.0) | @@ -115,6 +117,7 @@ |keyring |1.4.1 |2025-06-15 |CRAN (R 4.5.0) | |knitr |1.51 |2025-12-20 |CRAN (R 4.5.2) | |labeling |0.4.3 |2023-08-29 |CRAN (R 4.5.0) | +|labelled |2.16.0 |2025-10-22 |CRAN (R 4.5.0) | |later |1.4.8 |2026-03-05 |CRAN (R 4.5.2) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.5.2) | |lifecycle |1.0.5 |2026-01-08 |CRAN (R 4.5.2) | @@ -124,7 +127,6 @@ |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | |Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.0) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | -|mgcv |1.9-4 |2025-11-07 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | |mvtnorm |1.3-2 |2024-11-04 |CRAN (R 4.5.2) | @@ -148,7 +150,6 @@ |pkgload |1.5.0 |2026-02-03 |CRAN (R 4.5.2) | |plyr |1.8.9 |2023-10-02 |CRAN (R 4.5.0) | |polyclip |1.10-7 |2024-07-23 |CRAN (R 4.5.0) | -|polylabelr |1.0.0 |2026-01-19 |CRAN (R 4.5.2) | |pracma |2.4.6 |2025-10-22 |CRAN (R 4.5.0) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.5.0) | |promises |1.5.0 |2025-11-01 |CRAN (R 4.5.0) | diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index ce9abc8e..4f3752bd 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -55,7 +55,6 @@ "Imported data","Importeret data" "www/intro.md","www/intro.md" "Choose your data","Vælg dine data" -"Factor variable to reorder:","Kategoriske variabel der skal ændres:" "Sort by levels","Sorter efter niveauer" "Sort by count","Sorter efter antal" "Update factor variable","Updater faktor-variabel" @@ -148,16 +147,12 @@ "Import data from REDCap","Importér data fra REDCap" "REDCap server","REDCap-server" "Web address","Serveradresse" -"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Adressen skal være som 'https://redcap.your.institution/' eller 'https://your.institution/redcap/'" "API token","API-nøgle" -"The token is a string of 32 numbers and letters.","En API-nøgle består af ialt 32 tal og bogstaver." "Connect","Forbind" "Data import parameters","Data import parameters" -"Select fields/variables to import and click the funnel to apply optional filters","Vælg variabler, der skal importeres og tryk på tragten for at anvende valgfrie filtre" "Import","Import" "Click to see data dictionary","Tryk for at se metadata (Data Dictionary)" "Connected to server!","Forbindelse til serveren oprettet!" -"The {data_rv$info$project_title} project is loaded.","{data_rv$info$project_title}-projektet er forbundet." "Data dictionary","Data dictionary" "Preview:","Forsmag:" "Imported data set","Importeret datasæt" @@ -165,8 +160,6 @@ "Specify the data format","Specificér dataformatet" "Fill missing values?","Skal manglende observationer udfyldes?" "Requested data was retrieved!","Det udvalgte data blev hentet!" -"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde ID-variablen. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." -"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde nogle af de udvalgte variabler. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." "Click to see the imported data","Tryk for at se de importerede data" "Regression table","Regressionstabel" "Import a dataset from an environment","Importer et datasæt fra et kodemiljø" @@ -291,7 +284,6 @@ "No data present.","Ingen data tilstede." "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." -"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -323,3 +315,9 @@ "Settings","Settings" "Create new factor","Create new factor" "Choose color palette","Choose color palette" +"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" +"Drop empty","Drop empty" +"Choose variable:","Choose variable:" +"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." +"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." +"Likert diagram","Likert diagram" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 96a7a109..a375e0a5 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -55,7 +55,6 @@ "Imported data","Data iliyoingizwa" "www/intro.md","www/intro.md" "Choose your data","Chagua data yako" -"Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:" "Sort by levels","Panga kwa viwango" "Sort by count","Panga kwa hesabu" "Update factor variable","Sasisha kigezo cha kipengele" @@ -148,16 +147,12 @@ "Import data from REDCap","Ingiza data kutoka REDCap" "REDCap server","Seva ya REDCap" "Web address","Anwani ya wavuti" -"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Muundo unapaswa kuwa 'https://redcap.your.institution/' au 'https://your.institution/redcap/'" "API token","Tokeni ya API" -"The token is a string of 32 numbers and letters.","Tokeni ni mfuatano wa nambari na herufi 32." "Connect","Unganisha" "Data import parameters","Vigezo vya kuingiza data" -"Select fields/variables to import and click the funnel to apply optional filters","Chagua sehemu/vigezo vya kuingiza na ubofye faneli ili kutumia vichujio vya hiari" "Import","Ingiza" "Click to see data dictionary","Bofya ili kuona kamusi ya data" "Connected to server!","Imeunganishwa na seva!" -"The {data_rv$info$project_title} project is loaded.","Mradi wa {data_rv$info$project_title} umepakiwa." "Data dictionary","Kamusi ya data" "Preview:","Hakikisho:" "Imported data set","Seti ya data iliyoingizwa" @@ -165,8 +160,6 @@ "Specify the data format","Bainisha umbizo la data" "Fill missing values?","Jaza thamani zinazokosekana?" "Requested data was retrieved!","Data iliyoombwa ilipatikana!" -"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana ni kitambulisho pekee kilichorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." -"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana kama si sehemu zote zilizoombwa zilizorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." "Click to see the imported data","Bofya ili kuona data iliyoingizwa" "Regression table","Jedwali la urejeshaji" "Import a dataset from an environment","Ingiza seti ya data kutoka kwa mazingira" @@ -291,7 +284,6 @@ "No data present.","No data present." "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." -"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -323,3 +315,9 @@ "Settings","Settings" "Create new factor","Create new factor" "Choose color palette","Choose color palette" +"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" +"Drop empty","Drop empty" +"Choose variable:","Choose variable:" +"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." +"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." +"Likert diagram","Likert diagram" diff --git a/renv.lock b/renv.lock index 567601cc..96709a25 100644 --- a/renv.lock +++ b/renv.lock @@ -35,12 +35,12 @@ }, "DHARMa": { "Package": "DHARMa", - "Version": "0.4.6", + "Version": "0.4.7", "Source": "Repository", "Title": "Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models", - "Date": "2022-09-08", - "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"))", - "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB' 'GLMMadaptive' and 'spaMM', generalized additive models ('gam' from 'mgcv'), 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial and temporal autocorrelation.", + "Date": "2024-10-16", + "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"), person(\"Melina\", \"de Souza leite\", role = \"ctb\"))", + "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB', 'GLMMadaptive', and 'spaMM'; phylogenetic linear models from 'phylolm' (classes 'phylolm' and 'phyloglm'); generalized additive models ('gam' from 'mgcv'); 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial, phylogenetic and temporal autocorrelation.", "Depends": [ "R (>= 3.0.2)" ], @@ -59,7 +59,7 @@ ], "Suggests": [ "knitr", - "testthat", + "testthat (>= 3.0.0)", "rmarkdown", "KernSmooth", "sfsmisc", @@ -68,7 +68,8 @@ "mgcViz (>= 0.1.9)", "spaMM (>= 3.2.0)", "GLMMadaptive", - "glmmTMB (>= 1.1.2.3)" + "glmmTMB (>= 1.1.2.3)", + "phylolm (>= 2.6.5)" ], "Enhances": [ "phyr", @@ -80,11 +81,12 @@ "URL": "http://florianhartig.github.io/DHARMa/", "LazyData": "TRUE", "BugReports": "https://github.com/florianhartig/DHARMa/issues", - "RoxygenNote": "7.2.1", + "RoxygenNote": "7.3.2", "VignetteBuilder": "knitr", "Encoding": "UTF-8", + "Config/testthat/edition": "3", "NeedsCompilation": "no", - "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb]", + "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb], Melina de Souza leite [ctb]", "Maintainer": "Florian Hartig ", "Repository": "CRAN" }, @@ -2345,7 +2347,7 @@ }, "datamods": { "Package": "datamods", - "Version": "1.5.2", + "Version": "1.5.3", "Source": "Repository", "Title": "Modules to Import and Manipulate Data in 'Shiny'", "Authors@R": "c(person(given = \"Victor\", family = \"Perrier\", role = c(\"aut\", \"cre\", \"cph\"), email = \"victor.perrier@dreamrs.fr\"), person(given = \"Fanny\", family = \"Meyer\", role = \"aut\"), person(given = \"Samra\", family = \"Goumri\", role = \"aut\"), person(given = \"Zauad Shahreer\", family = \"Abeer\", role = \"aut\", email = \"shahreyar.abeer@gmail.com\"), person(given = \"Eduard\", family = \"Szöcs\", role = \"ctb\", email = \"eduardszoecs@gmail.com\") )", @@ -8357,7 +8359,7 @@ }, "shinybusy": { "Package": "shinybusy", - "Version": "0.3.2", + "Version": "0.3.3", "Source": "Repository", "Title": "Busy Indicators and Notifications for 'Shiny' Applications", "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))", @@ -8370,8 +8372,8 @@ "jsonlite", "htmlwidgets" ], - "RoxygenNote": "7.2.3", - "URL": "https://github.com/dreamRs/shinybusy", + "RoxygenNote": "7.3.1", + "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/", "BugReports": "https://github.com/dreamRs/shinybusy/issues", "Suggests": [ "testthat", From 75f2ae07b713fb1b12c1caf0b7423c6d6e7f57bf Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 30 Mar 2026 20:26:09 +0200 Subject: [PATCH 37/62] new version --- app_docker/app.R | 1163 +++++++++++++++----- app_docker/renv.lock | 26 +- app_docker/translations/translation_da.csv | 14 +- app_docker/translations/translation_sw.csv | 14 +- inst/apps/FreesearchR/app.R | 1163 +++++++++++++++----- 5 files changed, 1772 insertions(+), 608 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index c18c6f99..31c047b8 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmpn21sEQ/filec83e64988776.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//Rtmp1OaGW3/file656737f80bdf.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.4' +app_version <- function()'26.3.5' ######## @@ -84,7 +84,10 @@ app_version <- function()'26.3.4' #' @examples #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) -baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) { +baseline_table <- function(data, + fun.args = NULL, + fun = gtsummary::tbl_summary, + vars = NULL) { out <- do.call(fun, c(list(data = data), fun.args)) return(out) } @@ -110,7 +113,15 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, #' mtcars |> create_baseline(by.var = "gear", detail_level = "extended",type = list(gtsummary::all_dichotomous() ~ "categorical"),theme="nejm") #' #' create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") -create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon"), detail_level = c("minimal", "extended")) { +create_baseline <- function(data, + ..., + by.var, + add.p = FALSE, + add.diff = FALSE, + add.overall = FALSE, + theme = c("jama", "lancet", "nejm", "qjecon"), + detail_level = c("minimal", "extended"), + drop_empty = FALSE) { theme <- match.arg(theme) detail_level <- match.arg(detail_level) @@ -137,31 +148,28 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=FALSE, ad if (!any(hasName(args, c("type", "statistic")))) { if (detail_level == "extended") { args <- - modifyList( - args, - list( - type = list(gtsummary::all_continuous() ~ "continuous2", - gtsummary::all_dichotomous() ~ "categorical"), - statistic = list(gtsummary::all_continuous() ~ c( - "{median} ({p25}, {p75})", - "{mean} ({sd})", - "{min}, {max}")) + modifyList(args, list( + type = list( + gtsummary::all_continuous() ~ "continuous2", + gtsummary::all_dichotomous() ~ "categorical" + ), + statistic = list( + gtsummary::all_continuous() ~ c("{median} ({p25}, {p75})", "{mean} ({sd})", "{min}, {max}") ) - ) + )) } } - parameters <- list( - data = data, - fun.args = purrr::list_flatten(list(by = by.var, args)) - ) + if (isTRUE(drop_empty)) { + ## Drops empty levels if minimal + data <- data |> REDCapCAST::fct_drop() + } + + parameters <- list(data = data, fun.args = purrr::list_flatten(list(by = by.var, args))) # browser() - out <- do.call( - baseline_table, - parameters - ) + out <- do.call(baseline_table, parameters) if (!is.null(by.var)) { @@ -1121,7 +1129,7 @@ vectorSelectInput <- function(inputId, colorSelectInput <- function(inputId, label, choices, - selected = "", + selected = NULL, previews = 4, ..., placeholder = "") { @@ -1157,31 +1165,43 @@ colorSelectInput <- function(inputId, choices_new <- stats::setNames(vals, labels) + if (is.null(selected) || selected == "") { + selected <- vals[[1]] + } + shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., - options = list( + options = list( render = I( "{ - option: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '
' + escape(item.data.name) + '
' + - (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + - '
' + item.data.swatch + '
' + - '
'; - }, - item: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '' + escape(item.data.name) + '' + - item.data.swatch + - '
'; - } - }" + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" + ), + onInitialize = I( + "function() { + var self = this; + self.$control_input.prop('readonly', true); + self.$control_input.css('cursor', 'default'); + self.$control.css('cursor', 'pointer'); + }" ) ) ) @@ -1862,7 +1882,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { rlang::exec(cut_var, !!!parameters) }, error = function(err) { - showNotification(paste("We encountered the following error creating the new factor:", err), type = "err") + showNotification(paste("We encountered the following error creating the new factor:", err), type = "error") } ) @@ -2468,7 +2488,7 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, @@ -2494,7 +2514,7 @@ data_visuals_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) } }, ignoreInit = TRUE) @@ -2717,6 +2737,18 @@ supported_plots <- function() { secondary.max = 4, tertiary.type = c("dichotomous"), secondary.extra = NULL + ), + plot_euler = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t( + "Plot survey results" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL ) ) } @@ -4303,8 +4335,8 @@ default_parsing <- function(data) { REDCapCAST::as_factor() |> REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> - REDCapCAST::as_logical() |> - REDCapCAST::fct_drop() + REDCapCAST::as_logical() #|> + # REDCapCAST::fct_drop() }) # out <- # @@ -4914,12 +4946,63 @@ data_types <- function() { ) } +non_character_cols <- function(df) { + if (shiny::is.reactive(df)) df <- df() + df[, !sapply(df, is.character), drop = FALSE] +} + +apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()) { + # If this ever brakes, the solution will have to be to modify the original filter function + if (shiny::is.reactive(df_target)) df_target <- df_target() + + result <- if (shiny::is.reactive(filtered_reactive)) filtered_reactive() else filtered_reactive + filter_code <- attr(result, "code") + + if (is.null(filter_code)) return(df_target) + + deparsed <- paste(deparse(filter_code), collapse = "") + + if (is.symbol(filter_code) || !grepl("filter(", deparsed, fixed = TRUE)) { + return(df_target) + } + + extract_filters <- function(code) { + filters <- list() + while (!is.symbol(code) && deparse(code[[1]]) == "%>%") { + rhs <- code[[3]] + if (deparse(rhs[[1]]) == "filter") { + filters <- c(list(rhs), filters) + } + code <- code[[2]] + } + if (!is.symbol(code) && deparse(code[[1]]) == "filter") { + filters <- c(list(code), filters) + } + filters + } + + tryCatch({ + out <- df_target + for (f in extract_filters(filter_code)) { + args <- lapply(rlang::call_args(f), function(arg) { + rlang::new_quosure(arg, env = env) + }) + out <- dplyr::filter(out, !!!args) + } + out + }, + error = function(e) { + warning("Could not apply filter: ", conditionMessage(e)) + df_target + }) +} + ######## #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.4-260324' +hosted_version <- function()'v26.3.5-260330' ######## @@ -5698,7 +5781,7 @@ import_file_server <- function(id, # showNotification(warn, type = "warning") # }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") }) }) @@ -5715,7 +5798,7 @@ import_file_server <- function(id, minBodyHeight = 250 ) }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") }) }) @@ -5830,7 +5913,7 @@ import_xls <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) } @@ -5858,7 +5941,7 @@ import_ods <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + ?showNotification(paste0(err), type = "error") }) } @@ -6701,7 +6784,7 @@ data_missings_server <- function(id, data, max_level = 20, ...) { out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl))) }) }, error = function(err) { - showNotification(paste0("Error: ", err), type = "err") + showNotification(paste0("Error: ", err), type = "error") }) if (is.null(input$missings_var) || @@ -7406,6 +7489,62 @@ vertical_stacked_bars <- function(data, } +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_likert.R +######## + +#' Nice horizontal bar plot centred on the central category +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_likert(pri = "carb", sec = "cyl") +#' mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") +#' mtcars |> plot_likert(pri = "cyl",color.palette="Blues") +#' mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") +plot_likert <- function(data, + pri, + sec = NULL, + ter = NULL, + color.palette = "viridis") { + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + out <- lapply(ds, \(.x) { + .x[c(pri, sec)] |> + # na.omit() |> + plot_likert_single(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)+ + ggplot2::theme( + # legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = ggplot2::element_blank(), + # axis.title.y = ggplot2::element_blank(), + text = ggplot2::element_text(size = 12) + # axis.text = ggplot2::element_blank(), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + # plot.background = ggplot2::element_rect(fill = "white"), + # panel.border = ggplot2::element_blank() + ) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//plot_ridge.R ######## @@ -7990,10 +8129,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4( - i18n$t("Import data from REDCap"), - class = "redcap-module-title" - ) + title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") } server_ui <- shiny::tagList( @@ -8004,7 +8140,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), + shiny::helpText( + i18n$t( + "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" + ) + ), shiny::br(), shiny::br(), shiny::passwordInput( @@ -8013,7 +8153,9 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), + shiny::helpText(i18n$t( + "The token is a string of 32 numbers and letters." + )), shiny::br(), shiny::br(), shiny::actionButton( @@ -8030,7 +8172,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) + tags$p( + phosphoricons::ph("info", weight = "bold"), + i18n$t("Please fill in web address and API token, then press 'Connect'.") + ) ), dismissible = TRUE ), @@ -8043,14 +8188,18 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" - )) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") + ), + uiOutput(ns("filter_feedback")) ) params_ui <- shiny::tagList( shiny::tags$h4(i18n$t("Data import parameters")), shiny::tags$div( + #### + #### All below was deactivated to deactivate filtering + #### style = htmltools::css( display = "grid", gridTemplateColumns = "1fr 50px", @@ -8075,7 +8224,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ) ) ), - shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), + shiny::helpText( + i18n$t( + "Select fields/variables to import and click the funnel to apply optional filters" + ) + ), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -8094,7 +8247,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") + tags$p( + phosphoricons::ph("info", weight = "bold"), + "Please specify data to download, then press 'Import'." + ) ), dismissible = TRUE ) @@ -8105,11 +8261,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel( - condition = "output.connect_success == true", - params_ui, - ns = ns - ), + shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), shiny::br() ) } @@ -8134,14 +8286,19 @@ m_redcap_readServer <- function(id) { dd_list = NULL, data = NULL, rep_fields = NULL, - code = NULL + code = NULL, + filter_valid = NULL ) shiny::observeEvent(list(input$api, input$uri), { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") + uri <- paste0(ifelse( + endsWith(input$uri, "/"), + input$uri, + paste0(input$uri, "/") + ), "api/") } else { uri <- input$uri } @@ -8155,75 +8312,68 @@ m_redcap_readServer <- function(id) { }) - tryCatch( - { - shiny::observeEvent( - list( - input$data_connect - ), - { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch({ + shiny::observeEvent(list(input$data_connect), { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list( - redcap_uri = data_rv$uri, - token = input$api - ) + parameters <- list(redcap_uri = data_rv$uri, token = input$api) - # browser() - shiny::withProgress( - { - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) - }, - message = paste("Connecting to", data_rv$uri) - ) + # browser() + shiny::withProgress({ + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), + silent = TRUE) + }, message = paste("Connecting to", data_rv$uri)) - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || + NROW(imported) < 1 || + ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), + !isTRUE(imported$success), + FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" - data_rv$info <- REDCapR::redcap_project_info_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), - glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) - ), - btn_show_data = TRUE + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b( + phosphoricons::ph("check", weight = "bold"), + i18n$t("Connected to server!") + ), + glue::glue( + i18n$t( + "The {data_rv$info$project_title} project is loaded." + ) ) - ) + ), + btn_show_data = TRUE + ) + ) - data_rv$dd_list <- imported - } - }, - ignoreInit = TRUE - ) - }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - ) + data_rv$dd_list <- imported + } + }, ignoreInit = TRUE) + }, warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { + showNotification(paste0(err), type = "error") + }) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -8254,10 +8404,7 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data }) output$fields <- shiny::renderUI({ @@ -8267,7 +8414,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x){ + (\(.x) { split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -8300,14 +8447,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[ - data_rv$dd_list$data$form_name %in% repeated_instruments( - uri = data_rv$uri, - token = input$api - ) - ] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] - if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && + isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -8343,12 +8486,48 @@ m_redcap_readServer <- function(id) { } }) + + filter_validation <- reactive({ + val <- trimws(input$filter) + if (nchar(val) == 0) + return(NULL) + validate_redcap_filter(val, purrr::pluck(data_rv$dd_list, "data")) + }) + + output$filter_feedback <- renderUI({ + result <- filter_validation() + if (is.null(result)) { + data_rv$filter_valid <- NULL + return(NULL) + } + + if (result$valid) { + data_rv$filter_valid <- TRUE + tags$span(style = "color: green;", "\u2713 Filter is valid") + } else { + data_rv$filter_valid <- FALSE + + tags$span(style = "color: red;", + "\u2717 ", + line_break(result$message, lineLength = 30)) + } + }) + shiny::observeEvent(input$data_import, { shiny::req(input$fields) # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] + if (!is.null(data_rv$filter_valid)) { + if (isTRUE(data_rv$filter_valid)) { + filter <- trimws(input$filter) + } else { + filter <- "" + } + } else { + filter <- "" + } parameters <- list( uri = data_rv$uri, @@ -8356,7 +8535,8 @@ m_redcap_readServer <- function(id) { fields = unique(c(record_id, input$fields)), events = input$arms, raw_or_label = "both", - filter_logic = input$filter, + filter_logic = filter, + # filter_logic = "", split_forms = ifelse( input$data_type == "long" && !is.null(input$data_type), "none", @@ -8365,31 +8545,48 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) + imported <- try({ + rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters) + # if (nrow(out)==0){ + # stop("No data was exported") + # } else { + # out + # } + }, # error = function(err) { + # showNotification(i18n$t("An error was encountered exporting data. Please review data filter."), type = "error") + # }, + silent = TRUE) }) - parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] + # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) - code <- rlang::call2( - "easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST" - ) + parameters_code <- parameters[c("uri", + "fields", + "events", + "raw_or_label", + "filter_logic")] - if (inherits(imported, "try-error") || NROW(imported) < 1) { + code <- rlang::call2("easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST") + + if (inherits(imported, "try-error") | + NROW(imported) == 0 | + (length(imported) == 1 & !is.list(imported))) { data_rv$data_status <- "error" data_rv$data_list <- NULL - data_rv$data_message <- imported$raw_text + data_rv$data_message <- i18n$t("An empty data set was imported. Please review data filter.") + data_rv$data <- NULL } else { data_rv$data_status <- "success" data_rv$data_message <- i18n$t("Requested data was retrieved!") @@ -8398,12 +8595,11 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { - # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() } else { - if (input$fill == "yes") { + if (identical(input$fill, "yes")) { ## Repeated fields @@ -8421,78 +8617,102 @@ m_redcap_readServer <- function(id) { } } - # browser() + ## Ensure correct factor labels + ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way + out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) + + in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) + sapply(names(out), \(.x) any(sapply( + parameters$fields, \(.y) startsWith(.x, .y) + ))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } data_rv$code <- code + ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() + } }) - shiny::observeEvent( - data_rv$data_status, - { - # browser() - if (identical(data_rv$data_status, "error")) { - datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) - ), - btn_show_data = TRUE - ) + shiny::observeEvent(data_rv$data_status, { + if (identical(data_rv$data_status, "error")) { + ## The insert error wouldn't work. Inserted through regular. + # datamods:::insert_error(mssg = data_rv$data_message, + # selector = ns("retrieved")) + datamods:::insert_alert( + selector = ns("retrieved"), + status = "danger", + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), + ) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p(tags$b( + phosphoricons::ph("check", weight = "bold"), data_rv$data_message - ) + )), + btn_show_data = TRUE ) - } + ) + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message + ) + ) } - ) + }) - return(list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - )) + return( + list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + ) + ) } - shiny::moduleServer( - id = id, - module = module - ) + shiny::moduleServer(id = id, module = module) } #' @importFrom htmltools tagList tags @@ -8503,14 +8723,12 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList( - extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - ) - ) + success_message <- tagList(extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + )) } return(success_message) } @@ -8562,20 +8780,18 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { +is_valid_token <- function(token, + pattern_env = NULL, + nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, - any.missing = FALSE, - len = 1 - ) + checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">" - ) + .open = "<", + .close = ">") } if (is.na(token)) { @@ -8615,10 +8831,15 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") + generics <- c( + names(data)[1], + "redcap_event_name", + "redcap_repeat_instrument", + "redcap_repeat_instance" + ) filt <- split(data, data[[event]]) |> - lapply(\(.x){ + lapply(\(.x) { dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -8628,6 +8849,327 @@ drop_empty_event <- function(data, event = "redcap_event_name") { } +#' Validate a REDCap server-side filter string against a data dictionary +#' +#' Checks that a REDCap filter expression is syntactically correct and +#' consistent with the field types defined in the project data dictionary. +#' Plain text without field references is always rejected. Multi-clause +#' filters joined by \code{AND} or \code{OR} are supported. +#' +#' @param filter A single character string containing the filter expression, +#' e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}. +#' @param dictionary A data frame representing the REDCap data dictionary in +#' API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. +#' Must contain at least the columns \code{field_name} and \code{field_type}. +#' The columns \code{text_validation_type_or_show_slider_number} and +#' \code{select_choices_or_calculations} are used when present for stricter +#' type and choice validation. +#' +#' @return A named list with two elements: +#' \describe{ +#' \item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} +#' \item{\code{message}}{Character. \code{"Filter is valid."} on success, or +#' a newline-separated string of error messages describing every problem +#' found.} +#' } +#' +#' @details +#' Validation rules by field type: +#' \describe{ +#' \item{\code{calc}}{Numeric fields. Value must be an unquoted number. +#' All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, +#' \code{<=}, \code{>=}) are accepted.} +#' \item{\code{text} with date validation}{Fields with validation type +#' \code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be +#' a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All +#' comparison operators are accepted.} +#' \item{\code{text} with time validation}{Fields with validation type +#' \code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time +#' string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} +#' \item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a +#' quoted choice code (e.g. \code{'1'}) that exists in the field's choice +#' list. Only \code{=} and \code{!=} are accepted.} +#' \item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. +#' Only \code{=} and \code{!=} are accepted.} +#' } +#' +#' @examples +#' \dontrun{ +#' dict <- REDCapCAST::get_redcap_metadata( +#' uri = "https://redcap.example.com/api/", +#' token = Sys.getenv("REDCAP_TOKEN") +#' ) +#' +#' validate_redcap_filter("[age] > 18", dict) +#' #> list(valid = TRUE, message = "Filter is valid.") +#' +#' validate_redcap_filter("only plain text", dict) +#' #> list(valid = FALSE, message = "Filter must contain at least one field ...") +#' +#' validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) +#' #> list(valid = TRUE, message = "Filter is valid.") +#' } +#' +#' @export +# REDCap filter validation based on data dictionary +# +# REDCap filter format: [field_name] operator value +# Example: [age] > 18 +# [cohabitation] = '1' +# [inclusion] > '2020-01-01' +# +# Supported field types and their allowed operators/value formats: +# text (no validation) -> string values, = != operators only +# text (date_ymd/date_dmy) -> quoted date strings, all comparison operators +# text (time_hh_mm_ss) -> quoted time strings, all comparison operators +# text (datetime_*) -> quoted datetime strings, all comparison operators +# text (autocomplete) -> string values, = != operators only +# calc -> numeric values, all comparison operators +# radio/dropdown -> quoted numeric codes, = != operators only + +validate_redcap_filter <- function(filter, dictionary) { + # --- Input checks --- + if (!is.character(filter) || + length(filter) != 1 || nchar(trimws(filter)) == 0) { + return(list(valid = FALSE, message = "Filter must be a non-empty string.")) + } + + if (!grepl("\\[.+\\]", filter)) { + return( + list(valid = FALSE, message = "Filter must contain at least one field reference in [brackets]. Plain text is not accepted.") + ) + } + + # --- Column names (API export format) --- + col_field <- "field_name" + col_type <- "field_type" + col_val_type <- "text_validation_type_or_show_slider_number" + col_choices <- "select_choices_or_calculations" + + missing_cols <- setdiff(c(col_field, col_type), names(dictionary)) + if (length(missing_cols) > 0) { + stop("Dictionary is missing required columns: ", + paste(missing_cols, collapse = ", ")) + } + + # --- Build lookup index once for O(1) field access --- + field_idx <- setNames(seq_len(nrow(dictionary)), dictionary[[col_field]]) + has_val_type <- col_val_type %in% names(dictionary) + has_choices <- col_choices %in% names(dictionary) + + # --- Classify field types --- + numeric_types <- c("calc") + date_validations <- c( + "date_ymd", + "date_dmy", + "datetime_ymd", + "datetime_dmy", + "datetime_seconds_ymd", + "datetime_seconds_dmy" + ) + time_validations <- c("time_hh_mm_ss", "time_mm_ss") + categorical_types <- c("radio", "dropdown", "checkbox") + text_types <- c("text", "autocomplete") + + num_ops <- c("=", "!=", "<", ">", "<=", ">=") + cat_ops <- c("=", "!=") + text_ops <- c("=", "!=") + + # --- Parse filter into clauses --- + # Split on AND/OR (REDCap uses 'and'/'or' or 'AND'/'OR') + clauses <- trimws(strsplit(filter, "(?i)\\s+(and|or)\\s+", perl = TRUE)[[1]]) + + clause_pattern <- "^\\[([^\\]]+)\\]\\s*(=|!=|<=|>=|<|>)\\s*(.+)$" + + errors <- character(0) + + for (clause in clauses) { + if (!grepl(clause_pattern, clause, perl = TRUE)) { + errors <- c( + errors, + sprintf( + "Clause '%s' does not match expected format: [field] operator value", + clause + ) + ) + next + } + + parts <- regmatches(clause, regexec(clause_pattern, clause, perl = TRUE))[[1]] + field <- parts[2] + operator <- parts[3] + value <- trimws(parts[4]) + + # --- Check field exists using pre-built index --- + row_i <- field_idx[field] + if (is.na(row_i)) { + errors <- c(errors, sprintf("Unknown field: [%s]", field)) + next + } + + field_type <- dictionary[[col_type]][row_i] + val_type <- if (has_val_type) + dictionary[[col_val_type]][row_i] + else + "" + if (is.na(val_type)) + val_type <- "" + + # --- Determine expected value format and allowed operators --- + if (field_type %in% numeric_types || + grepl("^integer$|^number", val_type)) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is numeric — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl("^-?[0-9]+(\\.[0-9]+)?$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is numeric — value '%s' should be an unquoted number (e.g. 18 or 3.5)", + field, + value + ) + ) + } + + } else if (val_type %in% date_validations) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a date — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl( + "^'[0-9]{4}-[0-9]{2}-[0-9]{2}(\\s[0-9]{2}:[0-9]{2}(:[0-9]{2})?)?'$", + value + )) { + errors <- c( + errors, + sprintf( + "[%s] is a date — value '%s' should be a quoted date string, e.g. '2020-01-31'", + field, + value + ) + ) + } + + } else if (val_type %in% time_validations) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a time — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl("^'[0-9]{2}:[0-9]{2}(:[0-9]{2})?'$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is a time — value '%s' should be a quoted time string, e.g. '14:30:00'", + field, + value + ) + ) + } + + } else if (field_type %in% categorical_types) { + if (!operator %in% cat_ops) { + errors <- c( + errors, + sprintf( + "[%s] is categorical — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(cat_ops, collapse = ", ") + ) + ) + } + + # Validate value is a known choice code + choices_raw <- if (has_choices) + dictionary[[col_choices]][row_i] + else + NA + if (!is.na(choices_raw) && nchar(trimws(choices_raw)) > 0) { + choice_codes <- trimws(gsub(",.+?(\\||$)", "", gsub( + "^\\s*", "", strsplit(choices_raw, "\\|")[[1]] + ))) + value_unquoted <- gsub("^'|'$", "", value) + if (!value_unquoted %in% choice_codes) { + errors <- c( + errors, + sprintf( + "[%s] is categorical — '%s' is not a valid choice code. Valid codes: %s", + field, + value_unquoted, + paste(choice_codes, collapse = ", ") + ) + ) + } + } + + if (!grepl("^'.*'$", value)) { + errors <- c(errors, + sprintf( + "[%s] is categorical — value should be quoted, e.g. '1'", + field + )) + } + + } else { + # Plain text field + if (!operator %in% text_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a text field — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(text_ops, collapse = ", ") + ) + ) + } + if (!grepl("^'.*'$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is a text field — value should be quoted, e.g. 'some text'", + field + ) + ) + } + } + } + + if (length(errors) > 0) { + return(list( + valid = FALSE, + message = paste(errors, collapse = "\n") + )) + } + + list(valid = TRUE, message = "Filter is valid.") +} + + + #' Test app for the redcap_read_shiny_module #' #' @rdname redcap_read_shiny_module @@ -8646,16 +9188,10 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable( - { - shiny::req(data_val$data) - data_val$data() - }, - options = list( - scrollX = TRUE, - pageLength = 5 - ), - ) + output$data <- DT::renderDataTable({ + shiny::req(data_val$data) + data_val$data() + }, options = list(scrollX = TRUE, pageLength = 5), ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code() @@ -10054,7 +10590,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "error") } ) } @@ -10119,7 +10655,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "error") } ) } @@ -10197,7 +10733,7 @@ regression_server <- function(id, gg_theme_shiny() }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") } ) }) @@ -10257,7 +10793,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "error") } ) } @@ -10328,7 +10864,7 @@ regression_server <- function(id, out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") } ) @@ -11998,15 +12534,26 @@ update_factor_ui <- function(id) { ), fluidRow( column( - width = 6, + width = 3, shinyWidgets::virtualSelectInput( inputId = ns("variable"), - label = i18n$t("Factor variable to reorder:"), + label = i18n$t("Choose variable:"), choices = NULL, width = "100%", zIndex = 50 ) ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + disabled = TRUE, + inputId = ns("drop_levels"), + label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ), column( width = 3, class = "d-flex align-items-end", @@ -12039,7 +12586,9 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), + label = i18n$t( + "Create a new variable; otherwise replaces (Updating labels always creates new variable)" + ), value = FALSE, status = "primary", outline = TRUE, @@ -12094,6 +12643,20 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- grid }) + observeEvent(rv$data_grid, { + variable <- req(input$variable) + if (isTRUE(has_empty_levels(rv$data[[variable]]))) { + # browser() + updateActionButton(inputId = "drop_levels", disabled = FALSE) + } else { + updateActionButton(inputId = "drop_levels", disabled = TRUE) + } + }) + + observeEvent(input$drop_levels, { + rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,] + }) + observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -12177,7 +12740,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { ) data <- tryCatch({ - with_labels(data,{ + with_labels(data, { rlang::exec(factor_new_levels_labels, !!!modifyList(parameters, val = list(data = data))) }) @@ -12187,7 +12750,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { "We encountered the following error creating the new factor:", err ), - type = "err") + type = "error") }) # browser() @@ -12341,6 +12904,15 @@ unique_names <- function(new, existing = character()) { } +has_empty_levels <- function(x) { + if (is.factor(x)) { + any(!levels(x) %in% x) + } else { + return(FALSE) + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R ######## @@ -14871,7 +15443,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "err") + ), type = "error") }) }) @@ -15128,6 +15700,7 @@ server <- function(input, output, session) { inputId = "column_filter", label = i18n$t("Select data types to include"), selected = unique(data_type(rv$data)), + #[unique(data_type(rv$data))!="text"], choices = unique(data_type(rv$data)), updateOn = "change", multiple = TRUE, @@ -15220,48 +15793,58 @@ server <- function(input, output, session) { ######### Data filter # IDEAFilter has the least cluttered UI, but might have a License issue # Consider using shinyDataFilter, though not on CRAN - data_filter <- IDEAFilter::IDEAFilter( + data_filter_raw <- IDEAFilter::IDEAFilter( "data_filter", - data = shiny::reactive(rv$data_variables), + data = shiny::reactive(non_character_cols(rv$data_variables)), verbose = TRUE ) - shiny::observeEvent(list( - shiny::reactive(rv$data_variables), - shiny::reactive(rv$data_original), - data_filter(), - # regression_vars(), - input$complete_cutoff - ), - { - ### Save filtered data - rv$data_filtered <- data_filter() - - ### Save filtered data - ### without empty factor levels - rv$list$data <- data_filter() |> - REDCapCAST::fct_drop() |> - (\(.x) { - .x[!sapply(.x, is.character)] - })() - - ## This looks messy!! But it works as intended for now - - out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( - attr(rv$data_filtered, "code") - ), collapse = " "))) - - out <- strsplit(out, "%>%") |> - unlist() |> - (\(.x) { - paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"), collapse = "|> \n ") - })() - - rv$code <- append_list(data = out, - list = rv$code, - index = "filter") + data_filter <- reactive({ + apply_idea_filter(data_filter_raw, rv$data_variables) }) + shiny::observeEvent( + list( + shiny::reactive(rv$data_variables), + shiny::reactive(rv$data_original), + data_filter_raw(), + # regression_vars(), + input$complete_cutoff + ), + { + ### Save filtered data + # browser() + # rv$data_filtered <- apply_idea_filter(data_filter_raw, rv$data_variables)() + rv$data_filtered <- data_filter() + + ### Save filtered data + ### ~~without empty factor levels~~ + ### All factor levels are kept, but can be manually removed + # browser() + rv$list$data <- rv$data_filtered #|> + # # REDCapCAST::fct_drop() |> + # (\(.x) { + # .x[!sapply(.x, is.character)] + # })() + + ## This looks messy!! But it works as intended for now + # browser() + out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( + attr(data_filter_raw(), "code") + ), collapse = " "))) + + out <- strsplit(out, "%>%") |> + unlist() |> + (\(.x) { + paste(c("df <- df", .x[-1]), collapse = "|> \n ") + })() + + rv$code <- append_list(data = out, + list = rv$code, + index = "filter") + } + ) + ######### Data preview ### Overview @@ -15279,7 +15862,7 @@ server <- function(input, output, session) { observeEvent(input$modal_browse, { tryCatch({ show_data( - REDCapCAST::fct_drop(rv$data_filtered), + rv$data_filtered, title = i18n$t("Uploaded data overview"), type = "modal" ) @@ -15287,7 +15870,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error browsing your data:"), err - ), type = "err") + ), type = "error") }) }) @@ -15313,7 +15896,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "err") + ), type = "error") }) }) @@ -15520,7 +16103,7 @@ server <- function(input, output, session) { # } # }, # error = function(err) { - # showNotification(err, type = "err") + # showNotification(err, type = "error") # } # ) @@ -15679,7 +16262,7 @@ server <- function(input, output, session) { "We encountered the following error creating your report: " ), err - ), type = "err") + ), type = "error") }) }) file.rename(paste0("www/report.", type), file) diff --git a/app_docker/renv.lock b/app_docker/renv.lock index 567601cc..96709a25 100644 --- a/app_docker/renv.lock +++ b/app_docker/renv.lock @@ -35,12 +35,12 @@ }, "DHARMa": { "Package": "DHARMa", - "Version": "0.4.6", + "Version": "0.4.7", "Source": "Repository", "Title": "Residual Diagnostics for Hierarchical (Multi-Level / Mixed) Regression Models", - "Date": "2022-09-08", - "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"))", - "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB' 'GLMMadaptive' and 'spaMM', generalized additive models ('gam' from 'mgcv'), 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial and temporal autocorrelation.", + "Date": "2024-10-16", + "Authors@R": "c(person(\"Florian\", \"Hartig\", email = \"florian.hartig@biologie.uni-regensburg.de\", role = c(\"aut\", \"cre\"), comment=c(ORCID=\"0000-0002-6255-9059\")), person(\"Lukas\", \"Lohse\", role = \"ctb\"), person(\"Melina\", \"de Souza leite\", role = \"ctb\"))", + "Description": "The 'DHARMa' package uses a simulation-based approach to create readily interpretable scaled (quantile) residuals for fitted (generalized) linear mixed models. Currently supported are linear and generalized linear (mixed) models from 'lme4' (classes 'lmerMod', 'glmerMod'), 'glmmTMB', 'GLMMadaptive', and 'spaMM'; phylogenetic linear models from 'phylolm' (classes 'phylolm' and 'phyloglm'); generalized additive models ('gam' from 'mgcv'); 'glm' (including 'negbin' from 'MASS', but excluding quasi-distributions) and 'lm' model classes. Moreover, externally created simulations, e.g. posterior predictive simulations from Bayesian software such as 'JAGS', 'STAN', or 'BUGS' can be processed as well. The resulting residuals are standardized to values between 0 and 1 and can be interpreted as intuitively as residuals from a linear regression. The package also provides a number of plot and test functions for typical model misspecification problems, such as over/underdispersion, zero-inflation, and residual spatial, phylogenetic and temporal autocorrelation.", "Depends": [ "R (>= 3.0.2)" ], @@ -59,7 +59,7 @@ ], "Suggests": [ "knitr", - "testthat", + "testthat (>= 3.0.0)", "rmarkdown", "KernSmooth", "sfsmisc", @@ -68,7 +68,8 @@ "mgcViz (>= 0.1.9)", "spaMM (>= 3.2.0)", "GLMMadaptive", - "glmmTMB (>= 1.1.2.3)" + "glmmTMB (>= 1.1.2.3)", + "phylolm (>= 2.6.5)" ], "Enhances": [ "phyr", @@ -80,11 +81,12 @@ "URL": "http://florianhartig.github.io/DHARMa/", "LazyData": "TRUE", "BugReports": "https://github.com/florianhartig/DHARMa/issues", - "RoxygenNote": "7.2.1", + "RoxygenNote": "7.3.2", "VignetteBuilder": "knitr", "Encoding": "UTF-8", + "Config/testthat/edition": "3", "NeedsCompilation": "no", - "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb]", + "Author": "Florian Hartig [aut, cre] (), Lukas Lohse [ctb], Melina de Souza leite [ctb]", "Maintainer": "Florian Hartig ", "Repository": "CRAN" }, @@ -2345,7 +2347,7 @@ }, "datamods": { "Package": "datamods", - "Version": "1.5.2", + "Version": "1.5.3", "Source": "Repository", "Title": "Modules to Import and Manipulate Data in 'Shiny'", "Authors@R": "c(person(given = \"Victor\", family = \"Perrier\", role = c(\"aut\", \"cre\", \"cph\"), email = \"victor.perrier@dreamrs.fr\"), person(given = \"Fanny\", family = \"Meyer\", role = \"aut\"), person(given = \"Samra\", family = \"Goumri\", role = \"aut\"), person(given = \"Zauad Shahreer\", family = \"Abeer\", role = \"aut\", email = \"shahreyar.abeer@gmail.com\"), person(given = \"Eduard\", family = \"Szöcs\", role = \"ctb\", email = \"eduardszoecs@gmail.com\") )", @@ -8357,7 +8359,7 @@ }, "shinybusy": { "Package": "shinybusy", - "Version": "0.3.2", + "Version": "0.3.3", "Source": "Repository", "Title": "Busy Indicators and Notifications for 'Shiny' Applications", "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))", @@ -8370,8 +8372,8 @@ "jsonlite", "htmlwidgets" ], - "RoxygenNote": "7.2.3", - "URL": "https://github.com/dreamRs/shinybusy", + "RoxygenNote": "7.3.1", + "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/", "BugReports": "https://github.com/dreamRs/shinybusy/issues", "Suggests": [ "testthat", diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index ce9abc8e..4f3752bd 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -55,7 +55,6 @@ "Imported data","Importeret data" "www/intro.md","www/intro.md" "Choose your data","Vælg dine data" -"Factor variable to reorder:","Kategoriske variabel der skal ændres:" "Sort by levels","Sorter efter niveauer" "Sort by count","Sorter efter antal" "Update factor variable","Updater faktor-variabel" @@ -148,16 +147,12 @@ "Import data from REDCap","Importér data fra REDCap" "REDCap server","REDCap-server" "Web address","Serveradresse" -"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Adressen skal være som 'https://redcap.your.institution/' eller 'https://your.institution/redcap/'" "API token","API-nøgle" -"The token is a string of 32 numbers and letters.","En API-nøgle består af ialt 32 tal og bogstaver." "Connect","Forbind" "Data import parameters","Data import parameters" -"Select fields/variables to import and click the funnel to apply optional filters","Vælg variabler, der skal importeres og tryk på tragten for at anvende valgfrie filtre" "Import","Import" "Click to see data dictionary","Tryk for at se metadata (Data Dictionary)" "Connected to server!","Forbindelse til serveren oprettet!" -"The {data_rv$info$project_title} project is loaded.","{data_rv$info$project_title}-projektet er forbundet." "Data dictionary","Data dictionary" "Preview:","Forsmag:" "Imported data set","Importeret datasæt" @@ -165,8 +160,6 @@ "Specify the data format","Specificér dataformatet" "Fill missing values?","Skal manglende observationer udfyldes?" "Requested data was retrieved!","Det udvalgte data blev hentet!" -"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde ID-variablen. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." -"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde nogle af de udvalgte variabler. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." "Click to see the imported data","Tryk for at se de importerede data" "Regression table","Regressionstabel" "Import a dataset from an environment","Importer et datasæt fra et kodemiljø" @@ -291,7 +284,6 @@ "No data present.","Ingen data tilstede." "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." -"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -323,3 +315,9 @@ "Settings","Settings" "Create new factor","Create new factor" "Choose color palette","Choose color palette" +"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" +"Drop empty","Drop empty" +"Choose variable:","Choose variable:" +"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." +"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." +"Likert diagram","Likert diagram" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 96a7a109..a375e0a5 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -55,7 +55,6 @@ "Imported data","Data iliyoingizwa" "www/intro.md","www/intro.md" "Choose your data","Chagua data yako" -"Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:" "Sort by levels","Panga kwa viwango" "Sort by count","Panga kwa hesabu" "Update factor variable","Sasisha kigezo cha kipengele" @@ -148,16 +147,12 @@ "Import data from REDCap","Ingiza data kutoka REDCap" "REDCap server","Seva ya REDCap" "Web address","Anwani ya wavuti" -"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Muundo unapaswa kuwa 'https://redcap.your.institution/' au 'https://your.institution/redcap/'" "API token","Tokeni ya API" -"The token is a string of 32 numbers and letters.","Tokeni ni mfuatano wa nambari na herufi 32." "Connect","Unganisha" "Data import parameters","Vigezo vya kuingiza data" -"Select fields/variables to import and click the funnel to apply optional filters","Chagua sehemu/vigezo vya kuingiza na ubofye faneli ili kutumia vichujio vya hiari" "Import","Ingiza" "Click to see data dictionary","Bofya ili kuona kamusi ya data" "Connected to server!","Imeunganishwa na seva!" -"The {data_rv$info$project_title} project is loaded.","Mradi wa {data_rv$info$project_title} umepakiwa." "Data dictionary","Kamusi ya data" "Preview:","Hakikisho:" "Imported data set","Seti ya data iliyoingizwa" @@ -165,8 +160,6 @@ "Specify the data format","Bainisha umbizo la data" "Fill missing values?","Jaza thamani zinazokosekana?" "Requested data was retrieved!","Data iliyoombwa ilipatikana!" -"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana ni kitambulisho pekee kilichorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." -"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana kama si sehemu zote zilizoombwa zilizorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." "Click to see the imported data","Bofya ili kuona data iliyoingizwa" "Regression table","Jedwali la urejeshaji" "Import a dataset from an environment","Ingiza seti ya data kutoka kwa mazingira" @@ -291,7 +284,6 @@ "No data present.","No data present." "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." -"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -323,3 +315,9 @@ "Settings","Settings" "Create new factor","Create new factor" "Choose color palette","Choose color palette" +"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" +"Drop empty","Drop empty" +"Choose variable:","Choose variable:" +"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." +"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." +"Likert diagram","Likert diagram" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 1b6bf0c1..860dcd05 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//RtmpoawSeD/fileab3b7554cf72.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpgCu9u6/file55d839c4d43b.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.4' +app_version <- function()'26.3.5' ######## @@ -84,7 +84,10 @@ app_version <- function()'26.3.4' #' @examples #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) -baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) { +baseline_table <- function(data, + fun.args = NULL, + fun = gtsummary::tbl_summary, + vars = NULL) { out <- do.call(fun, c(list(data = data), fun.args)) return(out) } @@ -110,7 +113,15 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, #' mtcars |> create_baseline(by.var = "gear", detail_level = "extended",type = list(gtsummary::all_dichotomous() ~ "categorical"),theme="nejm") #' #' create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") -create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon"), detail_level = c("minimal", "extended")) { +create_baseline <- function(data, + ..., + by.var, + add.p = FALSE, + add.diff = FALSE, + add.overall = FALSE, + theme = c("jama", "lancet", "nejm", "qjecon"), + detail_level = c("minimal", "extended"), + drop_empty = FALSE) { theme <- match.arg(theme) detail_level <- match.arg(detail_level) @@ -137,31 +148,28 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=FALSE, ad if (!any(hasName(args, c("type", "statistic")))) { if (detail_level == "extended") { args <- - modifyList( - args, - list( - type = list(gtsummary::all_continuous() ~ "continuous2", - gtsummary::all_dichotomous() ~ "categorical"), - statistic = list(gtsummary::all_continuous() ~ c( - "{median} ({p25}, {p75})", - "{mean} ({sd})", - "{min}, {max}")) + modifyList(args, list( + type = list( + gtsummary::all_continuous() ~ "continuous2", + gtsummary::all_dichotomous() ~ "categorical" + ), + statistic = list( + gtsummary::all_continuous() ~ c("{median} ({p25}, {p75})", "{mean} ({sd})", "{min}, {max}") ) - ) + )) } } - parameters <- list( - data = data, - fun.args = purrr::list_flatten(list(by = by.var, args)) - ) + if (isTRUE(drop_empty)) { + ## Drops empty levels if minimal + data <- data |> REDCapCAST::fct_drop() + } + + parameters <- list(data = data, fun.args = purrr::list_flatten(list(by = by.var, args))) # browser() - out <- do.call( - baseline_table, - parameters - ) + out <- do.call(baseline_table, parameters) if (!is.null(by.var)) { @@ -1121,7 +1129,7 @@ vectorSelectInput <- function(inputId, colorSelectInput <- function(inputId, label, choices, - selected = "", + selected = NULL, previews = 4, ..., placeholder = "") { @@ -1157,31 +1165,43 @@ colorSelectInput <- function(inputId, choices_new <- stats::setNames(vals, labels) + if (is.null(selected) || selected == "") { + selected <- vals[[1]] + } + shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., - options = list( + options = list( render = I( "{ - option: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '
' + escape(item.data.name) + '
' + - (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + - '
' + item.data.swatch + '
' + - '
'; - }, - item: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '' + escape(item.data.name) + '' + - item.data.swatch + - '
'; - } - }" + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" + ), + onInitialize = I( + "function() { + var self = this; + self.$control_input.prop('readonly', true); + self.$control_input.css('cursor', 'default'); + self.$control.css('cursor', 'pointer'); + }" ) ) ) @@ -1862,7 +1882,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { rlang::exec(cut_var, !!!parameters) }, error = function(err) { - showNotification(paste("We encountered the following error creating the new factor:", err), type = "err") + showNotification(paste("We encountered the following error creating the new factor:", err), type = "error") } ) @@ -2468,7 +2488,7 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, @@ -2494,7 +2514,7 @@ data_visuals_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) } }, ignoreInit = TRUE) @@ -2717,6 +2737,18 @@ supported_plots <- function() { secondary.max = 4, tertiary.type = c("dichotomous"), secondary.extra = NULL + ), + plot_euler = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t( + "Plot survey results" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL ) ) } @@ -4303,8 +4335,8 @@ default_parsing <- function(data) { REDCapCAST::as_factor() |> REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> - REDCapCAST::as_logical() |> - REDCapCAST::fct_drop() + REDCapCAST::as_logical() #|> + # REDCapCAST::fct_drop() }) # out <- # @@ -4914,12 +4946,63 @@ data_types <- function() { ) } +non_character_cols <- function(df) { + if (shiny::is.reactive(df)) df <- df() + df[, !sapply(df, is.character), drop = FALSE] +} + +apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()) { + # If this ever brakes, the solution will have to be to modify the original filter function + if (shiny::is.reactive(df_target)) df_target <- df_target() + + result <- if (shiny::is.reactive(filtered_reactive)) filtered_reactive() else filtered_reactive + filter_code <- attr(result, "code") + + if (is.null(filter_code)) return(df_target) + + deparsed <- paste(deparse(filter_code), collapse = "") + + if (is.symbol(filter_code) || !grepl("filter(", deparsed, fixed = TRUE)) { + return(df_target) + } + + extract_filters <- function(code) { + filters <- list() + while (!is.symbol(code) && deparse(code[[1]]) == "%>%") { + rhs <- code[[3]] + if (deparse(rhs[[1]]) == "filter") { + filters <- c(list(rhs), filters) + } + code <- code[[2]] + } + if (!is.symbol(code) && deparse(code[[1]]) == "filter") { + filters <- c(list(code), filters) + } + filters + } + + tryCatch({ + out <- df_target + for (f in extract_filters(filter_code)) { + args <- lapply(rlang::call_args(f), function(arg) { + rlang::new_quosure(arg, env = env) + }) + out <- dplyr::filter(out, !!!args) + } + out + }, + error = function(e) { + warning("Could not apply filter: ", conditionMessage(e)) + df_target + }) +} + ######## #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.3.4-260324' +hosted_version <- function()'v26.3.5-260330' ######## @@ -5698,7 +5781,7 @@ import_file_server <- function(id, # showNotification(warn, type = "warning") # }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") }) }) @@ -5715,7 +5798,7 @@ import_file_server <- function(id, minBodyHeight = 250 ) }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") }) }) @@ -5830,7 +5913,7 @@ import_xls <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") }) } @@ -5858,7 +5941,7 @@ import_ods <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "err") + ?showNotification(paste0(err), type = "error") }) } @@ -6701,7 +6784,7 @@ data_missings_server <- function(id, data, max_level = 20, ...) { out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl))) }) }, error = function(err) { - showNotification(paste0("Error: ", err), type = "err") + showNotification(paste0("Error: ", err), type = "error") }) if (is.null(input$missings_var) || @@ -7406,6 +7489,62 @@ vertical_stacked_bars <- function(data, } +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_likert.R +######## + +#' Nice horizontal bar plot centred on the central category +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_likert(pri = "carb", sec = "cyl") +#' mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") +#' mtcars |> plot_likert(pri = "cyl",color.palette="Blues") +#' mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") +#' mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") +plot_likert <- function(data, + pri, + sec = NULL, + ter = NULL, + color.palette = "viridis") { + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + out <- lapply(ds, \(.x) { + .x[c(pri, sec)] |> + # na.omit() |> + plot_likert_single(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)+ + ggplot2::theme( + # legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = ggplot2::element_blank(), + # axis.title.y = ggplot2::element_blank(), + text = ggplot2::element_text(size = 12) + # axis.text = ggplot2::element_blank(), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + # plot.background = ggplot2::element_rect(fill = "white"), + # panel.border = ggplot2::element_blank() + ) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//plot_ridge.R ######## @@ -7990,10 +8129,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4( - i18n$t("Import data from REDCap"), - class = "redcap-module-title" - ) + title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") } server_ui <- shiny::tagList( @@ -8004,7 +8140,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), + shiny::helpText( + i18n$t( + "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" + ) + ), shiny::br(), shiny::br(), shiny::passwordInput( @@ -8013,7 +8153,9 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), + shiny::helpText(i18n$t( + "The token is a string of 32 numbers and letters." + )), shiny::br(), shiny::br(), shiny::actionButton( @@ -8030,7 +8172,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) + tags$p( + phosphoricons::ph("info", weight = "bold"), + i18n$t("Please fill in web address and API token, then press 'Connect'.") + ) ), dismissible = TRUE ), @@ -8043,14 +8188,18 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" - )) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") + ), + uiOutput(ns("filter_feedback")) ) params_ui <- shiny::tagList( shiny::tags$h4(i18n$t("Data import parameters")), shiny::tags$div( + #### + #### All below was deactivated to deactivate filtering + #### style = htmltools::css( display = "grid", gridTemplateColumns = "1fr 50px", @@ -8075,7 +8224,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ) ) ), - shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), + shiny::helpText( + i18n$t( + "Select fields/variables to import and click the funnel to apply optional filters" + ) + ), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -8094,7 +8247,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") + tags$p( + phosphoricons::ph("info", weight = "bold"), + "Please specify data to download, then press 'Import'." + ) ), dismissible = TRUE ) @@ -8105,11 +8261,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel( - condition = "output.connect_success == true", - params_ui, - ns = ns - ), + shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), shiny::br() ) } @@ -8134,14 +8286,19 @@ m_redcap_readServer <- function(id) { dd_list = NULL, data = NULL, rep_fields = NULL, - code = NULL + code = NULL, + filter_valid = NULL ) shiny::observeEvent(list(input$api, input$uri), { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") + uri <- paste0(ifelse( + endsWith(input$uri, "/"), + input$uri, + paste0(input$uri, "/") + ), "api/") } else { uri <- input$uri } @@ -8155,75 +8312,68 @@ m_redcap_readServer <- function(id) { }) - tryCatch( - { - shiny::observeEvent( - list( - input$data_connect - ), - { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch({ + shiny::observeEvent(list(input$data_connect), { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list( - redcap_uri = data_rv$uri, - token = input$api - ) + parameters <- list(redcap_uri = data_rv$uri, token = input$api) - # browser() - shiny::withProgress( - { - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) - }, - message = paste("Connecting to", data_rv$uri) - ) + # browser() + shiny::withProgress({ + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), + silent = TRUE) + }, message = paste("Connecting to", data_rv$uri)) - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || + NROW(imported) < 1 || + ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), + !isTRUE(imported$success), + FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" - data_rv$info <- REDCapR::redcap_project_info_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), - glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) - ), - btn_show_data = TRUE + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b( + phosphoricons::ph("check", weight = "bold"), + i18n$t("Connected to server!") + ), + glue::glue( + i18n$t( + "The {data_rv$info$project_title} project is loaded." + ) ) - ) + ), + btn_show_data = TRUE + ) + ) - data_rv$dd_list <- imported - } - }, - ignoreInit = TRUE - ) - }, - warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - ) + data_rv$dd_list <- imported + } + }, ignoreInit = TRUE) + }, warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { + showNotification(paste0(err), type = "error") + }) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -8254,10 +8404,7 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read( - redcap_uri = data_rv$uri, - token = input$api - )$data + REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data }) output$fields <- shiny::renderUI({ @@ -8267,7 +8414,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x){ + (\(.x) { split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -8300,14 +8447,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[ - data_rv$dd_list$data$form_name %in% repeated_instruments( - uri = data_rv$uri, - token = input$api - ) - ] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] - if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && + isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -8343,12 +8486,48 @@ m_redcap_readServer <- function(id) { } }) + + filter_validation <- reactive({ + val <- trimws(input$filter) + if (nchar(val) == 0) + return(NULL) + validate_redcap_filter(val, purrr::pluck(data_rv$dd_list, "data")) + }) + + output$filter_feedback <- renderUI({ + result <- filter_validation() + if (is.null(result)) { + data_rv$filter_valid <- NULL + return(NULL) + } + + if (result$valid) { + data_rv$filter_valid <- TRUE + tags$span(style = "color: green;", "\u2713 Filter is valid") + } else { + data_rv$filter_valid <- FALSE + + tags$span(style = "color: red;", + "\u2717 ", + line_break(result$message, lineLength = 30)) + } + }) + shiny::observeEvent(input$data_import, { shiny::req(input$fields) # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] + if (!is.null(data_rv$filter_valid)) { + if (isTRUE(data_rv$filter_valid)) { + filter <- trimws(input$filter) + } else { + filter <- "" + } + } else { + filter <- "" + } parameters <- list( uri = data_rv$uri, @@ -8356,7 +8535,8 @@ m_redcap_readServer <- function(id) { fields = unique(c(record_id, input$fields)), events = input$arms, raw_or_label = "both", - filter_logic = input$filter, + filter_logic = filter, + # filter_logic = "", split_forms = ifelse( input$data_type == "long" && !is.null(input$data_type), "none", @@ -8365,31 +8545,48 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) + imported <- try({ + rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters) + # if (nrow(out)==0){ + # stop("No data was exported") + # } else { + # out + # } + }, # error = function(err) { + # showNotification(i18n$t("An error was encountered exporting data. Please review data filter."), type = "error") + # }, + silent = TRUE) }) - parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] + # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) - code <- rlang::call2( - "easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST" - ) + parameters_code <- parameters[c("uri", + "fields", + "events", + "raw_or_label", + "filter_logic")] - if (inherits(imported, "try-error") || NROW(imported) < 1) { + code <- rlang::call2("easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST") + + if (inherits(imported, "try-error") | + NROW(imported) == 0 | + (length(imported) == 1 & !is.list(imported))) { data_rv$data_status <- "error" data_rv$data_list <- NULL - data_rv$data_message <- imported$raw_text + data_rv$data_message <- i18n$t("An empty data set was imported. Please review data filter.") + data_rv$data <- NULL } else { data_rv$data_status <- "success" data_rv$data_message <- i18n$t("Requested data was retrieved!") @@ -8398,12 +8595,11 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { - # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() } else { - if (input$fill == "yes") { + if (identical(input$fill, "yes")) { ## Repeated fields @@ -8421,78 +8617,102 @@ m_redcap_readServer <- function(id) { } } - # browser() + ## Ensure correct factor labels + ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way + out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) + + in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) + sapply(names(out), \(.x) any(sapply( + parameters$fields, \(.y) startsWith(.x, .y) + ))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") + data_rv$data_message <- i18n$t( + "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + ) } data_rv$code <- code + ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() + } }) - shiny::observeEvent( - data_rv$data_status, - { - # browser() - if (identical(data_rv$data_status, "error")) { - datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p( - tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) - ), - btn_show_data = TRUE - ) + shiny::observeEvent(data_rv$data_status, { + if (identical(data_rv$data_status, "error")) { + ## The insert error wouldn't work. Inserted through regular. + # datamods:::insert_error(mssg = data_rv$data_message, + # selector = ns("retrieved")) + datamods:::insert_alert( + selector = ns("retrieved"), + status = "danger", + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), + ) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p(tags$b( + phosphoricons::ph("check", weight = "bold"), data_rv$data_message - ) + )), + btn_show_data = TRUE ) - } + ) + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b( + phosphoricons::ph("warning", weight = "bold"), + "Warning!" + ), + data_rv$data_message + ) + ) } - ) + }) - return(list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - )) + return( + list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + ) + ) } - shiny::moduleServer( - id = id, - module = module - ) + shiny::moduleServer(id = id, module = module) } #' @importFrom htmltools tagList tags @@ -8503,14 +8723,12 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList( - extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - ) - ) + success_message <- tagList(extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + )) } return(success_message) } @@ -8562,20 +8780,18 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { +is_valid_token <- function(token, + pattern_env = NULL, + nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, - any.missing = FALSE, - len = 1 - ) + checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">" - ) + .open = "<", + .close = ">") } if (is.na(token)) { @@ -8615,10 +8831,15 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") + generics <- c( + names(data)[1], + "redcap_event_name", + "redcap_repeat_instrument", + "redcap_repeat_instance" + ) filt <- split(data, data[[event]]) |> - lapply(\(.x){ + lapply(\(.x) { dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -8628,6 +8849,327 @@ drop_empty_event <- function(data, event = "redcap_event_name") { } +#' Validate a REDCap server-side filter string against a data dictionary +#' +#' Checks that a REDCap filter expression is syntactically correct and +#' consistent with the field types defined in the project data dictionary. +#' Plain text without field references is always rejected. Multi-clause +#' filters joined by \code{AND} or \code{OR} are supported. +#' +#' @param filter A single character string containing the filter expression, +#' e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}. +#' @param dictionary A data frame representing the REDCap data dictionary in +#' API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. +#' Must contain at least the columns \code{field_name} and \code{field_type}. +#' The columns \code{text_validation_type_or_show_slider_number} and +#' \code{select_choices_or_calculations} are used when present for stricter +#' type and choice validation. +#' +#' @return A named list with two elements: +#' \describe{ +#' \item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} +#' \item{\code{message}}{Character. \code{"Filter is valid."} on success, or +#' a newline-separated string of error messages describing every problem +#' found.} +#' } +#' +#' @details +#' Validation rules by field type: +#' \describe{ +#' \item{\code{calc}}{Numeric fields. Value must be an unquoted number. +#' All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, +#' \code{<=}, \code{>=}) are accepted.} +#' \item{\code{text} with date validation}{Fields with validation type +#' \code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be +#' a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All +#' comparison operators are accepted.} +#' \item{\code{text} with time validation}{Fields with validation type +#' \code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time +#' string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} +#' \item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a +#' quoted choice code (e.g. \code{'1'}) that exists in the field's choice +#' list. Only \code{=} and \code{!=} are accepted.} +#' \item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. +#' Only \code{=} and \code{!=} are accepted.} +#' } +#' +#' @examples +#' \dontrun{ +#' dict <- REDCapCAST::get_redcap_metadata( +#' uri = "https://redcap.example.com/api/", +#' token = Sys.getenv("REDCAP_TOKEN") +#' ) +#' +#' validate_redcap_filter("[age] > 18", dict) +#' #> list(valid = TRUE, message = "Filter is valid.") +#' +#' validate_redcap_filter("only plain text", dict) +#' #> list(valid = FALSE, message = "Filter must contain at least one field ...") +#' +#' validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) +#' #> list(valid = TRUE, message = "Filter is valid.") +#' } +#' +#' @export +# REDCap filter validation based on data dictionary +# +# REDCap filter format: [field_name] operator value +# Example: [age] > 18 +# [cohabitation] = '1' +# [inclusion] > '2020-01-01' +# +# Supported field types and their allowed operators/value formats: +# text (no validation) -> string values, = != operators only +# text (date_ymd/date_dmy) -> quoted date strings, all comparison operators +# text (time_hh_mm_ss) -> quoted time strings, all comparison operators +# text (datetime_*) -> quoted datetime strings, all comparison operators +# text (autocomplete) -> string values, = != operators only +# calc -> numeric values, all comparison operators +# radio/dropdown -> quoted numeric codes, = != operators only + +validate_redcap_filter <- function(filter, dictionary) { + # --- Input checks --- + if (!is.character(filter) || + length(filter) != 1 || nchar(trimws(filter)) == 0) { + return(list(valid = FALSE, message = "Filter must be a non-empty string.")) + } + + if (!grepl("\\[.+\\]", filter)) { + return( + list(valid = FALSE, message = "Filter must contain at least one field reference in [brackets]. Plain text is not accepted.") + ) + } + + # --- Column names (API export format) --- + col_field <- "field_name" + col_type <- "field_type" + col_val_type <- "text_validation_type_or_show_slider_number" + col_choices <- "select_choices_or_calculations" + + missing_cols <- setdiff(c(col_field, col_type), names(dictionary)) + if (length(missing_cols) > 0) { + stop("Dictionary is missing required columns: ", + paste(missing_cols, collapse = ", ")) + } + + # --- Build lookup index once for O(1) field access --- + field_idx <- setNames(seq_len(nrow(dictionary)), dictionary[[col_field]]) + has_val_type <- col_val_type %in% names(dictionary) + has_choices <- col_choices %in% names(dictionary) + + # --- Classify field types --- + numeric_types <- c("calc") + date_validations <- c( + "date_ymd", + "date_dmy", + "datetime_ymd", + "datetime_dmy", + "datetime_seconds_ymd", + "datetime_seconds_dmy" + ) + time_validations <- c("time_hh_mm_ss", "time_mm_ss") + categorical_types <- c("radio", "dropdown", "checkbox") + text_types <- c("text", "autocomplete") + + num_ops <- c("=", "!=", "<", ">", "<=", ">=") + cat_ops <- c("=", "!=") + text_ops <- c("=", "!=") + + # --- Parse filter into clauses --- + # Split on AND/OR (REDCap uses 'and'/'or' or 'AND'/'OR') + clauses <- trimws(strsplit(filter, "(?i)\\s+(and|or)\\s+", perl = TRUE)[[1]]) + + clause_pattern <- "^\\[([^\\]]+)\\]\\s*(=|!=|<=|>=|<|>)\\s*(.+)$" + + errors <- character(0) + + for (clause in clauses) { + if (!grepl(clause_pattern, clause, perl = TRUE)) { + errors <- c( + errors, + sprintf( + "Clause '%s' does not match expected format: [field] operator value", + clause + ) + ) + next + } + + parts <- regmatches(clause, regexec(clause_pattern, clause, perl = TRUE))[[1]] + field <- parts[2] + operator <- parts[3] + value <- trimws(parts[4]) + + # --- Check field exists using pre-built index --- + row_i <- field_idx[field] + if (is.na(row_i)) { + errors <- c(errors, sprintf("Unknown field: [%s]", field)) + next + } + + field_type <- dictionary[[col_type]][row_i] + val_type <- if (has_val_type) + dictionary[[col_val_type]][row_i] + else + "" + if (is.na(val_type)) + val_type <- "" + + # --- Determine expected value format and allowed operators --- + if (field_type %in% numeric_types || + grepl("^integer$|^number", val_type)) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is numeric — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl("^-?[0-9]+(\\.[0-9]+)?$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is numeric — value '%s' should be an unquoted number (e.g. 18 or 3.5)", + field, + value + ) + ) + } + + } else if (val_type %in% date_validations) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a date — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl( + "^'[0-9]{4}-[0-9]{2}-[0-9]{2}(\\s[0-9]{2}:[0-9]{2}(:[0-9]{2})?)?'$", + value + )) { + errors <- c( + errors, + sprintf( + "[%s] is a date — value '%s' should be a quoted date string, e.g. '2020-01-31'", + field, + value + ) + ) + } + + } else if (val_type %in% time_validations) { + if (!operator %in% num_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a time — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(num_ops, collapse = ", ") + ) + ) + } + if (!grepl("^'[0-9]{2}:[0-9]{2}(:[0-9]{2})?'$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is a time — value '%s' should be a quoted time string, e.g. '14:30:00'", + field, + value + ) + ) + } + + } else if (field_type %in% categorical_types) { + if (!operator %in% cat_ops) { + errors <- c( + errors, + sprintf( + "[%s] is categorical — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(cat_ops, collapse = ", ") + ) + ) + } + + # Validate value is a known choice code + choices_raw <- if (has_choices) + dictionary[[col_choices]][row_i] + else + NA + if (!is.na(choices_raw) && nchar(trimws(choices_raw)) > 0) { + choice_codes <- trimws(gsub(",.+?(\\||$)", "", gsub( + "^\\s*", "", strsplit(choices_raw, "\\|")[[1]] + ))) + value_unquoted <- gsub("^'|'$", "", value) + if (!value_unquoted %in% choice_codes) { + errors <- c( + errors, + sprintf( + "[%s] is categorical — '%s' is not a valid choice code. Valid codes: %s", + field, + value_unquoted, + paste(choice_codes, collapse = ", ") + ) + ) + } + } + + if (!grepl("^'.*'$", value)) { + errors <- c(errors, + sprintf( + "[%s] is categorical — value should be quoted, e.g. '1'", + field + )) + } + + } else { + # Plain text field + if (!operator %in% text_ops) { + errors <- c( + errors, + sprintf( + "[%s] is a text field — operator '%s' is not valid. Use one of: %s", + field, + operator, + paste(text_ops, collapse = ", ") + ) + ) + } + if (!grepl("^'.*'$", value)) { + errors <- c( + errors, + sprintf( + "[%s] is a text field — value should be quoted, e.g. 'some text'", + field + ) + ) + } + } + } + + if (length(errors) > 0) { + return(list( + valid = FALSE, + message = paste(errors, collapse = "\n") + )) + } + + list(valid = TRUE, message = "Filter is valid.") +} + + + #' Test app for the redcap_read_shiny_module #' #' @rdname redcap_read_shiny_module @@ -8646,16 +9188,10 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable( - { - shiny::req(data_val$data) - data_val$data() - }, - options = list( - scrollX = TRUE, - pageLength = 5 - ), - ) + output$data <- DT::renderDataTable({ + shiny::req(data_val$data) + data_val$data() + }, options = list(scrollX = TRUE, pageLength = 5), ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code() @@ -10054,7 +10590,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "error") } ) } @@ -10119,7 +10655,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "error") } ) } @@ -10197,7 +10733,7 @@ regression_server <- function(id, gg_theme_shiny() }, error = function(err) { - showNotification(paste0(err), type = "err") + showNotification(paste0(err), type = "error") } ) }) @@ -10257,7 +10793,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "error") } ) } @@ -10328,7 +10864,7 @@ regression_server <- function(id, out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) }, error = function(err) { - showNotification(err, type = "err") + showNotification(err, type = "error") } ) @@ -11998,15 +12534,26 @@ update_factor_ui <- function(id) { ), fluidRow( column( - width = 6, + width = 3, shinyWidgets::virtualSelectInput( inputId = ns("variable"), - label = i18n$t("Factor variable to reorder:"), + label = i18n$t("Choose variable:"), choices = NULL, width = "100%", zIndex = 50 ) ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + disabled = TRUE, + inputId = ns("drop_levels"), + label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ), column( width = 3, class = "d-flex align-items-end", @@ -12039,7 +12586,9 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), + label = i18n$t( + "Create a new variable; otherwise replaces (Updating labels always creates new variable)" + ), value = FALSE, status = "primary", outline = TRUE, @@ -12094,6 +12643,20 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- grid }) + observeEvent(rv$data_grid, { + variable <- req(input$variable) + if (isTRUE(has_empty_levels(rv$data[[variable]]))) { + # browser() + updateActionButton(inputId = "drop_levels", disabled = FALSE) + } else { + updateActionButton(inputId = "drop_levels", disabled = TRUE) + } + }) + + observeEvent(input$drop_levels, { + rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,] + }) + observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -12177,7 +12740,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { ) data <- tryCatch({ - with_labels(data,{ + with_labels(data, { rlang::exec(factor_new_levels_labels, !!!modifyList(parameters, val = list(data = data))) }) @@ -12187,7 +12750,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { "We encountered the following error creating the new factor:", err ), - type = "err") + type = "error") }) # browser() @@ -12341,6 +12904,15 @@ unique_names <- function(new, existing = character()) { } +has_empty_levels <- function(x) { + if (is.factor(x)) { + any(!levels(x) %in% x) + } else { + return(FALSE) + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R ######## @@ -14871,7 +15443,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "err") + ), type = "error") }) }) @@ -15128,6 +15700,7 @@ server <- function(input, output, session) { inputId = "column_filter", label = i18n$t("Select data types to include"), selected = unique(data_type(rv$data)), + #[unique(data_type(rv$data))!="text"], choices = unique(data_type(rv$data)), updateOn = "change", multiple = TRUE, @@ -15220,48 +15793,58 @@ server <- function(input, output, session) { ######### Data filter # IDEAFilter has the least cluttered UI, but might have a License issue # Consider using shinyDataFilter, though not on CRAN - data_filter <- IDEAFilter::IDEAFilter( + data_filter_raw <- IDEAFilter::IDEAFilter( "data_filter", - data = shiny::reactive(rv$data_variables), + data = shiny::reactive(non_character_cols(rv$data_variables)), verbose = TRUE ) - shiny::observeEvent(list( - shiny::reactive(rv$data_variables), - shiny::reactive(rv$data_original), - data_filter(), - # regression_vars(), - input$complete_cutoff - ), - { - ### Save filtered data - rv$data_filtered <- data_filter() - - ### Save filtered data - ### without empty factor levels - rv$list$data <- data_filter() |> - REDCapCAST::fct_drop() |> - (\(.x) { - .x[!sapply(.x, is.character)] - })() - - ## This looks messy!! But it works as intended for now - - out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( - attr(rv$data_filtered, "code") - ), collapse = " "))) - - out <- strsplit(out, "%>%") |> - unlist() |> - (\(.x) { - paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"), collapse = "|> \n ") - })() - - rv$code <- append_list(data = out, - list = rv$code, - index = "filter") + data_filter <- reactive({ + apply_idea_filter(data_filter_raw, rv$data_variables) }) + shiny::observeEvent( + list( + shiny::reactive(rv$data_variables), + shiny::reactive(rv$data_original), + data_filter_raw(), + # regression_vars(), + input$complete_cutoff + ), + { + ### Save filtered data + # browser() + # rv$data_filtered <- apply_idea_filter(data_filter_raw, rv$data_variables)() + rv$data_filtered <- data_filter() + + ### Save filtered data + ### ~~without empty factor levels~~ + ### All factor levels are kept, but can be manually removed + # browser() + rv$list$data <- rv$data_filtered #|> + # # REDCapCAST::fct_drop() |> + # (\(.x) { + # .x[!sapply(.x, is.character)] + # })() + + ## This looks messy!! But it works as intended for now + # browser() + out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( + attr(data_filter_raw(), "code") + ), collapse = " "))) + + out <- strsplit(out, "%>%") |> + unlist() |> + (\(.x) { + paste(c("df <- df", .x[-1]), collapse = "|> \n ") + })() + + rv$code <- append_list(data = out, + list = rv$code, + index = "filter") + } + ) + ######### Data preview ### Overview @@ -15279,7 +15862,7 @@ server <- function(input, output, session) { observeEvent(input$modal_browse, { tryCatch({ show_data( - REDCapCAST::fct_drop(rv$data_filtered), + rv$data_filtered, title = i18n$t("Uploaded data overview"), type = "modal" ) @@ -15287,7 +15870,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error browsing your data:"), err - ), type = "err") + ), type = "error") }) }) @@ -15313,7 +15896,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "err") + ), type = "error") }) }) @@ -15520,7 +16103,7 @@ server <- function(input, output, session) { # } # }, # error = function(err) { - # showNotification(err, type = "err") + # showNotification(err, type = "error") # } # ) @@ -15679,7 +16262,7 @@ server <- function(input, output, session) { "We encountered the following error creating your report: " ), err - ), type = "err") + ), type = "error") }) }) file.rename(paste0("www/report.", type), file) From 7b0692fd1764b9adbd552ca4cade7d21e92233b9 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 31 Mar 2026 20:41:09 +0200 Subject: [PATCH 38/62] 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 39/62] 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 40/62] 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 41/62] 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 42/62] 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 43/62] 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 From 451f5bf9a89bb5bf41ce7eea7acf236970d9c828 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 1 Apr 2026 23:41:23 +0200 Subject: [PATCH 44/62] fix: streamlined icons to use only phosphoricons --- R/data-summary.R | 48 +++++++++++++++++--------- R/data_plots.R | 12 ++++--- R/landing_page_ui.R | 29 +++++----------- R/missings-module.R | 9 +++-- R/plot-download-module.R | 3 +- R/redcap_read_shiny_module.R | 9 +++-- R/regression-module.R | 15 +++++--- R/table-download-module.R | 3 +- R/ui_elements.R | 66 ++++++++++++++++++++++-------------- R/update-factor-ext.R | 2 +- 10 files changed, 117 insertions(+), 79 deletions(-) diff --git a/R/data-summary.R b/R/data-summary.R index 62f5e0bf..27c11b3e 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -309,21 +309,29 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "factor")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - shiny::icon("clock") + phosphoricons::ph("clock") + # shiny::icon("clock") } else { - shiny::icon("table") + phosphoricons::ph("calendar") + # shiny::icon("table") }} } @@ -342,21 +350,29 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "categorical")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (identical(x,"id")) { - shiny::icon("id-card") + phosphoricons::ph("identification-badge") + # shiny::icon("id-card") } else { - shiny::icon("table") + phosphoricons::ph("table") + # shiny::icon("table") } } } diff --git a/R/data_plots.R b/R/data_plots.R index 439b0ccf..bc1995e6 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -20,7 +20,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_plot", title = "Create plot", - icon = bsicons::bs_icon("graph-up"), + icon = phosphoricons::ph("chart-line"), + # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -37,7 +38,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = shiny::icon("palette"), + icon = phosphoricons::ph("paint-brush"), + # icon = shiny::icon("palette"), disabled = FALSE ), shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) @@ -45,7 +47,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = bsicons::bs_icon("download"), + icon = phosphoricons::ph("download-simple"), + # icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -84,7 +87,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), diff --git a/R/landing_page_ui.R b/R/landing_page_ui.R index 1123640e..8301309a 100644 --- a/R/landing_page_ui.R +++ b/R/landing_page_ui.R @@ -37,20 +37,6 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", - # Introduction text - # div( - # class = "row mb-5", - # div( - # class = "col-12 text-center", - # p( - # class = "lead", - # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), - # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), - # style = "font-size: 1.2rem; color: #555;" - # ) - # ) - # ), - # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -68,7 +54,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("file-import") + phosphoricons::ph("folder-simple-plus", weight = "bold") + # fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -89,7 +76,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("pen-to-square") + phosphoricons::ph("note-pencil", weight = "bold") + # fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -110,7 +98,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("magnifying-glass-chart") + phosphoricons::ph("magnifying-glass", weight = "bold") + # fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -135,7 +124,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -147,7 +136,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -164,7 +153,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( diff --git a/R/missings-module.R b/R/missings-module.R index 003a35f4..bb247b18 100644 --- a/R/missings-module.R +++ b/R/missings-module.R @@ -19,7 +19,8 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = bsicons::bs_icon("gear"), + icon = phosphoricons::ph("gear"), + # icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -36,14 +37,16 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = phosphoricons::ph("download-simple") + # icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) diff --git a/R/plot-download-module.R b/R/plot-download-module.R index 4caf94bf..ac1d58a5 100644 --- a/R/plot-download-module.R +++ b/R/plot-download-module.R @@ -39,7 +39,8 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) } diff --git a/R/redcap_read_shiny_module.R b/R/redcap_read_shiny_module.R index 810cab0c..bb704325 100644 --- a/R/redcap_read_shiny_module.R +++ b/R/redcap_read_shiny_module.R @@ -43,7 +43,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = shiny::icon("link", lib = "glyphicon"), + icon = phosphoricons::ph("link",weight = "bold"), + # icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -99,7 +100,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = shiny::icon("filter"), + label = phosphoricons::ph("funnel",weight = "bold"), + # label = shiny::icon("filter"), width = "50px" ), filter_ui @@ -118,7 +120,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = shiny::icon("download", lib = "glyphicon"), + icon = phosphoricons::ph("download-simple",weight = "bold"), + # icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), diff --git a/R/regression-module.R b/R/regression-module.R index d569bd54..c8a0f20d 100644 --- a/R/regression-module.R +++ b/R/regression-module.R @@ -57,7 +57,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = bsicons::bs_icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -91,7 +92,8 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = bsicons::bs_icon("pencil"), + icon = phosphoricons::ph("math-operations"), + # icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -136,7 +138,8 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = bsicons::bs_icon("bar-chart-steps"), + icon = phosphoricons::ph("chart-bar-horizontal"), + # icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -179,7 +182,8 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ) @@ -200,7 +204,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = bsicons::bs_icon("clipboard-check"), + icon = phosphoricons::ph("checks"), + # icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) diff --git a/R/table-download-module.R b/R/table-download-module.R index baa566fa..aebbb98d 100644 --- a/R/table-download-module.R +++ b/R/table-download-module.R @@ -37,7 +37,8 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) } else { # Return NULL to show nothing diff --git a/R/ui_elements.R b/R/ui_elements.R index 96175376..2cd23878 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -15,7 +15,8 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = shiny::icon("house"), + icon = phosphoricons::ph("house", weight = "bold"), + # icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -45,7 +46,8 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = shiny::icon("play"), + icon = phosphoricons::ph("play", weight = "bold"), + # icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -122,7 +124,8 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = shiny::icon("binoculars"), + icon = phosphoricons::ph("binoculars"), + # icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -166,7 +169,8 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = shiny::icon("play"), + icon = phosphoricons::ph("play"), + # icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -185,11 +189,13 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = shiny::icon("pen-to-square"), + icon = phosphoricons::ph("note-pencil", weight = "bold"), + # icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = shiny::icon("eye"), + icon = phosphoricons::ph("eye"), + # icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -264,7 +270,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = shiny::icon("file-pen"), + icon = phosphoricons::ph("pencil-line"), + # icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -293,13 +300,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor levels"), + label = i18n$t("Modify factor"), width = "100%" ), shiny::tags$br(), - shiny::helpText( - i18n$t("Reorder or rename the levels of factor/categorical variables.") - ), + shiny::helpText(i18n$t( + "Modify the levels of factor/categorical variables." + )), shiny::tags$br(), shiny::tags$br() ), @@ -312,9 +319,7 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t( - "Create factor/categorical variable from a continous variable (number/date/time)." - ) + i18n$t("Create factor/categorical variable from other variables.") ), shiny::tags$br(), shiny::tags$br() @@ -391,14 +396,16 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = shiny::icon("magnifying-glass-chart"), + icon = phosphoricons::ph("magnifying-glass", weight = "bold"), + # icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -410,7 +417,8 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -452,7 +460,8 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -466,7 +475,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = bsicons::bs_icon("bounding-box"), + icon = phosphoricons::ph("graph"), + # icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -507,7 +517,8 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = bsicons::bs_icon("x-circle") + icon = phosphoricons::ph("placeholder") + # icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -522,7 +533,8 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = shiny::icon("chart-line"), + icon = phosphoricons::ph("chart-line", weight = "bold"), + # icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -543,7 +555,8 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator", weight = "bold"), + # icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -555,7 +568,8 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = shiny::icon("download"), + icon = phosphoricons::ph("download-simple", weight = "bold"), + # icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -591,7 +605,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -621,7 +636,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index 7f3380cd..e8699886 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -44,7 +44,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) From 0d9ad7457edc8d2baa37ef8c153d7863d1203aaf Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 1 Apr 2026 23:42:39 +0200 Subject: [PATCH 45/62] version 26.4.1 incomming --- CITATION.cff | 2 +- DESCRIPTION | 2 +- NEWS.md | 4 ++++ R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/sysdata.rda | Bin 2770 -> 2692 bytes SESSION.md | 16 ++++------------ inst/translations/translation_da.csv | 5 ++--- inst/translations/translation_sw.csv | 5 ++--- 9 files changed, 16 insertions(+), 22 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index ae7ae538..8629fb7c 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.6 +version: 26.4.1 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index 23174866..89673630 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.3.6 +Version: 26.4.1 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 04fa782b..fbff9355 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.4.1 + +Minor adjustments and bug fixes including streamlining icon use to only use phosphoricons across the app. + # FreesearchR 26.3.6 *FIX* Plot single variable in Likert plot. diff --git a/R/app_version.R b/R/app_version.R index ac06a8a2..4f474ec7 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.3.6' +app_version <- function()'26.4.1' diff --git a/R/hosted_version.R b/R/hosted_version.R index f7e99a89..608d59ed 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.3.6-260331' +hosted_version <- function()'v26.4.1-260401' diff --git a/R/sysdata.rda b/R/sysdata.rda index be267dbfe3b40f25930e615ab562574760211f60..443516d108cdaf03bb65689d76c67b6317ae4443 100644 GIT binary patch literal 2692 zcmV-~3VZcJT4*^jL0KkKSq7!m(Eu5Z|HS|QXaz!l|KNXb-@w2B|L{Nn01yZP;0ym3 z5R16*JQYPufg*wP=g^uF-|L?!`WIhtZUs?Tjhs|HgO-idD(iMN4 z?UcgV=7rVrJBs22R4UXY2`PBk;+S5W$(usG&s4$8Cs& z`%8AFwJ|SZmhMeCsftRd%_X$K7f{%U-;w6>b2!gdM>p~F|B%(gILMbA&tl(gmfVYZ zj0s$*F@8bMa7ex-0OzQ#x+`z{`0I_kWAImrJ+OTlVTF1SOM{Z* zHw>`sS902A*QOsX3Z{w(u&RwGa>5WI06@VJ3+4ex<>8`v8=`LmW+0+#ih?mv0D&PP zvq*?7tw4ey`-q_Ppoj(9(v4rj2s#^khIXQ=>Om0E*2k5xwWpVp*P|3c!e-|!Bp|9H zD5%AP#RWkTV1mUWim`}_q6)D^7=kJ&0?48uprWG@Sgcf2!RdB5=TCa7UTNl|BJ#D8 zW1DhwTg|>2H!1?o7L`#GhSxQmF9x}>He%ApYcCw%d0ZX$F7)8kU9_`K>t)u;36mFB z4PG=5snmmJVdO*>0H#_C9;Cq-Mw!rN#MremK^RdWoHtZum?04vkqrSP5&&#EQ?&VCA zN>r<`O(88JA`(TQid&@QS(}sy5vhR)h#-=IL^X4E9?G*SF%&MOl0=Mz3uaQf*C!=6 z+@-s^u3^5n%a9(4r39EH*%M9-CC(gUm#5>7Z!CKrzpKkfzpYNH9VSYWa1O_2!py|a^3{^C*9y~6E z(K!$rjI|FY`(bFwmA4F{Ikhonib1thF)L82$x#EK9SFjjX0V2*bRd*mLZdoy~VBS*Fl~Oc| zR1^Z4l!Yj@*nK^=Bv?nD!rKF;&K1Q;f$*5s3YniSaEF;S8zmZ~6?Bc+0a98(~OF}5mi-NR!HaYD%}&);I$RIQ~|Wsn64 zSV*B6FbN6AR!t{&(bgJ#bmE%V7K>G-t4kRPDM7%+VxkX)@bd8AerDj(rQmU;tx}CD z(%LJG61@g;%S~@*NiPFjEvmG*AvH9Kt1Ei9ZEI_5Qj2V&EuxW0J6l6%zCRvV5GQ#3 zd)s=w{qv6AKoAAYFtUJFYrfYH!oblg*~(|sO3F|kd|C{QOxj4cK!6|#BMnDJYLh}2 z-?|_O0#!I<0RT$yN#kP@uHh7uqX)pMafZje%=-HMzTeDo@Eg||m%&Q3yc3Vae-55@&P*2iZ@k~>qhfN; zg6=d#<0w?`7jK+i$)h$27OO1&IX5y5DTJ%YtXLd}W!BaY&M!(t-Bltt3$;e$;o(~_ zEusA&o;#lASnU{^l+y1QUkhl*1Z=|z7fNx=p{Q~gGM(*2GjtFuNav~0gN{$0l56M; zGaJlwwjF&>{GtNb-mR6+ieR})BaOqjeo{-aCzW%=5OGubRFy*i&PcN|?Y4&mld!N@ zc3|;rA=maDl6=n`rb-2osI;CNHP?FRUZ2BS+zz6J!WI z)rbd^pB~hMa5$8+YUyz>%XlOmXK^J87<%&Av@&uSXBsZ?IaA0OA(>jM7iU@!%eyLt z0q(~AG=)uv_#w~4+$FgSg99Yizf7o_Eyn3P@W%G4H1 zbi_h5gseL!S(SD*dBlBs5uc>5QZTApE5X!6xJGK#5yg zdgqo#-xd4HOdNp?NTT(VI|+sfW=2%OQ1Xz2ITMrAl-Ja~zpr)zKwGf%FF9K?^7>&G z=0J;E(K5eq_88m1r2;_r<$u*4TLjva#LrbpN1*2~2*~QRQ``79+#hw@N4A=sL3ZK0 zI}ir%;b@xj9KL%Wyt_)x_NIGW!NFDVP*oh(IX7;HAXM*g-K5?G@WnRco>cP_y~3S4 zKAId^w6z&f8|&+HZHWsEc?$2u#I4xR8b=)Bx6!LgY2I}qsW9@DYzWg~4GNNki1F8o zF0NQjR9A#(C3?apIjFtLCB*0=X-aKUjx(h&B^qkg`+Igi?YZrFZQE^ZklSSl>kTuy z7&geTTu3NWWB6eL1kn5I2{>zIlk8dXrgc=RU6FG-Yz>nV0)WsxF4~gV(L$7D;{e{V z3fi{G$-%WbZ3_2T<=wjbs6%pI&NZ_W)|-2)nyboJE)_BP&SXM0Ir$_VV)~lQZ*3j? zr|)Ir<`6Sn__T8u)6*X|d;GIfLbXk_(Wu$C8Z_+oMZQSkJ;j+ys$Py}ubP^&6WmR; yG;RZkwy8lYGJ&rXD|=Sga&`e){qN 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?CJHm Date: Thu, 2 Apr 2026 10:10:40 +0200 Subject: [PATCH 46/62] v26.4.1 ready --- R/hosted_version.R | 2 +- app_docker/app.R | 202 ++++++++++++--------- app_docker/translations/translation_da.csv | 5 +- app_docker/translations/translation_sw.csv | 5 +- inst/apps/FreesearchR/app.R | 202 ++++++++++++--------- 5 files changed, 245 insertions(+), 171 deletions(-) diff --git a/R/hosted_version.R b/R/hosted_version.R index 608d59ed..6e001f53 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.1-260401' +hosted_version <- function()'v26.4.1-260402' diff --git a/app_docker/app.R b/app_docker/app.R index a2b1dc19..fe1bceb3 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpRQAQCo/file4ab639355bd6.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmlTuE8/file8be05102425f.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.6' +app_version <- function()'26.4.1' ######## @@ -2157,7 +2157,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_plot", title = "Create plot", - icon = bsicons::bs_icon("graph-up"), + icon = phosphoricons::ph("chart-line"), + # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -2174,7 +2175,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = shiny::icon("palette"), + icon = phosphoricons::ph("paint-brush"), + # icon = shiny::icon("palette"), disabled = FALSE ), shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) @@ -2182,7 +2184,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = bsicons::bs_icon("download"), + icon = phosphoricons::ph("download-simple"), + # icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -2221,7 +2224,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -3280,21 +3284,29 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "factor")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - shiny::icon("clock") + phosphoricons::ph("clock") + # shiny::icon("clock") } else { - shiny::icon("table") + phosphoricons::ph("calendar") + # shiny::icon("table") }} } @@ -3313,21 +3325,29 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "categorical")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (identical(x,"id")) { - shiny::icon("id-card") + phosphoricons::ph("identification-badge") + # shiny::icon("id-card") } else { - shiny::icon("table") + phosphoricons::ph("table") + # shiny::icon("table") } } } @@ -4925,7 +4945,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.6-260331' +hosted_version <- function()'v26.4.1-260402' ######## @@ -6137,20 +6157,6 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", - # Introduction text - # div( - # class = "row mb-5", - # div( - # class = "col-12 text-center", - # p( - # class = "lead", - # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), - # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), - # style = "font-size: 1.2rem; color: #555;" - # ) - # ) - # ), - # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -6168,7 +6174,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("file-import") + phosphoricons::ph("folder-simple-plus", weight = "bold") + # fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6189,7 +6196,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("pen-to-square") + phosphoricons::ph("note-pencil", weight = "bold") + # fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6210,7 +6218,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("magnifying-glass-chart") + phosphoricons::ph("magnifying-glass", weight = "bold") + # fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6235,7 +6244,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -6247,7 +6256,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -6264,7 +6273,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( @@ -6554,7 +6563,8 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = bsicons::bs_icon("gear"), + icon = phosphoricons::ph("gear"), + # icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -6571,14 +6581,16 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = phosphoricons::ph("download-simple") + # icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -7933,7 +7945,8 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) } @@ -8071,7 +8084,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = shiny::icon("link", lib = "glyphicon"), + icon = phosphoricons::ph("link",weight = "bold"), + # icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8127,7 +8141,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = shiny::icon("filter"), + label = phosphoricons::ph("funnel",weight = "bold"), + # label = shiny::icon("filter"), width = "50px" ), filter_ui @@ -8146,7 +8161,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = shiny::icon("download", lib = "glyphicon"), + icon = phosphoricons::ph("download-simple",weight = "bold"), + # icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -10141,7 +10157,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = bsicons::bs_icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -10175,7 +10192,8 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = bsicons::bs_icon("pencil"), + icon = phosphoricons::ph("math-operations"), + # icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -10220,7 +10238,8 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = bsicons::bs_icon("bar-chart-steps"), + icon = phosphoricons::ph("chart-bar-horizontal"), + # icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -10263,7 +10282,8 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ) @@ -10284,7 +10304,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = bsicons::bs_icon("clipboard-check"), + icon = phosphoricons::ph("checks"), + # icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -11428,7 +11449,8 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) } else { # Return NULL to show nothing @@ -11719,7 +11741,8 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = shiny::icon("house"), + icon = phosphoricons::ph("house", weight = "bold"), + # icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -11749,7 +11772,8 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = shiny::icon("play"), + icon = phosphoricons::ph("play", weight = "bold"), + # icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -11826,7 +11850,8 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = shiny::icon("binoculars"), + icon = phosphoricons::ph("binoculars"), + # icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -11870,7 +11895,8 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = shiny::icon("play"), + icon = phosphoricons::ph("play"), + # icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -11889,11 +11915,13 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = shiny::icon("pen-to-square"), + icon = phosphoricons::ph("note-pencil", weight = "bold"), + # icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = shiny::icon("eye"), + icon = phosphoricons::ph("eye"), + # icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -11968,7 +11996,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = shiny::icon("file-pen"), + icon = phosphoricons::ph("pencil-line"), + # icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -11997,13 +12026,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor levels"), + label = i18n$t("Modify factor"), width = "100%" ), shiny::tags$br(), - shiny::helpText( - i18n$t("Reorder or rename the levels of factor/categorical variables.") - ), + shiny::helpText(i18n$t( + "Modify the levels of factor/categorical variables." + )), shiny::tags$br(), shiny::tags$br() ), @@ -12016,9 +12045,7 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t( - "Create factor/categorical variable from a continous variable (number/date/time)." - ) + i18n$t("Create factor/categorical variable from other variables.") ), shiny::tags$br(), shiny::tags$br() @@ -12095,14 +12122,16 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = shiny::icon("magnifying-glass-chart"), + icon = phosphoricons::ph("magnifying-glass", weight = "bold"), + # icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12114,7 +12143,8 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -12156,7 +12186,8 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -12170,7 +12201,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = bsicons::bs_icon("bounding-box"), + icon = phosphoricons::ph("graph"), + # icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12211,7 +12243,8 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = bsicons::bs_icon("x-circle") + icon = phosphoricons::ph("placeholder") + # icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -12226,7 +12259,8 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = shiny::icon("chart-line"), + icon = phosphoricons::ph("chart-line", weight = "bold"), + # icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -12247,7 +12281,8 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator", weight = "bold"), + # icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -12259,7 +12294,8 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = shiny::icon("download"), + icon = phosphoricons::ph("download-simple", weight = "bold"), + # icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -12295,7 +12331,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -12325,7 +12362,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -12459,7 +12497,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 4f3752bd..2240bc2c 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -260,7 +260,6 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR er tilgængelig på flere sprog. For at få hjælp med oversættelser, kontakt os venligst på info@freesearchr.org" "Home","Hjem" "Start with FreesearchR for basic data evaluation and analysis.","Start med FreesearchR til grundlæggende dataevaluering og -analyse." -"When you need more advanced tools, you'll be better prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være bedre forberedt på at bruge R direkte." "(Read more)","(Læs mere)" "Run the FreesearchR app locally when working with sensitive data.","Kør FreesearchR-appen lokalt, når du arbejder med følsomme data." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Indlæs data fra regneark, REDCap-servere, eller prøv med eksempeldata. Flere kilder understøttes for maksimal fleksibilitet." @@ -271,8 +270,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være forberedt på at bruge R direkte." "The app contains a selelct number of features and will guide you through key analyses.","Appen indeholder udvalgte funktioner, og guider dig gennem de vigtigste analyser." "Sort by Levels","Sorter efter niveauer" -"Modify factor levels","Ændr kategoriske niveauer" -"Reorder or rename the levels of factor/categorical variables.","Ændr navn eller rækkefølge på kategorisk variabel." "Maximum number of observations:","Maximale antal observationer:" "setting to 0 includes all","angiv 0 for at inkludere alle" "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." @@ -321,3 +318,5 @@ "An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." "An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." "Likert diagram","Likert diagram" +"Modify factor","Modify factor" +"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index a375e0a5..7866710e 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -260,7 +260,6 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR inapatikana katika lugha nyingi. Ili kukusaidia na tafsiri, tafadhali wasiliana nasi kwa info@freesearchr.org." "Home","Nyumbani" "Start with FreesearchR for basic data evaluation and analysis.","Anza na FreesearchR kwa tathmini na uchambuzi wa data ya msingi." -"When you need more advanced tools, you'll be better prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari zaidi kutumia R moja kwa moja." "(Read more)","(Soma zaidi)" "Run the FreesearchR app locally when working with sensitive data.","Endesha programu ya FreesearchR ndani ya eneo lako unapofanya kazi na data nyeti." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Pakia data kutoka kwa lahajedwali, seva za REDCap, au jaribu na data ya sampuli. Vyanzo vingi vinaungwa mkono kwa unyumbufu wa hali ya juu." @@ -271,8 +270,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari kutumia R moja kwa moja." "The app contains a selelct number of features and will guide you through key analyses.","The app contains a selelct number of features and will guide you through key analyses." "Sort by Levels","Sort by Levels" -"Modify factor levels","Modify factor levels" -"Reorder or rename the levels of factor/categorical variables.","Reorder or rename the levels of factor/categorical variables." "Maximum number of observations:","Maximum number of observations:" "setting to 0 includes all","setting to 0 includes all" "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." @@ -321,3 +318,5 @@ "An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." "An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." "Likert diagram","Likert diagram" +"Modify factor","Modify factor" +"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index e64d7b30..66df2775 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//RtmpRQAQCo/file4ab61747a8d7.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmlTuE8/file8be0207bfdc2.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.6' +app_version <- function()'26.4.1' ######## @@ -2157,7 +2157,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_plot", title = "Create plot", - icon = bsicons::bs_icon("graph-up"), + icon = phosphoricons::ph("chart-line"), + # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -2174,7 +2175,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = shiny::icon("palette"), + icon = phosphoricons::ph("paint-brush"), + # icon = shiny::icon("palette"), disabled = FALSE ), shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) @@ -2182,7 +2184,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = bsicons::bs_icon("download"), + icon = phosphoricons::ph("download-simple"), + # icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -2221,7 +2224,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -3280,21 +3284,29 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "factor")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - shiny::icon("clock") + phosphoricons::ph("clock") + # shiny::icon("clock") } else { - shiny::icon("table") + phosphoricons::ph("calendar") + # shiny::icon("table") }} } @@ -3313,21 +3325,29 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "categorical")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (identical(x,"id")) { - shiny::icon("id-card") + phosphoricons::ph("identification-badge") + # shiny::icon("id-card") } else { - shiny::icon("table") + phosphoricons::ph("table") + # shiny::icon("table") } } } @@ -4925,7 +4945,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.6-260331' +hosted_version <- function()'v26.4.1-260402' ######## @@ -6137,20 +6157,6 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", - # Introduction text - # div( - # class = "row mb-5", - # div( - # class = "col-12 text-center", - # p( - # class = "lead", - # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), - # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), - # style = "font-size: 1.2rem; color: #555;" - # ) - # ) - # ), - # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -6168,7 +6174,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("file-import") + phosphoricons::ph("folder-simple-plus", weight = "bold") + # fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6189,7 +6196,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("pen-to-square") + phosphoricons::ph("note-pencil", weight = "bold") + # fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6210,7 +6218,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("magnifying-glass-chart") + phosphoricons::ph("magnifying-glass", weight = "bold") + # fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6235,7 +6244,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -6247,7 +6256,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -6264,7 +6273,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( @@ -6554,7 +6563,8 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = bsicons::bs_icon("gear"), + icon = phosphoricons::ph("gear"), + # icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -6571,14 +6581,16 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = phosphoricons::ph("download-simple") + # icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -7933,7 +7945,8 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) } @@ -8071,7 +8084,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = shiny::icon("link", lib = "glyphicon"), + icon = phosphoricons::ph("link",weight = "bold"), + # icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8127,7 +8141,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = shiny::icon("filter"), + label = phosphoricons::ph("funnel",weight = "bold"), + # label = shiny::icon("filter"), width = "50px" ), filter_ui @@ -8146,7 +8161,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = shiny::icon("download", lib = "glyphicon"), + icon = phosphoricons::ph("download-simple",weight = "bold"), + # icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -10141,7 +10157,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = bsicons::bs_icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -10175,7 +10192,8 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = bsicons::bs_icon("pencil"), + icon = phosphoricons::ph("math-operations"), + # icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -10220,7 +10238,8 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = bsicons::bs_icon("bar-chart-steps"), + icon = phosphoricons::ph("chart-bar-horizontal"), + # icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -10263,7 +10282,8 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ) @@ -10284,7 +10304,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = bsicons::bs_icon("clipboard-check"), + icon = phosphoricons::ph("checks"), + # icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -11428,7 +11449,8 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) } else { # Return NULL to show nothing @@ -11719,7 +11741,8 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = shiny::icon("house"), + icon = phosphoricons::ph("house", weight = "bold"), + # icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -11749,7 +11772,8 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = shiny::icon("play"), + icon = phosphoricons::ph("play", weight = "bold"), + # icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -11826,7 +11850,8 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = shiny::icon("binoculars"), + icon = phosphoricons::ph("binoculars"), + # icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -11870,7 +11895,8 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = shiny::icon("play"), + icon = phosphoricons::ph("play"), + # icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -11889,11 +11915,13 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = shiny::icon("pen-to-square"), + icon = phosphoricons::ph("note-pencil", weight = "bold"), + # icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = shiny::icon("eye"), + icon = phosphoricons::ph("eye"), + # icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -11968,7 +11996,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = shiny::icon("file-pen"), + icon = phosphoricons::ph("pencil-line"), + # icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -11997,13 +12026,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor levels"), + label = i18n$t("Modify factor"), width = "100%" ), shiny::tags$br(), - shiny::helpText( - i18n$t("Reorder or rename the levels of factor/categorical variables.") - ), + shiny::helpText(i18n$t( + "Modify the levels of factor/categorical variables." + )), shiny::tags$br(), shiny::tags$br() ), @@ -12016,9 +12045,7 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t( - "Create factor/categorical variable from a continous variable (number/date/time)." - ) + i18n$t("Create factor/categorical variable from other variables.") ), shiny::tags$br(), shiny::tags$br() @@ -12095,14 +12122,16 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = shiny::icon("magnifying-glass-chart"), + icon = phosphoricons::ph("magnifying-glass", weight = "bold"), + # icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12114,7 +12143,8 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -12156,7 +12186,8 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -12170,7 +12201,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = bsicons::bs_icon("bounding-box"), + icon = phosphoricons::ph("graph"), + # icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12211,7 +12243,8 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = bsicons::bs_icon("x-circle") + icon = phosphoricons::ph("placeholder") + # icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -12226,7 +12259,8 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = shiny::icon("chart-line"), + icon = phosphoricons::ph("chart-line", weight = "bold"), + # icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -12247,7 +12281,8 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator", weight = "bold"), + # icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -12259,7 +12294,8 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = shiny::icon("download"), + icon = phosphoricons::ph("download-simple", weight = "bold"), + # icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -12295,7 +12331,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -12325,7 +12362,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -12459,7 +12497,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) From 1e19486af1392eb35d57ff1705babb6336659d81 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:03:47 +0200 Subject: [PATCH 47/62] feat: revised color palette selection --- R/generate_colors.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/generate_colors.R b/R/generate_colors.R index 898c0a94..d7a7cc82 100644 --- a/R/generate_colors.R +++ b/R/generate_colors.R @@ -254,12 +254,12 @@ color_choices <- function() { "Perceptual (blue-yellow)" = "viridis", "Perceptual (fire)" = "plasma", "Colour-blind friendly" = "Okabe-Ito", - "Qualitative (bold)" = "Dark 2", - "Qualitative (paired)" = "Paired", - "Sequential (blues)" = "Blues", + "Diverging (red-yellow-green)"= "RdYlGn", "Diverging (red-blue)" = "RdBu", - "Tableau style" = "Tableau 10", - "Pastel" = "Pastel 1", - "Rainbow" = "rainbow" + "Sequential (blues)" = "Blues", + "Qualitative (paired)" = "Paired", + "Qualitative (bold)" = "Dark 2", + "Rainbow" = "Spectral", + "Generic" = "Set1" ) } From b2745f5628b182cbc0fc1a9d6eff802dc9d28475 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:04:20 +0200 Subject: [PATCH 48/62] feat: default to 5 preview colors --- R/data_plots.R | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index bc1995e6..a01403df 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -38,7 +38,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = phosphoricons::ph("paint-brush"), + icon = phosphoricons::ph("paint-brush",weight = "bold"), # icon = shiny::icon("palette"), disabled = FALSE ), @@ -243,7 +243,8 @@ data_visuals_server <- function(id, colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes + choices = palettes, + previews = 5 ) }) @@ -721,6 +722,7 @@ wrap_plot_list <- function(data, guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ...) { if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { @@ -734,7 +736,7 @@ wrap_plot_list <- function(data, .x } })() |> - align_axes() |> + align_axes(percentage=y.axis.percentage) |> patchwork::wrap_plots(guides = guides, axes = axes, axis_titles = axis_titles, @@ -779,7 +781,8 @@ wrap_plot_list <- function(data, #' align_axes <- function(..., x.axis = TRUE, - y.axis = TRUE) { + y.axis = TRUE, + percentage = FALSE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -797,7 +800,7 @@ align_axes <- function(..., xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x) { + p_out <- purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -808,6 +811,15 @@ align_axes <- function(..., out }) }) + + if(isTRUE(percentage)){ + lapply(p_out,\(.x){ + .x+ + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } } #' Extract and clean axis ranges From af4e21b836d2ab0f423877a47c76ab0d51a5f42d Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:04:42 +0200 Subject: [PATCH 49/62] revised ui --- CITATION.cff | 2 +- DESCRIPTION | 2 +- NAMESPACE | 1 + NEWS.md | 4 ++ R/app_version.R | 2 +- R/create-column-mod.R | 4 +- R/cut-variable-ext.R | 2 +- R/hosted_version.R | 2 +- R/import-file-ext.R | 4 +- R/missings-module.R | 2 +- R/plot_bar.R | 90 ++++++++++++++++----------- R/separate_string.R | 2 +- R/sysdata.rda | Bin 2692 -> 2691 bytes R/ui_elements.R | 6 +- R/update-factor-ext.R | 8 +-- R/update-variables-ext.R | 4 +- SESSION.md | 9 ++- inst/translations/translation_da.csv | 2 +- inst/translations/translation_sw.csv | 2 +- man/align_axes.Rd | 2 +- man/data-plots.Rd | 23 +++++++ man/wrap_plot_list.Rd | 1 + 22 files changed, 110 insertions(+), 64 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 8629fb7c..86c9ebe0 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.4.1 +version: 26.4.2 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index 89673630..69564bc2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.4.1 +Version: 26.4.2 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/NAMESPACE b/NAMESPACE index 9ede131b..9e036c3f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -116,6 +116,7 @@ export(modify_qmd) export(names2val) export(overview_vars) export(pipe_string) +export(plot_bar) export(plot_bar_single) export(plot_box) export(plot_box_single) diff --git a/NEWS.md b/NEWS.md index fbff9355..785ee46a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.4.2 + +Bug fixes and revised color choices. + # FreesearchR 26.4.1 Minor adjustments and bug fixes including streamlining icon use to only use phosphoricons across the app. diff --git a/R/app_version.R b/R/app_version.R index 4f474ec7..2cbd2cc4 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.4.1' +app_version <- function()'26.4.2' diff --git a/R/create-column-mod.R b/R/create-column-mod.R index c2b6d403..6047aa33 100644 --- a/R/create-column-mod.R +++ b/R/create-column-mod.R @@ -76,7 +76,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil"), i18n$t("Create column") + phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -84,7 +84,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle"), + phosphoricons::ph("x-circle",weight = "bold"), i18n$t("Cancel") ), class = "btn-outline-danger", diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index b7d8eb80..84418736 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -64,7 +64,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") diff --git a/R/hosted_version.R b/R/hosted_version.R index 6e001f53..33aaf67c 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.1-260402' +hosted_version <- function()'v26.4.2-260410' diff --git a/R/import-file-ext.R b/R/import-file-ext.R index 709a55c1..6d78e381 100644 --- a/R/import-file-ext.R +++ b/R/import-file-ext.R @@ -714,7 +714,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -725,7 +725,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), diff --git a/R/missings-module.R b/R/missings-module.R index bb247b18..eeb46edd 100644 --- a/R/missings-module.R +++ b/R/missings-module.R @@ -37,7 +37,7 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ) diff --git a/R/plot_bar.R b/R/plot_bar.R index f820cc6b..0535b6f3 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -1,5 +1,29 @@ -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), - color.palette = "viridis", max_level = 30, ...) { +#' Title +#' +#' @name data-plots +#' +#' @param style barplot style passed to geom_bar position argument. +#' One of c("stack", "dodge", "fill") +#' +#' @returns ggplot list object +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> +#' plot_bar(pri = "cyl", sec = "am", style = "fill") +#' +#' mtcars |> +#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> +#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") +plot_bar <- function(data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -8,7 +32,7 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ds <- list(data) } - out <- lapply(ds, \(.ds){ + out <- lapply(ds, \(.ds) { plot_bar_single( data = .ds, pri = pri, @@ -19,7 +43,10 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ) }) - wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), ...) + wrap_plot_list(out, + title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), + y.axis.percentage = TRUE, + ...) } @@ -41,7 +68,11 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, +plot_bar_single <- function(data, + pri, + sec = NULL, + style = c("stack", "dodge", "fill"), + max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -51,16 +82,11 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data) - ) + p = Freq / NROW(data)) if (nrow(p_data) > max_level) { - p_data <- sort_by( - p_data, - p_data[["Freq"]], - decreasing = TRUE - ) |> + p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> head(max_level) } @@ -73,39 +99,31 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " fill <- pri } - p <- ggplot2::ggplot( - p_data, - ggplot2::aes( - x = .data[[pri]], - y = p, - fill = .data[[fill]] - ) - ) + + p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + ggplot2::geom_bar(position = style, stat = "identity") + - ggplot2::scale_y_continuous(labels = scales::percent) + - scale_fill_generate(palette=color.palette) + - ggplot2::ylab("Percentage") + - ggplot2::xlab(get_label(data,pri))+ - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) + scale_fill_generate(palette = color.palette) + + ggplot2::xlab(get_label(data, pri)) + + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | + any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, hjust = 1 - ))+ - ggplot2::theme( - axis.text.x = ggplot2::element_text(vjust = 0.5) - ) + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, + hjust = 1 + )) + + ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) - if (is.null(sec)){ + if (is.null(sec)) { p <- p + ggplot2::guides(fill = "none") } } - p + p + + ggplot2::scale_y_continuous(labels = scales::percent) + + ggplot2::ylab("Percentage") } diff --git a/R/separate_string.R b/R/separate_string.R index 0aa64e6c..61063b53 100644 --- a/R/separate_string.R +++ b/R/separate_string.R @@ -50,7 +50,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") diff --git a/R/sysdata.rda b/R/sysdata.rda index 443516d108cdaf03bb65689d76c67b6317ae4443..c56ca282b6b07bc77e3fda961193f62c47cf5e58 100644 GIT binary patch literal 2691 zcmV-}3ViiKT4*^jL0KkKS*kVc=KvXSf5iX)cm+a#|KNXb-@w2B|L{Nn03Zkf;0xau z5Q`53f~h(HbSN*McmYX$14;u^2oTYr2u~!`+5(Nf2j75h{%rqecelQ|E%A~d;b5AJcs<3w{OgNTpvXK zGE}l--wQtPb<&_+O%T3(j`F;L6-`=%fh8|197)z)Vzumja1Bva$&`Ch+xd- zR8XR2W46RXe}r!4D^n8oDQ@J`nwX@jjMgo=1ZBfwBE0WYlf~m6bdOK7>-WQ#4I?6M zS{~-%b+=xPz{VukH3m=2IqnG;#GoAZiO#97-|*Wjx6pi|o*e^XM;WIqv%?l|)Z-tN zX+;I_DXFTHu6G|2_(mYH>8UjJx?61xTMZ06w4o_+@GGzQwl`pJ7I1JzSocBo zXO1(}f?gb#nYdxvt>wJSvt8Z#xUI5d^6jd0asDi9fMj(oc0Hje6P*G8ctX3*1+u7#y&j%G$ z@y|^e7sAw&Zf~!S-yaxg;HV2Zw5o`l?&hod#@8i(9jUlLka-2gpldc46+KR zF}tZ#B+`{C>=Q^!NQi`yXd;&BITmK+5Xrp6w8U18ObZv+|cXst?;;Y`qGU5eftS5zq zsN&Yvxg?TOBLP#;V3XW^%zWgkjBo_9!qF(Cu_k52Dkt?J4Cn=rgCGQ8c$orrvPgAg zkl8#*iHtn9Lb1wEGt17hotay3$|m&Ti!@RVs-cN(3aph7JJY=wQ%u$n)c0K&Lf*{8 znGr~#F)=dP@Zm)d1@90O#MlEF0ahS{>(?+0EfxiqgFTuUZ`s+Wv68FbPbCZ6+u`mB zqSlQ{*JL0#gOb9sjHroPF$V^qG{Gli20hzY1Y6!1W5QXrdXamat(s zES5smmJ(VN2@d6fNJ)Ix@$Y1d2=`c9V0anLaZ<5aeQdyBD5Iva3N4{cF+2CjU{)hP zr7uV*Coc($l%I3O)=oCiruT71NT8(4NF^k7a8NCP;z0&A!$;$O%9ckAD+ZIhy_UkI zZ7QoQfGA4BMF`1~LKCK}non0LkDi>SwaZ1S($%Gj2`NFq#X*QYzq82ak9VINnrTG6 z4z#tZQKed2MR9^xyw41@*A{jqQkv-kO&B0suvLAd%%EUD3!RMi+qG(Cs4}vv6hQOZ~K_m=ll8e;$67q?j)C;eo%` zR^;WU7VtDg>69#Yo4P3&GKkTNMOw>$mTRE}Dg>vQTG$+iZTCzcq+pebI_yMTZ`l_w z9~rX}-XG2h=fUn}uGNXLQ7-|G5W1|fMWACM=U!SAHV#7uRJ~CQ-2@F%I&5?xH zbO=4u5DzClJ;?>c;!@FDt>nWlfJi$I@=BT*epPz7g|4B#nb#&K9W{oC_nu}9mT-s^ z+A^3>_h5cFMx=k(g?r|rjyl<3q{MoB102Hvp2{4u7y-k9q!_qJz8_Xj)qX(XazF6#-pCtG0$WKvHZ#H<6XWi5HJ-JPq!L2%d z#(=#S2|O$hPq|QXBD5h07+(8QqAbkFy$7NTj!Z5;IR(bMVz`a|bD)F`QP;ofs2>aj zNvfXOXPK{?eZ?jYL^dLe+a`9C3=?QZSixZVh(Vl*$?Qt!*52>g!x11Z+v$QHa@IBQ3VJTa!ZX`OvSm$+B2 zZ_iVUMJ?k=Nb5~B zz8I~sV7!o2(_{GK0tBJ>OeG;!S-#fOm37%+$^A)LOK@#V2!#j+^S30%pi?rL!~s2m zHW7(JvkPiev=Pf?Q-=&MsSU}4I%dp|YVPly7GP4nxY)<(Ns$QH=jM=gt@bN2!D{g3 zPlGTQuz{O&=~2`$uby67bbQoSLTyd;)v(>aDz)wUqP~dZP356V%HED<&!W3C6y8g6 xYPppojg?UulPDzBX9mF_(JD$TTFbLh_ks107Al1d3OmQ*F64@Ep&?Xj+0M%_{yP8w delta 2691 zcmV-}3Vij06@(RkLRx4!F+o`-Q&|S3)zJVMjsL{||7Zn5fB)crZ{NVb|Nrnn000mO z0pJV&7Z8iM@H`boOo1YS^XJeCOXved@YKZ6LqGxyg*cV8f_DQ$_)&RhCz@G4FQB?0BF$A zNu-ey0i+okXfzK{0MG+X007Vc14009z7Pg5lE0yNOjG-Lxo zpa26CKn#G%l`Q6yJfnz)X^w!p>QqwrBBrjL0xQG!yt1e^u?)`_*Izzmp@1-OZSe3J zqHRSnl3hT5R5BO!XJ-8Ui?YRVKtx7FclW-WYXOLnHUF)w14?oBzVib|->CA7g8P}qon-;w6>b2!gdM>p~F|B%(gILMbA z&tl(gmfVYZj0s$*F@8bMa7ex-0OzQ#x+`z{`0I_kWSpRx$?3qS!qKOWa+L67W^j$%xHz_zTCsAInr2aPwmq{oKyW!I)3E()fK2(YSujVE%#5F!9T!4V7Q0Z8THqInylZv$o^ zqHBtRF;D=3AtAF!h%K!^f+72ep!1-J1=`Y$U&07F8+(R!qN?ga5Yg7hm9e#_my_3{ z6hXpf=Pe{4sv;<;#e&5JK@nhr#UhHah>D^Lu|*hyDkuWTq9CB6qY+rFR8zs}b~xu+ zPkO3eY38FM^0ksZt7 z)He*-inucBmiKmn-0yd6U0cYJWW)@cvvLb69X4R$STMz4P~v|qA)%6NnBkh?cg_~O z=5ND>#@WtCPXip|w)bfyk=qrDf^i5IR<4ahlH71|@)^S?F-4dcr>GRErL=3ij&3-N zb2B(y@>XtzGPTndw4Q(4I?&J%(nAUWw1kl2NP`DTUPkWaOp{7ftFTQWEg~WkMWBjX zq~uwfln4>2fe45ol7U1ub9NrevnnwZE~Jt~jD!njQo7eCB{$rqySlDnzPHPe9*Ly{ zm?YT~P7Ec^9AlTKBUnFRWz?2JT8UNIS?9*wGSryVQ9&f zw+x~=wJ~OjLA6vdD^RM*Q3IeI2*R3Xu!g5~(S$AOIf*PqB80@m%V*Jr6drs5I?aGF zkQHJGPCRn}!qIRd*mLZdoy~VBS*Fl~Oc|R1^Z4l!Yj@*nK^= zBv?nD!rKF;&K1Q5 z+c8m+D3+=ql_RBsgB(*Jh%vS*Z{5RV3~@rqE6?9z*i@~hRb`L`30O#>888V6$5u@z zchS}we01WP*A|OarK?LB2`NFq#bTllh4Aw5-+pG`(xu>WrL9tpD$?33j1s*Da?4F` zXGt#uTrGd9w74NPG>NM#dbe$BYim-AY@#iqkx4sSLubA}9#{}3c>R0ZdcFPgj^02J z1XVgl{P#%0*42(?LNVY(LAPFN4M@DLsLKok zzPZRm6QcPrloy^c->jAC{*tk zZ=8Q#$)h$27OO1&IX5y5DTJ%YtXLd}W!BaY&M!(t-Bltt3$;e$;o(~_EusA&o;#lA zSnU{^l+y1QUkhl*1Z=|z7fNx=p{Q~gGM(*2GjtFuNav~0gN{$0l56M;GaJlwwjF&> z{GtNb-mR6+ieR})BaOqjeo{-aCzW%=5OIG~`c#!d|ISFWGVQj91e36^Sax9XY$4b7 z9g=*{9HvSIk*Ktu8#UK@=w6@0hdbuDg*I&U4_}&0u!Kdxrs`=8+Y@96J=KT@lb;^c zgK#*Mvuf#aFw1x(9cOVR3K)9w*|aip7-t$T@i|k-7$KQjs~2Zl5X-wNg#qry{WO1t zO^5g)&&1p%!%C_Xn2#Rt$utnGPzj!hj04){N4Tx5V;%CfZ22|NH$HC8wHg8qzXnjf zEi$vWavwA%iselwV`e2rnd-Lj6Df5lY{u&6mh>G&GwBzk<(in3UFyoz7E5%*LNtV| zJ11Grx3&ljLdBYtP)DmZ7*9_*LN|X$4vd6qDozHQm5|SW?Rw)|G=izm_nHFoS|sq; z9)IbmIT2V8h9Lc)GB}CkMn&j75L|LX=XFqAcWhS^eYwy=0~}20nV{=HiCbEF=axp_ z75mCe9Dxl;qVcP_y~3S4KAId^ zw6z&f8|&+HZHWsEc?$2u#I1kW&l*P@;?Y!2j^k(Ws~e#@uqcDs$G$DI&2M-5(0qGJucdk*wKGNlw{)o-mwbW zw#muCwK;7H_gLlKy8Ea@a$e3gvlG^vd#jqO%2zHGG5OA9LNz)0BpqVzNZ~!jnM$f&j%Kf#nz9qzO|>*` x1BkY%K`SzWuM;bKR`wq~Vwjo}CV6oW*dK!erZ6xi$58)^xgwk>NCQ&p=zwI0{t5s9 diff --git a/R/ui_elements.R b/R/ui_elements.R index 2cd23878..6686879d 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -124,7 +124,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars"), + icon = phosphoricons::ph("binoculars",weight = "bold"), # icon = shiny::icon("binoculars"), disabled = FALSE ), @@ -169,7 +169,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play"), + icon = phosphoricons::ph("play",weight = "bold"), # icon = shiny::icon("play"), disabled = TRUE ), @@ -460,7 +460,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ), diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index e8699886..98d24dae 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -44,7 +44,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) @@ -55,7 +55,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -68,7 +68,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -92,7 +92,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise"), + phosphoricons::ph("arrow-clockwise",weight = "bold"), i18n$t("Update factor variable") ), class = "btn-outline-primary" diff --git a/R/update-variables-ext.R b/R/update-variables-ext.R index 17542646..b5dc5ab0 100644 --- a/R/update-variables-ext.R +++ b/R/update-variables-ext.R @@ -30,7 +30,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear"), + label = phosphoricons::ph("gear",weight = "bold"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -75,7 +75,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), i18n$t("Apply changes") ), width = "100%" diff --git a/SESSION.md b/SESSION.md index d1466928..1e301770 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.4 | +|os |macOS Tahoe 26.4.1 | |system |aarch64, darwin20 | |ui |RStudio | |language |(EN) | |collate |en_US.UTF-8 | |ctype |en_US.UTF-8 | |tz |Europe/Copenhagen | -|date |2026-04-01 | +|date |2026-04-10 | |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.4.1.260401 | +|FreesearchR |26.4.2.260410 | -------------------------------------------------------------------------------- @@ -83,7 +83,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.4.1 |NA |NA | +|FreesearchR |26.4.2 |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) | @@ -147,7 +147,6 @@ |pkgload |1.5.0 |2026-02-03 |CRAN (R 4.5.2) | |plyr |1.8.9 |2023-10-02 |CRAN (R 4.5.0) | |polyclip |1.10-7 |2024-07-23 |CRAN (R 4.5.0) | -|polylabelr |1.0.0 |2026-01-19 |CRAN (R 4.5.2) | |pracma |2.4.6 |2025-10-22 |CRAN (R 4.5.0) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.5.0) | |promises |1.5.0 |2025-11-01 |CRAN (R 4.5.0) | diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 2240bc2c..927131ba 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." "Select a sample dataset from a package.","Vælg et træningsdatasæt." "Data ready to be imported!","Data er klar til at blive importeret!" -"Data has %s obs. of %s variables.","Data har %s obs. på %s variabler." "Data successfully imported!","Data successfully imported!" "Click to see data","Klik for at se data" "No data present.","Ingen data tilstede." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 7866710e..134ec155 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." "Select a sample dataset from a package.","Select a sample dataset from a package." "Data ready to be imported!","Data ready to be imported!" -"Data has %s obs. of %s variables.","Data has %s obs. of %s variables." "Data successfully imported!","Data successfully imported!" "Click to see data","Click to see data" "No data present.","No data present." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/man/align_axes.Rd b/man/align_axes.Rd index 2a8ab279..6d3e79e2 100644 --- a/man/align_axes.Rd +++ b/man/align_axes.Rd @@ -4,7 +4,7 @@ \alias{align_axes} \title{Aligns axes between plots} \usage{ -align_axes(..., x.axis = TRUE, y.axis = TRUE) +align_axes(..., x.axis = TRUE, y.axis = TRUE, percentage = FALSE) } \arguments{ \item{...}{ggplot2 objects or list of ggplot2 objects} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 6da5a230..4222466f 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -7,6 +7,7 @@ \alias{data_visuals_ui} \alias{data_visuals_server} \alias{create_plot} +\alias{plot_bar} \alias{plot_bar_single} \alias{plot_box} \alias{plot_box_single} @@ -25,6 +26,17 @@ data_visuals_server(id, data, palettes, ...) create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) +plot_bar( + data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ... +) + plot_bar_single( data, pri, @@ -91,6 +103,8 @@ shiny server module ggplot2 object +ggplot list object + ggplot object ggplot2 object @@ -116,6 +130,8 @@ Data correlations evaluation module Wrapper to create plot based on provided type +Title + Single vertical barplot Beautiful box plot(s) @@ -138,6 +154,13 @@ Beautiful violin plot } \examples{ create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +mtcars |> + dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> + plot_bar(pri = "cyl", sec = "am", style = "fill") + +mtcars |> + dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> + plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") mtcars |> dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> plot_bar_single(pri = "cyl", sec = "am", style = "fill") diff --git a/man/wrap_plot_list.Rd b/man/wrap_plot_list.Rd index 2a6e8d62..40cf0ba1 100644 --- a/man/wrap_plot_list.Rd +++ b/man/wrap_plot_list.Rd @@ -12,6 +12,7 @@ wrap_plot_list( guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ... ) } From 41c855a71c4f5d14bd8be47c0546c189916cf3e0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:47:36 +0200 Subject: [PATCH 50/62] new version --- app_docker/app.R | 162 ++++++++++++--------- app_docker/translations/translation_da.csv | 2 +- app_docker/translations/translation_sw.csv | 2 +- inst/apps/FreesearchR/app.R | 162 ++++++++++++--------- 4 files changed, 194 insertions(+), 134 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index fe1bceb3..4dd38592 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmlTuE8/file8be05102425f.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprUCGcI/file4761ae70bf7.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.4.1' +app_version <- function()'26.4.2' ######## @@ -512,7 +512,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil"), i18n$t("Create column") + phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -520,7 +520,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle"), + phosphoricons::ph("x-circle",weight = "bold"), i18n$t("Cancel") ), class = "btn-outline-danger", @@ -1568,7 +1568,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -2175,7 +2175,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = phosphoricons::ph("paint-brush"), + icon = phosphoricons::ph("paint-brush",weight = "bold"), # icon = shiny::icon("palette"), disabled = FALSE ), @@ -2380,7 +2380,8 @@ data_visuals_server <- function(id, colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes + choices = palettes, + previews = 5 ) }) @@ -2858,6 +2859,7 @@ wrap_plot_list <- function(data, guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ...) { if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { @@ -2871,7 +2873,7 @@ wrap_plot_list <- function(data, .x } })() |> - align_axes() |> + align_axes(percentage=y.axis.percentage) |> patchwork::wrap_plots(guides = guides, axes = axes, axis_titles = axis_titles, @@ -2916,7 +2918,8 @@ wrap_plot_list <- function(data, #' align_axes <- function(..., x.axis = TRUE, - y.axis = TRUE) { + y.axis = TRUE, + percentage = FALSE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -2934,7 +2937,7 @@ align_axes <- function(..., xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x) { + p_out <- purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -2945,6 +2948,15 @@ align_axes <- function(..., out }) }) + + if(isTRUE(percentage)){ + lapply(p_out,\(.x){ + .x+ + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } } #' Extract and clean axis ranges @@ -4031,13 +4043,13 @@ color_choices <- function() { "Perceptual (blue-yellow)" = "viridis", "Perceptual (fire)" = "plasma", "Colour-blind friendly" = "Okabe-Ito", - "Qualitative (bold)" = "Dark 2", - "Qualitative (paired)" = "Paired", - "Sequential (blues)" = "Blues", + "Diverging (red-yellow-green)"= "RdYlGn", "Diverging (red-blue)" = "RdBu", - "Tableau style" = "Tableau 10", - "Pastel" = "Pastel 1", - "Rainbow" = "rainbow" + "Sequential (blues)" = "Blues", + "Qualitative (paired)" = "Paired", + "Qualitative (bold)" = "Dark 2", + "Rainbow" = "Spectral", + "Generic" = "Set1" ) } @@ -4945,7 +4957,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.4.1-260402' +hosted_version <- function()'v26.4.2-260410' ######## @@ -6085,7 +6097,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6096,7 +6108,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6581,7 +6593,7 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ) @@ -6918,8 +6930,32 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), - color.palette = "viridis", max_level = 30, ...) { +#' Title +#' +#' @name data-plots +#' +#' @param style barplot style passed to geom_bar position argument. +#' One of c("stack", "dodge", "fill") +#' +#' @returns ggplot list object +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> +#' plot_bar(pri = "cyl", sec = "am", style = "fill") +#' +#' mtcars |> +#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> +#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") +plot_bar <- function(data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6928,7 +6964,7 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ds <- list(data) } - out <- lapply(ds, \(.ds){ + out <- lapply(ds, \(.ds) { plot_bar_single( data = .ds, pri = pri, @@ -6939,7 +6975,10 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ) }) - wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), ...) + wrap_plot_list(out, + title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), + y.axis.percentage = TRUE, + ...) } @@ -6961,7 +7000,11 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, +plot_bar_single <- function(data, + pri, + sec = NULL, + style = c("stack", "dodge", "fill"), + max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -6971,16 +7014,11 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data) - ) + p = Freq / NROW(data)) if (nrow(p_data) > max_level) { - p_data <- sort_by( - p_data, - p_data[["Freq"]], - decreasing = TRUE - ) |> + p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> head(max_level) } @@ -6993,41 +7031,33 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " fill <- pri } - p <- ggplot2::ggplot( - p_data, - ggplot2::aes( - x = .data[[pri]], - y = p, - fill = .data[[fill]] - ) - ) + + p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + ggplot2::geom_bar(position = style, stat = "identity") + - ggplot2::scale_y_continuous(labels = scales::percent) + - scale_fill_generate(palette=color.palette) + - ggplot2::ylab("Percentage") + - ggplot2::xlab(get_label(data,pri))+ - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) + scale_fill_generate(palette = color.palette) + + ggplot2::xlab(get_label(data, pri)) + + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | + any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, hjust = 1 - ))+ - ggplot2::theme( - axis.text.x = ggplot2::element_text(vjust = 0.5) - ) + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, + hjust = 1 + )) + + ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) - if (is.null(sec)){ + if (is.null(sec)) { p <- p + ggplot2::guides(fill = "none") } } - p + p + + ggplot2::scale_y_continuous(labels = scales::percent) + + ggplot2::ylab("Percentage") } @@ -10965,7 +10995,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -11850,7 +11880,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars"), + icon = phosphoricons::ph("binoculars",weight = "bold"), # icon = shiny::icon("binoculars"), disabled = FALSE ), @@ -11895,7 +11925,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play"), + icon = phosphoricons::ph("play",weight = "bold"), # icon = shiny::icon("play"), disabled = TRUE ), @@ -12186,7 +12216,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ), @@ -12497,7 +12527,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) @@ -12508,7 +12538,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -12521,7 +12551,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -12545,7 +12575,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise"), + phosphoricons::ph("arrow-clockwise",weight = "bold"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -12897,7 +12927,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear"), + label = phosphoricons::ph("gear",weight = "bold"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -12942,7 +12972,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), i18n$t("Apply changes") ), width = "100%" diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 2240bc2c..927131ba 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." "Select a sample dataset from a package.","Vælg et træningsdatasæt." "Data ready to be imported!","Data er klar til at blive importeret!" -"Data has %s obs. of %s variables.","Data har %s obs. på %s variabler." "Data successfully imported!","Data successfully imported!" "Click to see data","Klik for at se data" "No data present.","Ingen data tilstede." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 7866710e..134ec155 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." "Select a sample dataset from a package.","Select a sample dataset from a package." "Data ready to be imported!","Data ready to be imported!" -"Data has %s obs. of %s variables.","Data has %s obs. of %s variables." "Data successfully imported!","Data successfully imported!" "Click to see data","Click to see data" "No data present.","No data present." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 66df2775..fbadebb2 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//RtmpmlTuE8/file8be0207bfdc2.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprUCGcI/file47614d090a4c.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.4.1' +app_version <- function()'26.4.2' ######## @@ -512,7 +512,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil"), i18n$t("Create column") + phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -520,7 +520,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle"), + phosphoricons::ph("x-circle",weight = "bold"), i18n$t("Cancel") ), class = "btn-outline-danger", @@ -1568,7 +1568,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -2175,7 +2175,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = phosphoricons::ph("paint-brush"), + icon = phosphoricons::ph("paint-brush",weight = "bold"), # icon = shiny::icon("palette"), disabled = FALSE ), @@ -2380,7 +2380,8 @@ data_visuals_server <- function(id, colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes + choices = palettes, + previews = 5 ) }) @@ -2858,6 +2859,7 @@ wrap_plot_list <- function(data, guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ...) { if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { @@ -2871,7 +2873,7 @@ wrap_plot_list <- function(data, .x } })() |> - align_axes() |> + align_axes(percentage=y.axis.percentage) |> patchwork::wrap_plots(guides = guides, axes = axes, axis_titles = axis_titles, @@ -2916,7 +2918,8 @@ wrap_plot_list <- function(data, #' align_axes <- function(..., x.axis = TRUE, - y.axis = TRUE) { + y.axis = TRUE, + percentage = FALSE) { # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 if (ggplot2::is_ggplot(..1)) { @@ -2934,7 +2937,7 @@ align_axes <- function(..., xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x) { + p_out <- purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -2945,6 +2948,15 @@ align_axes <- function(..., out }) }) + + if(isTRUE(percentage)){ + lapply(p_out,\(.x){ + .x+ + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } } #' Extract and clean axis ranges @@ -4031,13 +4043,13 @@ color_choices <- function() { "Perceptual (blue-yellow)" = "viridis", "Perceptual (fire)" = "plasma", "Colour-blind friendly" = "Okabe-Ito", - "Qualitative (bold)" = "Dark 2", - "Qualitative (paired)" = "Paired", - "Sequential (blues)" = "Blues", + "Diverging (red-yellow-green)"= "RdYlGn", "Diverging (red-blue)" = "RdBu", - "Tableau style" = "Tableau 10", - "Pastel" = "Pastel 1", - "Rainbow" = "rainbow" + "Sequential (blues)" = "Blues", + "Qualitative (paired)" = "Paired", + "Qualitative (bold)" = "Dark 2", + "Rainbow" = "Spectral", + "Generic" = "Set1" ) } @@ -4945,7 +4957,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.4.1-260402' +hosted_version <- function()'v26.4.2-260410' ######## @@ -6085,7 +6097,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6096,7 +6108,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6581,7 +6593,7 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ) @@ -6918,8 +6930,32 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), - color.palette = "viridis", max_level = 30, ...) { +#' Title +#' +#' @name data-plots +#' +#' @param style barplot style passed to geom_bar position argument. +#' One of c("stack", "dodge", "fill") +#' +#' @returns ggplot list object +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> +#' plot_bar(pri = "cyl", sec = "am", style = "fill") +#' +#' mtcars |> +#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> +#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") +plot_bar <- function(data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6928,7 +6964,7 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ds <- list(data) } - out <- lapply(ds, \(.ds){ + out <- lapply(ds, \(.ds) { plot_bar_single( data = .ds, pri = pri, @@ -6939,7 +6975,10 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ) }) - wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), ...) + wrap_plot_list(out, + title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), + y.axis.percentage = TRUE, + ...) } @@ -6961,7 +7000,11 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, +plot_bar_single <- function(data, + pri, + sec = NULL, + style = c("stack", "dodge", "fill"), + max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -6971,16 +7014,11 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data) - ) + p = Freq / NROW(data)) if (nrow(p_data) > max_level) { - p_data <- sort_by( - p_data, - p_data[["Freq"]], - decreasing = TRUE - ) |> + p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> head(max_level) } @@ -6993,41 +7031,33 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " fill <- pri } - p <- ggplot2::ggplot( - p_data, - ggplot2::aes( - x = .data[[pri]], - y = p, - fill = .data[[fill]] - ) - ) + + p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + ggplot2::geom_bar(position = style, stat = "identity") + - ggplot2::scale_y_continuous(labels = scales::percent) + - scale_fill_generate(palette=color.palette) + - ggplot2::ylab("Percentage") + - ggplot2::xlab(get_label(data,pri))+ - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) + scale_fill_generate(palette = color.palette) + + ggplot2::xlab(get_label(data, pri)) + + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | + any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, hjust = 1 - ))+ - ggplot2::theme( - axis.text.x = ggplot2::element_text(vjust = 0.5) - ) + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, + hjust = 1 + )) + + ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) - if (is.null(sec)){ + if (is.null(sec)) { p <- p + ggplot2::guides(fill = "none") } } - p + p + + ggplot2::scale_y_continuous(labels = scales::percent) + + ggplot2::ylab("Percentage") } @@ -10965,7 +10995,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -11850,7 +11880,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars"), + icon = phosphoricons::ph("binoculars",weight = "bold"), # icon = shiny::icon("binoculars"), disabled = FALSE ), @@ -11895,7 +11925,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play"), + icon = phosphoricons::ph("play",weight = "bold"), # icon = shiny::icon("play"), disabled = TRUE ), @@ -12186,7 +12216,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ), @@ -12497,7 +12527,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) @@ -12508,7 +12538,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -12521,7 +12551,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -12545,7 +12575,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise"), + phosphoricons::ph("arrow-clockwise",weight = "bold"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -12897,7 +12927,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear"), + label = phosphoricons::ph("gear",weight = "bold"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -12942,7 +12972,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), i18n$t("Apply changes") ), width = "100%" From 7f14447627c29545c954940bc0ab44ac813d6fe0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 15 Apr 2026 23:47:49 +0200 Subject: [PATCH 51/62] revised --- R/generate_colors.R | 96 +++++++++++++++++++++------------------------ 1 file changed, 45 insertions(+), 51 deletions(-) diff --git a/R/generate_colors.R b/R/generate_colors.R index d7a7cc82..9daec605 100644 --- a/R/generate_colors.R +++ b/R/generate_colors.R @@ -56,38 +56,25 @@ #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { + + # --- Input validation ------------------------------------------------------- + if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { stop("`n` must be a single positive integer.") } + if (!is.function(palette) && (!is.character(palette) || length(palette) != 1)) { + stop("`palette` must be a single character string or a function.") + } - # Function passthrough — call directly with n and ... + # --- Function passthrough --------------------------------------------------- if (is.function(palette)) { return(palette(n, ...)) } - if (!is.character(palette) || length(palette) != 1) { - stop("`palette` must be a single character string or a function.") - } - - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { - stop("`n` must be a single positive integer.") - } - if (!is.character(palette) || length(palette) != 1) { - stop("`palette` must be a single character string.") - } - + # --- Named palette dispatch ------------------------------------------------- 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, ...) @@ -107,35 +94,42 @@ generate_colors <- function(n, palette = "viridis", ...) { } else if (palette_lower == "topo") { grDevices::topo.colors(n = n, ...) - } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { - max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] - fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() - base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) - grDevices::colorRampPalette(base_colors)(n) - - } else if (palette %in% grDevices::palette.pals()) { - grDevices::colorRampPalette(palette.colors(palette = palette))(n) - - } else if (palette %in% grDevices::hcl.pals()) { - grDevices::hcl.colors(n = n, palette = palette, ...) - } else { - message( - paste0( - "Unknown palette: '", - palette, - "'. ", - "Falling back to default R colors.\n", - "Available options:\n", - " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", - " grDevices : hcl, rainbow, heat, terrain, topo\n", - " grDevices HCL: use grDevices::hcl.pals() to see all options\n", - " grDevices : use grDevices::palette.pals() to see all options\n", - " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" - ) - ) - viridisLite::viridis(n = n, option = "viridis") - # grDevices::hcl.colors(n = n) + # Case-insensitive RColorBrewer lookup + brewer_names <- rownames(RColorBrewer::brewer.pal.info) + brewer_match <- brewer_names[match(palette_lower, tolower(brewer_names))] + + if (!is.na(brewer_match)) { + max_n <- RColorBrewer::brewer.pal.info[brewer_match, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = brewer_match) + grDevices::colorRampPalette(base_colors)(n) + + } else { + # Case-insensitive grDevices palette.pals() lookup + pal_names <- grDevices::palette.pals() + pal_match <- pal_names[match(palette_lower, tolower(pal_names))] + + if (!is.na(pal_match)) { + grDevices::colorRampPalette(grDevices::palette.colors(palette = pal_match))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + # Named HCL palettes (e.g. "Rocket", "Plasma") — distinct from viridisLite + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + warning( + "Unknown palette: '", palette, "'. Falling back to viridis.\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") + } + } } } From 0d4f51f176a3becccef8f620b66e1f52ad194528 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 27 May 2026 20:23:58 +0200 Subject: [PATCH 52/62] upd --- .Rbuildignore | 2 ++ .gitignore | 1 + 2 files changed, 3 insertions(+) diff --git a/.Rbuildignore b/.Rbuildignore index 94927477..a0e3635f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,5 @@ ^app*$ ^page$ ^demo$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index ce227491..25eb7609 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ app page demo visuals +.positai From d1e0236437fe08aac8bf07e9c2d4468b0a189fae Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 29 May 2026 11:46:58 +0200 Subject: [PATCH 53/62] new dynamic plotting working --- R/data_plots.R | 338 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 286 insertions(+), 52 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index a01403df..f2ef156d 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -30,8 +30,9 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("basic_parameters")), + # shiny::uiOutput(outputId = ns("secondary")), + # shiny::uiOutput(outputId = ns("tertiary")), shiny::uiOutput(outputId = ns("color_palette")), shiny::br(), shiny::actionButton( @@ -174,13 +175,19 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data) + plots <- possible_plots(data = plot_data, + source_list=available_plots()) - plots_named <- get_plot_options(plots) |> + plots_named <- get_input_params(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x) { + # stats::setNames(.x$descr, .x$note) + # }) + vectorSelectInput( inputId = ns("type"), selected = NULL, @@ -191,51 +198,124 @@ data_visuals_server <- function(id, }) rv$plot.params <- shiny::reactive({ - get_plot_options(input$type) |> purrr::pluck(1) + get_input_params(input$type)|> purrr::pluck(1) + # get_plot_options(input$type) |> purrr::pluck(1) }) - output$secondary <- shiny::renderUI({ - shiny::req(input$type) - cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - subset_types(data(), rv$plot.params()[["secondary.type"]]) - ), input$primary)) + output$basic_parameters <- renderUI({ + req(input$type, rv$plot.params) - columnSelectInput( - inputId = ns("secondary"), - data = data, - selected = cols[1], - placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) - i18n$t("Additional variables") - else - i18n$t("Secondary variable"), - multiple = rv$plot.params()[["secondary.multi"]], - maxItems = rv$plot.params()[["secondary.max"]], - col_subset = cols, - none_label = i18n$t("No variable") - ) + # Get the plot function name + base_params <- rv$plot.params()[["basic"]] + + + params2update <- seq_along(base_params)[sapply(base_params, function(params) { + params$type %in% "select_variables" + })] + + # browser() + updated_params <- seq_along(params2update) |> lapply(function(index){ + params <- base_params[params2update][[index]] + params$exclude <- input$primary + + edits <- base_params[params2update][seq_len(index-1)] + + id_exclude <- unlist(lapply(edits,\(.x){.x[["id"]]})) + + if (length(id_exclude)>0){ + ids <- paste0("base_", id_exclude) + + params$exclude <- c(params$exclude, names(input)[ids %in% names(input)]) + } + + return(params) + }) + + base_params[params2update] <- updated_params + + # Create UI elements for base parameters + base_inputs <- lapply(base_params, function(params) { + input_id <- paste0("base_", params$id) + params$id <- NULL + if (params$type %in% "select_variables"){ + params$data <- data() + } + + create_input_element(params, ns, input_id) + }) + + if(length(base_inputs) > 0) { + tagList(base_inputs) + } else { + p("No basic parameters available for this plot type.") + } }) - output$tertiary <- shiny::renderUI({ - shiny::req(input$type) - columnSelectInput( - inputId = ns("tertiary"), - data = data, - placeholder = i18n$t("Please select"), - label = i18n$t("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 = i18n$t("No stratification") - ) - }) + + # output$secondary <- shiny::renderUI({ + # shiny::req(input$type) + # + # browser() + # + # + # params <- rv$plot.params()[["inputs"]][[1]] + # + # # params$fun <- NULL + # params$exclude <- input$primary + # # params$inputId <- paste0("base_", names(available_plots()[[1]][["inputs"]])[1]) + # + # # input_fun <- rlang::eval_tidy(rlang::sym("selectPlotVariables"), env = asNamespace("shiny")) + # # + # # rlang::inject(input_fun(!!!append_list(data(), params, "data"))) + # + # create_input_element(input_id = paste0("base_", names(available_plots()[[1]][["inputs"]])[1]), + # ns = ns, + # params = append_list(data(), params, "data")) + # + # # rlang::exec(selectPlotVariables, + # # !!!append_list(data(), params, "data")) + # + # + # # cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + # # subset_types(data(), rv$plot.params()[["secondary.type"]]) + # # ), input$primary)) + # # + # # columnSelectInput( + # # inputId = ns("secondary"), + # # data = data, + # # selected = cols[1], + # # placeholder = i18n$t("Please select"), + # # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + # # i18n$t("Additional variables") + # # else + # # i18n$t("Secondary variable"), + # # multiple = rv$plot.params()[["secondary.multi"]], + # # maxItems = rv$plot.params()[["secondary.max"]], + # # col_subset = cols, + # # none_label = i18n$t("No variable") + # # ) + # }) + # + # output$tertiary <- shiny::renderUI({ + # shiny::req(input$type) + # columnSelectInput( + # inputId = ns("tertiary"), + # data = data, + # placeholder = i18n$t("Please select"), + # label = i18n$t("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 = i18n$t("No stratification") + # ) + # }) ### Color option output$color_palette <- shiny::renderUI({ @@ -251,13 +331,28 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { tryCatch({ - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary, - color.palette = input$color_palette - ) + + ## BELOW NEEDS REVISION ### + + # Get all input values with prefixes + base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] + advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] + + # Remove the prefix from names + names(base_inputs) <- gsub("^base_", "", names(base_inputs)) + names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) + + # Combine all parameters + dynamic_params <- c(base_inputs, advanced_inputs) + + # Build parameters for plotting function + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + color.palette = input$color_palette + ) + + parameters <- modifyList(parameters, dynamic_params) ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included @@ -343,6 +438,118 @@ data_visuals_server <- function(id, ) } +available_plots <- function() { +list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + basic = list( + list( + id = "sec", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = FALSE + ), + list( + id = "ter", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + basic = list( + list( + id = "sec", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = FALSE + ), + list( + id = "ter", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ) +) +} + +# Helper function to create input elements dynamically +create_input_element <- function(params, ns, input_id) { + # Add the namespaced inputId to the arguments + params$inputId <- ns(input_id) + + # Map input types to Shiny functions + input_function <- switch(params$type, + "numeric_input" = shiny::numericInput, + "select_input" = shiny::selectInput, + "checkbox_input" = shiny::checkboxInput, + "slider_input" = shiny::sliderInput, + "text_input" = shiny::textInput, + "select_variables" = selectPlotVariables + ) + + params$type <- NULL + + # Call the function with all arguments + do.call(input_function, params) +} + +selectPlotVariables <- function(data,exclude=NULL,allow_none=TRUE,var_types,...){ + datar <- if (is.reactive(data)){ + data + } else { + reactive(data)} + + cols <- all_but(colnames( + subset_types(datar(), var_types) + ), exclude) + + if (isTRUE(allow_none)){ + cols <- c("none",cols) + } + + params <- list(...) + + params$none_label <- i18n$t("No variable") + params$col_subset <- cols + + rlang::exec(columnSelectInput, + !!!append_list(datar(), params, "data")) +} + + + #' Select all from vector but #' #' @param data vector @@ -533,7 +740,7 @@ supported_plots <- function() { #' default_parsing() |> #' dplyr::select("mpg") |> #' possible_plots() -possible_plots <- function(data) { +possible_plots <- function(data,source_list = supported_plots()) { # browser() # data <- if (is.reactive(data)) data() else data if (is.data.frame(data)) { @@ -545,7 +752,7 @@ possible_plots <- function(data) { if (type == "unknown") { out <- type } else { - out <- supported_plots() |> + out <- source_list |> lapply(\(.x) { if (type %in% .x$primary.type) { .x$descr @@ -584,6 +791,33 @@ get_plot_options <- function(data) { })() } +#' Get the function parameters based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_input_params() +get_input_params <- function(data) { + descr <- available_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + available_plots() |> + (\(.x) { + .x[match(data, descr)] + })() +} #' Wrapper to create plot based on provided type From f2a522dcb6c33050b61d9640b6298e93dd332ccc Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 29 May 2026 11:47:15 +0200 Subject: [PATCH 54/62] allows ... inputs in plot models --- R/hosted_version.R | 2 +- R/plot_bar.R | 6 +++--- R/plot_box.R | 4 ++-- R/plot_euler.R | 2 +- R/plot_hbar.R | 6 ++++-- R/plot_likert.R | 3 ++- R/plot_sankey.R | 3 ++- R/plot_scatter.R | 2 +- R/plot_violin.R | 5 +++-- examples/visuals_module_demo.R | 2 +- 10 files changed, 20 insertions(+), 15 deletions(-) diff --git a/R/hosted_version.R b/R/hosted_version.R index 33aaf67c..5a0a6546 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260410' +hosted_version <- function()'v26.4.2-260528' diff --git a/R/plot_bar.R b/R/plot_bar.R index 0535b6f3..e9879ef3 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -39,14 +39,14 @@ plot_bar <- function(data, sec = sec, style = style, max_level = max_level, - color.palette = color.palette + color.palette = color.palette, + ... ) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE, - ...) + y.axis.percentage = TRUE) } diff --git a/R/plot_box.R b/R/plot_box.R index 01911aac..4acd67ab 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -32,11 +32,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette + color.palette=color.palette, ... ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) } diff --git a/R/plot_euler.R b/R/plot_euler.R index 27cdf02f..a5a0d31f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -131,7 +131,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis") { +plot_euler_single <- function(data,color.palette="viridis", ...) { data |> ggeulerr(shape = "circle") + diff --git a/R/plot_hbar.R b/R/plot_hbar.R index d93ef4c9..1405678f 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -15,13 +15,15 @@ plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette + color.palette = color.palette, + ... ) } diff --git a/R/plot_likert.R b/R/plot_likert.R index c18c57a1..e33256a2 100644 --- a/R/plot_likert.R +++ b/R/plot_likert.R @@ -15,7 +15,8 @@ plot_likert <- function(data, pri, sec = NULL, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 23c1a13a..409a1050 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -95,7 +95,8 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing") { + missing.level = "Missing", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { diff --git a/R/plot_scatter.R b/R/plot_scatter.R index 142c30fd..8c73547e 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (is.null(ter)) { rempsyc::nice_scatter( data = data, diff --git a/R/plot_violin.R b/R/plot_violin.R index 83d11d2a..29850d26 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -23,7 +23,8 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + ytitle = get_label(data, var = pri), + ... )+ scale_fill_generate(palette=color.palette) }) diff --git a/examples/visuals_module_demo.R b/examples/visuals_module_demo.R index 00a8c020..e4883d6c 100644 --- a/examples/visuals_module_demo.R +++ b/examples/visuals_module_demo.R @@ -22,7 +22,7 @@ visuals_demo_app <- function() { ) ) server <- function(input, output, session) { - pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars))) + pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars)),palettes = color_choices()) } shiny::shinyApp(ui, server) } From f774b90d073bf4d49dea4cb7fce60a61aa8e7053 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 19:55:45 +0200 Subject: [PATCH 55/62] transformed for a new pragmatic compromise to dynamically load additional input options where available --- R/data_plots.R | 882 ++++++------------------------------------------- 1 file changed, 106 insertions(+), 776 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index f2ef156d..41edfb20 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -14,12 +14,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { list( bslib::layout_sidebar( sidebar = bslib::sidebar( + shiny::actionButton( + inputId = ns("act_plot"), + label = i18n$t("Plot"), + width = "100%", + icon = phosphoricons::ph("paint-brush", weight = "bold"), + # icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText( + i18n$t('Adjust plot input and settings below, then press "Plot".') + ), bslib::accordion( id = "acc_plot", multiple = FALSE, bslib::accordion_panel( value = "acc_pan_plot", - title = "Create plot", + title = i18n$t("Define plot"), icon = phosphoricons::ph("chart-line"), # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), @@ -30,20 +41,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::uiOutput(outputId = ns("basic_parameters")), - # shiny::uiOutput(outputId = ns("secondary")), - # shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("secondary")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), shiny::uiOutput(outputId = ns("color_palette")), - shiny::br(), - shiny::actionButton( - inputId = ns("act_plot"), - label = i18n$t("Plot"), - width = "100%", - icon = phosphoricons::ph("paint-brush",weight = "bold"), - # icon = shiny::icon("palette"), - disabled = FALSE - ), - shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) + shiny::uiOutput(outputId = ns("basic_parameters")), ), bslib::accordion_panel( value = "acc_pan_download", @@ -120,10 +126,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, - data, - palettes, - ...) { +data_visuals_server <- function(id, data, palettes = color_choices(), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -175,8 +178,7 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data, - source_list=available_plots()) + plots <- possible_plots(data = plot_data, source_list = available_plots()) plots_named <- get_input_params(plots) |> lapply(\(.x) { @@ -198,125 +200,77 @@ data_visuals_server <- function(id, }) rv$plot.params <- shiny::reactive({ - get_input_params(input$type)|> purrr::pluck(1) + get_input_params(input$type) |> purrr::pluck(1) # get_plot_options(input$type) |> purrr::pluck(1) }) + ### Include two additional variable inputs + output$secondary <- shiny::renderUI({ + shiny::req(input$type) + + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + params$id %in% "secondary" + })][[1]] + + filtered_params$exclude <- input$primary + + create_input_element( + input_id = "secondary", + ns = ns, + params = append_list(data(), filtered_params, "data") + ) + + }) + + output$tertiary <- shiny::renderUI({ + shiny::req(input$type) + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + params$id %in% "tertiary" + })][[1]] + + filtered_params$exclude <- c(input$primary, input$secondary) + + create_input_element( + input_id = "tertiary", + ns = ns, + params = append_list(data(), filtered_params, "data") + ) + }) + + + ### Generating additional parameter inputs if any specified output$basic_parameters <- renderUI({ req(input$type, rv$plot.params) # Get the plot function name - base_params <- rv$plot.params()[["basic"]] + base_params <- rv$plot.params()[["base"]] - - params2update <- seq_along(base_params)[sapply(base_params, function(params) { - params$type %in% "select_variables" + filtered_params <- base_params[sapply(base_params, function(params) { + !params$id %in% c("secondary", "tertiary") })] - # browser() - updated_params <- seq_along(params2update) |> lapply(function(index){ - params <- base_params[params2update][[index]] - params$exclude <- input$primary - - edits <- base_params[params2update][seq_len(index-1)] - - id_exclude <- unlist(lapply(edits,\(.x){.x[["id"]]})) - - if (length(id_exclude)>0){ - ids <- paste0("base_", id_exclude) - - params$exclude <- c(params$exclude, names(input)[ids %in% names(input)]) - } - - return(params) - }) - - base_params[params2update] <- updated_params # Create UI elements for base parameters - base_inputs <- lapply(base_params, function(params) { + base_inputs <- lapply(filtered_params, function(params) { input_id <- paste0("base_", params$id) params$id <- NULL - if (params$type %in% "select_variables"){ - params$data <- data() - } + if (params$type %in% "select_variables") { + params$data <- data() + } create_input_element(params, ns, input_id) }) + tagList(base_inputs) - if(length(base_inputs) > 0) { - tagList(base_inputs) - } else { - p("No basic parameters available for this plot type.") - } }) - - # output$secondary <- shiny::renderUI({ - # shiny::req(input$type) - # - # browser() - # - # - # params <- rv$plot.params()[["inputs"]][[1]] - # - # # params$fun <- NULL - # params$exclude <- input$primary - # # params$inputId <- paste0("base_", names(available_plots()[[1]][["inputs"]])[1]) - # - # # input_fun <- rlang::eval_tidy(rlang::sym("selectPlotVariables"), env = asNamespace("shiny")) - # # - # # rlang::inject(input_fun(!!!append_list(data(), params, "data"))) - # - # create_input_element(input_id = paste0("base_", names(available_plots()[[1]][["inputs"]])[1]), - # ns = ns, - # params = append_list(data(), params, "data")) - # - # # rlang::exec(selectPlotVariables, - # # !!!append_list(data(), params, "data")) - # - # - # # cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - # # subset_types(data(), rv$plot.params()[["secondary.type"]]) - # # ), input$primary)) - # # - # # columnSelectInput( - # # inputId = ns("secondary"), - # # data = data, - # # selected = cols[1], - # # placeholder = i18n$t("Please select"), - # # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) - # # i18n$t("Additional variables") - # # else - # # i18n$t("Secondary variable"), - # # multiple = rv$plot.params()[["secondary.multi"]], - # # maxItems = rv$plot.params()[["secondary.max"]], - # # col_subset = cols, - # # none_label = i18n$t("No variable") - # # ) - # }) - # - # output$tertiary <- shiny::renderUI({ - # shiny::req(input$type) - # columnSelectInput( - # inputId = ns("tertiary"), - # data = data, - # placeholder = i18n$t("Please select"), - # label = i18n$t("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 = i18n$t("No stratification") - # ) - # }) - ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) @@ -330,34 +284,49 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ + # Get all input values with prefixes + base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] + # advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] - ## BELOW NEEDS REVISION ### + # Remove the prefix from names + names(base_inputs) <- gsub("^base_", "", names(base_inputs)) + # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) - # Get all input values with prefixes - base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] - advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] + base_inputs <- c(base_inputs, + list(color.palette = input$color_palette)) - # Remove the prefix from names - names(base_inputs) <- gsub("^base_", "", names(base_inputs)) - names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) + # If any of the specified parameters are NULL/missing, the settings + # accordion/panel was never opened, and they can be ignored, as + # default settings will the be used. + if (any(sapply(base_inputs, is.null))) { + dynamic_params <- list() + } else { + dynamic_params <- base_inputs + } - # Combine all parameters - dynamic_params <- c(base_inputs, advanced_inputs) + # Build parameters for plotting function + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary + ) - # Build parameters for plotting function - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - color.palette = input$color_palette - ) - - parameters <- modifyList(parameters, dynamic_params) + parameters <- modifyList(parameters, dynamic_params) ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included if (!is.null(rv$plot.params()[["fun.args"]])) { - parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + default_params <- rv$plot.params()[["fun.args"]] + + ## Ensure not to overwrite user defined parameters are overwritten + ## This allows to define default parameters. + ## + ## This will create a strange edge case, where the plot looks in + ## one way, when plotted initially, but may change, when the settings + ## accordion is opened. Problem for future me. Really mostly an edge case. + parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -437,642 +406,3 @@ data_visuals_server <- function(id, } ) } - -available_plots <- function() { -list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - basic = list( - list( - id = "sec", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = FALSE - ), - list( - id = "ter", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - basic = list( - list( - id = "sec", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = FALSE - ), - list( - id = "ter", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ) -) -} - -# Helper function to create input elements dynamically -create_input_element <- function(params, ns, input_id) { - # Add the namespaced inputId to the arguments - params$inputId <- ns(input_id) - - # Map input types to Shiny functions - input_function <- switch(params$type, - "numeric_input" = shiny::numericInput, - "select_input" = shiny::selectInput, - "checkbox_input" = shiny::checkboxInput, - "slider_input" = shiny::sliderInput, - "text_input" = shiny::textInput, - "select_variables" = selectPlotVariables - ) - - params$type <- NULL - - # Call the function with all arguments - do.call(input_function, params) -} - -selectPlotVariables <- function(data,exclude=NULL,allow_none=TRUE,var_types,...){ - datar <- if (is.reactive(data)){ - data - } else { - reactive(data)} - - cols <- all_but(colnames( - subset_types(datar(), var_types) - ), exclude) - - if (isTRUE(allow_none)){ - cols <- c("none",cols) - } - - params <- list(...) - - params$none_label <- i18n$t("No variable") - params$col_subset <- cols - - rlang::exec(columnSelectInput, - !!!append_list(datar(), params, "data")) -} - - - -#' Select all from vector but -#' -#' @param data vector -#' @param ... exclude -#' -#' @returns vector -#' @export -#' -#' @examples -#' all_but(1:10, c(2, 3), 11, 5) -all_but <- function(data, ...) { - data[!data %in% c(...)] -} - -#' Easily subset by data type function -#' -#' @param data data -#' @param types desired types -#' @param type.fun function to get type. Default is outcome_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) -#' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { - data[sapply(data, type.fun) %in% types] -} - - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - descr: Plot description -#' -#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.extra: "none" or NULL to have option to choose none. -#' -#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' supported_plots() |> str() -supported_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = "none", - tertiary.type = c("dichotomous", "categorical") - ), - # plot_ridge = list( - # descr = "Ridge plot", - # note = "An alternative option to visualise data distribution", - # primary.type = "continuous", - # secondary.type = c("dichotomous" ,"categorical"), - # tertiary.type = c("dichotomous" ,"categorical"), - # secondary.extra = NULL - # ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical") - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - secondary.type = c("datatime", "continuous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - secondary.type = c("dichotomous"), - secondary.multi = TRUE, - secondary.max = 4, - tertiary.type = c("dichotomous"), - secondary.extra = NULL - ), - plot_euler = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t( - "Plot survey results" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = TRUE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ) - ) -} - -#' Get possible regression models -#' -#' @param data data -#' -#' @returns character vector -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' dplyr::pull("cyl") |> -#' possible_plots() -#' -#' mtcars |> -#' default_parsing() |> -#' dplyr::select("mpg") |> -#' possible_plots() -possible_plots <- function(data,source_list = supported_plots()) { - # browser() - # data <- if (is.reactive(data)) data() else data - if (is.data.frame(data)) { - data <- data[[1]] - } - - type <- data_type(data) - - if (type == "unknown") { - out <- type - } else { - out <- source_list |> - lapply(\(.x) { - if (type %in% .x$primary.type) { - .x$descr - } - }) |> - unlist() - } - unname(out) -} - -#' Get the function options based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_plot_options() -get_plot_options <- function(data) { - descrs <- supported_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - supported_plots() |> - (\(.x) { - .x[match(data, descrs)] - })() -} - -#' Get the function parameters based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_input_params() -get_input_params <- function(data) { - descr <- available_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - available_plots() |> - (\(.x) { - .x[match(data, descr)] - })() -} - - -#' Wrapper to create plot based on provided type -#' -#' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable -#' @param type plot type (derived from possible_plots() and matches custom function) -#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. -#' @param ... ignored for now -#' -#' @name data-plots -#' -#' @returns ggplot2 object -#' @export -#' -#' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, - type, - pri, - sec, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(sec)) { - if (!any(sec %in% names(data))) { - sec <- NULL - } - } - - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } - } - - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - color.palette = color.palette, - ... - ) - - out <- do.call(type, modifyList(parameters, list(data = data))) - - code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") - - attr(out, "code") <- code - out -} - -#' Print label, and if missing print variable name for plots -#' -#' @param data vector or data frame -#' @param var variable name. Optional. -#' -#' @returns character string -#' @export -#' -#' @examples -#' mtcars |> get_label(var = "mpg") -#' mtcars |> get_label() -#' mtcars$mpg |> get_label() -#' gtsummary::trial |> get_label(var = "trt") -#' gtsummary::trial$trt |> get_label() -#' 1:10 |> get_label() -get_label <- function(data, var = NULL) { - # data <- if (is.reactive(data)) data() else data - if (!is.null(var) & is.data.frame(data)) { - data <- data[[var]] - } - out <- REDCapCAST::get_attr(data = data, attr = "label") - if (is.na(out)) { - if (is.null(var)) { - out <- deparse(substitute(data)) - } else { - if (is.symbol(var)) { - out <- gsub('\"', "", deparse(substitute(var))) - } else { - out <- var - } - } - } - out -} - - -#' Line breaking at given number of characters for nicely plotting labels -#' -#' @param data string -#' @param lineLength maximum line length -#' @param fixed flag to force split at exactly the value given in lineLength. -#' Default is FALSE, only splitting at spaces. -#' -#' @returns character string -#' @export -#' -#' @examples -#' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, - lineLength = 20, - force = FALSE) { - if (isTRUE(force)) { - ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), - "\\1\n", - data) - } else { - paste(strwrap(data, lineLength), collapse = "\n") - } - ## https://stackoverflow.com/a/29847221 -} - - -#' Wrapping -#' -#' @param data list of ggplot2 objects -#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL -#' @param title panel title -#' @param guides passed to patchwork::wrap_plots() -#' @param axes passed to patchwork::wrap_plots() -#' @param axis_titles passed to patchwork::wrap_plots() -#' @param ... passed to patchwork::wrap_plots() -#' -#' @returns list of ggplot2 objects -#' @export -#' -wrap_plot_list <- function(data, - tag_levels = NULL, - title = NULL, - axis.font.family = NULL, - guides = "collect", - axes = "collect", - axis_titles = "collect", - y.axis.percentage = FALSE, - ...) { - if (ggplot2::is_ggplot(data[[1]])) { - if (length(data) > 1) { - out <- data |> - (\(.x) { - if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i) { - .y + ggplot2::ggtitle(.i) - }) - } else { - .x - } - })() |> - align_axes(percentage=y.axis.percentage) |> - patchwork::wrap_plots(guides = guides, - axes = axes, - axis_titles = axis_titles, - ...) - if (!is.null(tag_levels)) { - out <- out + patchwork::plot_annotation(tag_levels = tag_levels) - } - if (!is.null(title)) { - out <- out + - patchwork::plot_annotation( - title = title, - theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) - ) - } - } else { - out <- data[[1]] - } - } else { - cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") - } - - if (!is.null(axis.font.family)) { - if (inherits(x = out, what = "patchwork")) { - out <- out & - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } else { - out <- out + - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } - } - - out -} - - -#' Aligns axes between plots -#' -#' @param ... ggplot2 objects or list of ggplot2 objects -#' -#' @returns list of ggplot2 objects -#' @export -#' -align_axes <- function(..., - x.axis = TRUE, - y.axis = TRUE, - percentage = FALSE) { - # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object - # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 - if (ggplot2::is_ggplot(..1)) { - ## Assumes list of ggplots - p <- list(...) - } else if (is.list(..1)) { - ## Assumes list with list of ggplots - p <- ..1 - } else { - cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") - } - - yr <- clean_common_axis(p, "y") - - xr <- clean_common_axis(p, "x") - - suppressWarnings({ - p_out <- purrr::map(p, \(.x) { - out <- .x - if (isTRUE(x.axis)) { - out <- out + ggplot2::xlim(xr) - } - if (isTRUE(y.axis)) { - out <- out + ggplot2::ylim(yr) - } - out - }) - }) - - if(isTRUE(percentage)){ - lapply(p_out,\(.x){ - .x+ - ggplot2::scale_y_continuous(labels = scales::percent) - }) - } else { - p_out - } -} - -#' Extract and clean axis ranges -#' -#' @param p plot -#' @param axis axis. x or y. -#' -#' @returns vector -#' @export -#' -clean_common_axis <- function(p, axis) { - purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> - unlist() |> - (\(.x) { - if (is.numeric(.x)) { - range(.x) - } else { - as.character(.x) - } - })() |> - unique() -} From 5ca751d3ea65f52cd20187a6b817782203acf8d3 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 19:56:25 +0200 Subject: [PATCH 56/62] all plot helper functions are moved --- R/plot-helpers.R | 878 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 878 insertions(+) create mode 100644 R/plot-helpers.R diff --git a/R/plot-helpers.R b/R/plot-helpers.R new file mode 100644 index 00000000..361e15ef --- /dev/null +++ b/R/plot-helpers.R @@ -0,0 +1,878 @@ +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - fun: the plotting function +#' +#' - fun.args: default parameters for the plotting function +#' +#' - descr: Plot description +#' +#' - note: Short note/description of the function for displaying in ui and docs +#' +#' - primary.type: Primary variable data type (see [data_type]) +#' +#' - base: holds a list of parameters for plot input fields generation +#' Secondary and tertiary variable input fields are mandatory. +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' available_plots() |> str() +available_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Additional variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ), + list( + id = "reverse", + type = "select_input", + label = i18n$t("Reverse colors"), + choices = c(yes = TRUE, no = FALSE) + ) + ), + advanced = list() + ######### + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("datatime", "continuous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = TRUE, + maxItems = 4 + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = TRUE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ) + ) +} + +# Helper function to create input elements dynamically +create_input_element <- function(params, ns, input_id) { + # Add the namespaced inputId to the arguments + params$inputId <- ns(input_id) + + # Map input types to Shiny functions + input_function <- switch( + params$type, + "numeric_input" = shiny::numericInput, + "select_input" = shiny::selectInput, + "checkbox_input" = shiny::checkboxInput, + "slider_input" = shiny::sliderInput, + "text_input" = shiny::textInput, + "select_variables" = selectPlotVariables + ) + + params$type <- NULL + params$id <- NULL + + + # Call the function with all arguments + do.call(input_function, params) +} + +#' Wrapper for columnSelectInput +#' +selectPlotVariables <- function(data, + exclude = NULL, + allow_none = TRUE, + var_types, + ...) { + datar <- if (is.reactive(data)) { + data + } else { + reactive(data) + } + + cols <- all_but(colnames(subset_types(datar(), var_types)), exclude) + + if (isTRUE(allow_none)) { + cols <- c("none", cols) + } + + params <- list(...) + + params$none_label <- i18n$t("No variable") + params$col_subset <- cols + + rlang::exec(columnSelectInput, !!!append_list(datar(), params, "data")) +} + + + +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + secondary.type = c("dichotomous"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous"), + secondary.extra = NULL + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data, source_list = supported_plots()) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- source_list |> + lapply(\(.x) { + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x) { + .x[match(data, descrs)] + })() +} + +#' Get the function parameters based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_input_params() +get_input_params <- function(data) { + descr <- available_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + available_plots() |> + (\(.x) { + .x[match(data, descr)] + })() +} + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + color.palette = color.palette, + ... + ) + + out <- do.call(type, modifyList(parameters, list(data = data))) + + code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") + + attr(out, "code") <- code + out +} + +#' Print label, and if missing print variable name for plots +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, + lineLength = 20, + force = FALSE) { + if (isTRUE(force)) { + ## This eats some letters when splitting a sentence... ?? + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' @param title panel title +#' @param guides passed to patchwork::wrap_plots() +#' @param axes passed to patchwork::wrap_plots() +#' @param axis_titles passed to patchwork::wrap_plots() +#' @param ... passed to patchwork::wrap_plots() +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, + tag_levels = NULL, + title = NULL, + axis.font.family = NULL, + guides = "collect", + axes = "collect", + axis_titles = "collect", + y.axis.percentage = FALSE, + ...) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x) { + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i) { + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes(percentage = y.axis.percentage) |> + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + if (!is.null(title)) { + out <- out + + patchwork::plot_annotation( + title = title, + theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) + ) + } + } else { + out <- data[[1]] + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + + if (!is.null(axis.font.family)) { + if (inherits(x = out, what = "patchwork")) { + out <- out & + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } else { + out <- out + + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } + } + + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE, + percentage = FALSE) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + p_out <- purrr::map(p, \(.x) { + out <- .x + if (isTRUE(x.axis)) { + out <- out + ggplot2::xlim(xr) + } + if (isTRUE(y.axis)) { + out <- out + ggplot2::ylim(yr) + } + out + }) + }) + + if (isTRUE(percentage)) { + lapply(p_out, \(.x) { + .x + + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x) { + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} From ab3df0eda657caf1ea9371a5dafeb9ac12c2b0dd Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 19:59:31 +0200 Subject: [PATCH 57/62] new renders --- DESCRIPTION | 3 ++- NAMESPACE | 2 ++ NEWS.md | 4 ++++ R/hosted_version.R | 2 +- R/plot_hbar.R | 2 +- inst/translations/translation_da.csv | 7 ------- inst/translations/translation_sw.csv | 7 ------- man/align_axes.Rd | 2 +- man/all_but.Rd | 2 +- man/available_plots.Rd | 27 +++++++++++++++++++++++++++ man/clean_common_axis.Rd | 2 +- man/data-plots.Rd | 19 ++++++++++--------- man/get_input_params.Rd | 27 +++++++++++++++++++++++++++ man/get_label.Rd | 2 +- man/get_plot_options.Rd | 2 +- man/line_break.Rd | 2 +- man/plot_euler_single.Rd | 2 +- man/possible_plots.Rd | 4 ++-- man/selectPlotVariables.Rd | 11 +++++++++++ man/subset_types.Rd | 2 +- man/supported_plots.Rd | 2 +- man/wrap_plot_list.Rd | 2 +- 22 files changed, 97 insertions(+), 38 deletions(-) create mode 100644 man/available_plots.Rd create mode 100644 man/get_input_params.Rd create mode 100644 man/selectPlotVariables.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 69564bc2..881625b1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.4.2 +Version: 26.5.1 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), @@ -118,6 +118,7 @@ Collate: 'launch_FreesearchR.R' 'missings-module.R' 'plot-download-module.R' + 'plot-helpers.R' 'plot_bar.R' 'plot_box.R' 'plot_euler.R' diff --git a/NAMESPACE b/NAMESPACE index 9e036c3f..947b97e8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ export(append_column) export(append_list) export(apply_labels) export(argsstring2list) +export(available_plots) export(baseline_table) export(class_icons) export(clean_common_axis) @@ -64,6 +65,7 @@ export(format_writer) export(generate_colors) export(get_data_packages) export(get_fun_options) +export(get_input_params) export(get_label) export(get_list_elements) export(get_plot_options) diff --git a/NEWS.md b/NEWS.md index 785ee46a..62106e48 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.5.1 + +*NEW* The visuals module has been restructured to allow for more advanced inputs, which will be added in the future. Basically a more future proof design allowing for more adjustments, while striving to keep the simplicity. Have fun! + # FreesearchR 26.4.2 Bug fixes and revised color choices. diff --git a/R/hosted_version.R b/R/hosted_version.R index 5a0a6546..b2178643 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260528' +hosted_version <- function()'v26.4.2-260530' diff --git a/R/plot_hbar.R b/R/plot_hbar.R index 1405678f..fc33b20d 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -76,7 +76,7 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse)) { + if (isTRUE(reverse) | reverse=="TRUE") { colors <- rev(colors) } diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 927131ba..50a8e93b 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -89,7 +89,6 @@ "and","og" "from each pair","fra hvert par" "Plot","Tegn" -"Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" "Plot width (mm)","Bredde af grafik (mm)" "File format","File format" @@ -97,12 +96,7 @@ "Select variable","Vælg variabel" "Response variable","Svarvariable" "Plot type","Type af grafik" -"Please select","Vælg" -"Additional variables","Yderligere variabler" -"Secondary variable","Sekundær variabel" "No variable","Ingen variabel" -"Grouping variable","Variabel til gruppering" -"No stratification","Ingen stratificering" "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 134ec155..cff599bb 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -89,7 +89,6 @@ "and","na" "from each pair","kutoka kwa kila jozi" "Plot","Kipande cha habari" -"Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" "Plot width (mm)","Upana wa kiwanja (mm)" "File format","Umbizo la faili" @@ -97,12 +96,7 @@ "Select variable","Chagua kigezo" "Response variable","Kigezo cha majibu" "Plot type","Aina ya kiwanja" -"Please select","Tafadhali chagua" -"Additional variables","Vigezo vya ziada" -"Secondary variable","Kigezo cha pili" "No variable","Hakuna kigezo" -"Grouping variable","Kigezo cha kuweka katika makundi" -"No stratification","Hakuna matabaka" "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" diff --git a/man/align_axes.Rd b/man/align_axes.Rd index 6d3e79e2..f403e1a7 100644 --- a/man/align_axes.Rd +++ b/man/align_axes.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{align_axes} \alias{align_axes} \title{Aligns axes between plots} diff --git a/man/all_but.Rd b/man/all_but.Rd index e2453d15..8dc3f46e 100644 --- a/man/all_but.Rd +++ b/man/all_but.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{all_but} \alias{all_but} \title{Select all from vector but} diff --git a/man/available_plots.Rd b/man/available_plots.Rd new file mode 100644 index 00000000..0ee1d5ac --- /dev/null +++ b/man/available_plots.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{available_plots} +\alias{available_plots} +\title{Implemented functions} +\usage{ +available_plots() +} +\value{ +list +} +\description{ +Library of supported functions. The list name and "descr" element should be +unique for each element on list. +\itemize{ +\item fun: the plotting function +\item fun.args: default parameters for the plotting function +\item descr: Plot description +\item note: Short note/description of the function for displaying in ui and docs +\item primary.type: Primary variable data type (see \link{data_type}) +\item base: holds a list of parameters for plot input fields generation +Secondary and tertiary variable input fields are mandatory. +} +} +\examples{ +available_plots() |> str() +} diff --git a/man/clean_common_axis.Rd b/man/clean_common_axis.Rd index 175053c9..67197d46 100644 --- a/man/clean_common_axis.Rd +++ b/man/clean_common_axis.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{clean_common_axis} \alias{clean_common_axis} \title{Extract and clean axis ranges} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 4222466f..e6d84e08 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R, R/plot_bar.R, R/plot_box.R, -% R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, R/plot_sankey.R, -% R/plot_scatter.R, R/plot_violin.R +% Please edit documentation in R/data_plots.R, R/plot-helpers.R, R/plot_bar.R, +% R/plot_box.R, R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, +% R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R \name{data-plots} \alias{data-plots} \alias{data_visuals_ui} @@ -22,7 +22,7 @@ \usage{ data_visuals_ui(id, tab_title = "Plots", ...) -data_visuals_server(id, data, palettes, ...) +data_visuals_server(id, data, palettes = color_choices(), ...) create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) @@ -50,9 +50,9 @@ plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...) plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") -plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis") +plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis", ...) plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) @@ -69,12 +69,13 @@ plot_sankey( default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing" + missing.level = "Missing", + ... ) -plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis", ...) } \arguments{ \item{id}{Module id. (Use 'ns("id")')} diff --git a/man/get_input_params.Rd b/man/get_input_params.Rd new file mode 100644 index 00000000..6766d73e --- /dev/null +++ b/man/get_input_params.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{get_input_params} +\alias{get_input_params} +\title{Get the function parameters based on the selected function description} +\usage{ +get_input_params(data) +} +\arguments{ +\item{data}{vector} +} +\value{ +list +} +\description{ +Get the function parameters based on the selected function description +} +\examples{ +ls <- mtcars |> + default_parsing() |> + dplyr::pull(mpg) |> + possible_plots() |> + (\(.x){ + .x[[1]] + })() |> + get_input_params() +} diff --git a/man/get_label.Rd b/man/get_label.Rd index 108fd372..c808209e 100644 --- a/man/get_label.Rd +++ b/man/get_label.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{get_label} \alias{get_label} \title{Print label, and if missing print variable name for plots} diff --git a/man/get_plot_options.Rd b/man/get_plot_options.Rd index 08c04496..83001d38 100644 --- a/man/get_plot_options.Rd +++ b/man/get_plot_options.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{get_plot_options} \alias{get_plot_options} \title{Get the function options based on the selected function description} diff --git a/man/line_break.Rd b/man/line_break.Rd index 65c987c7..d926556e 100644 --- a/man/line_break.Rd +++ b/man/line_break.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{line_break} \alias{line_break} \title{Line breaking at given number of characters for nicely plotting labels} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd index f481d5af..22d425c2 100644 --- a/man/plot_euler_single.Rd +++ b/man/plot_euler_single.Rd @@ -4,7 +4,7 @@ \alias{plot_euler_single} \title{Easily plot single euler diagrams} \usage{ -plot_euler_single(data, color.palette = "viridis") +plot_euler_single(data, color.palette = "viridis", ...) } \value{ ggplot2 object diff --git a/man/possible_plots.Rd b/man/possible_plots.Rd index 28c0b623..d1519e38 100644 --- a/man/possible_plots.Rd +++ b/man/possible_plots.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{possible_plots} \alias{possible_plots} \title{Get possible regression models} \usage{ -possible_plots(data) +possible_plots(data, source_list = supported_plots()) } \arguments{ \item{data}{data} diff --git a/man/selectPlotVariables.Rd b/man/selectPlotVariables.Rd new file mode 100644 index 00000000..f9e63e5d --- /dev/null +++ b/man/selectPlotVariables.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{selectPlotVariables} +\alias{selectPlotVariables} +\title{Wrapper for columnSelectInput} +\usage{ +selectPlotVariables(data, exclude = NULL, allow_none = TRUE, var_types, ...) +} +\description{ +Wrapper for columnSelectInput +} diff --git a/man/subset_types.Rd b/man/subset_types.Rd index 61fced5e..a33e1561 100644 --- a/man/subset_types.Rd +++ b/man/subset_types.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{subset_types} \alias{subset_types} \title{Easily subset by data type function} diff --git a/man/supported_plots.Rd b/man/supported_plots.Rd index c91ad753..caa250e3 100644 --- a/man/supported_plots.Rd +++ b/man/supported_plots.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{supported_plots} \alias{supported_plots} \title{Implemented functions} diff --git a/man/wrap_plot_list.Rd b/man/wrap_plot_list.Rd index 40cf0ba1..dcf1ae64 100644 --- a/man/wrap_plot_list.Rd +++ b/man/wrap_plot_list.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{wrap_plot_list} \alias{wrap_plot_list} \title{Wrapping} From bcc490535445d9f9fecbc2521e9faf1df5cecf52 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 20:00:42 +0200 Subject: [PATCH 58/62] adds --- .Rbuildignore | 2 ++ .gitignore | 1 + 2 files changed, 3 insertions(+) diff --git a/.Rbuildignore b/.Rbuildignore index 94927477..a0e3635f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,5 @@ ^app*$ ^page$ ^demo$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index ce227491..25eb7609 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ app page demo visuals +.positai From 1793a2650f38835ed2b5c0f15317e3790fdf6962 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:22:27 +0200 Subject: [PATCH 59/62] updated links --- R/data_plots.R | 27 +++++++++++++++++++++++---- R/ui_elements.R | 4 ++-- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index 41edfb20..b9e84c85 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -41,6 +41,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), + shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), shiny::uiOutput(outputId = ns("tertiary")) ), @@ -102,14 +103,14 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::plotOutput(ns("plot"), height = "65vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -193,7 +194,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h4(i18n$t("Plot type")), + label = shiny::h5(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) @@ -362,7 +363,25 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { if (!is.null(rv$plot)) { rv$plot } else { - return(NULL) + # Create a placeholder plot with instructions using ggplot2 + ggplot2::ggplot() + + ggplot2::annotate( + "text", + x = 0.5, + y = 0.5, + label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), + size = 5, + color = "gray50", + lineheight = 0.8 + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + + ggplot2::theme( + panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white") + ) + # return(NULL) } }) diff --git a/R/ui_elements.R b/R/ui_elements.R index 6686879d..b08d5152 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -247,7 +247,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -694,7 +694,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/", + href = "https://freesearchr.github.io/FreesearchR-knowledge/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", From 5e85902d4b4367b3de0c3d7ef4d04ec2692bedea Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:22:55 +0200 Subject: [PATCH 60/62] version ready for merging --- DESCRIPTION | 2 +- NEWS.md | 2 +- R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/plot-helpers.R | 2 +- inst/translations/translation_da.csv | 10 ++++++++++ inst/translations/translation_sw.csv | 10 ++++++++++ 7 files changed, 25 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 881625b1..cc854ec0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.5.1 +Version: 26.6.1 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 62106e48..ce86f7a7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# FreesearchR 26.5.1 +# FreesearchR 26.6.1 *NEW* The visuals module has been restructured to allow for more advanced inputs, which will be added in the future. Basically a more future proof design allowing for more adjustments, while striving to keep the simplicity. Have fun! diff --git a/R/app_version.R b/R/app_version.R index 2cbd2cc4..bce90462 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.4.2' +app_version <- function()'26.6.1' diff --git a/R/hosted_version.R b/R/hosted_version.R index b2178643..27a50899 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260530' +hosted_version <- function()'v26.6.1' diff --git a/R/plot-helpers.R b/R/plot-helpers.R index 361e15ef..5b4ae981 100644 --- a/R/plot-helpers.R +++ b/R/plot-helpers.R @@ -70,7 +70,7 @@ available_plots <- function() { id = "secondary", type = "select_variables", var_types = c("dichotomous", "categorical"), - allow_none = FALSE, + allow_none = TRUE, # inputId = "sec", label = i18n$t("Secondary variable"), multiple = FALSE diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 50a8e93b..8b230b1c 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -313,3 +313,13 @@ "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." "The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." +"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." +"Define plot","Define plot" +"Choose color palette","Choose color palette" +"Additional variable","Additional variable" +"Grouping variable","Grouping variable" +"Secondary variable","Secondary variable" +"Reverse colors","Reverse colors" +"Plot survey results","Plot survey results" +"Additional variables","Additional variables" +"Other variables","Other variables" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index cff599bb..4b0d628a 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -313,3 +313,13 @@ "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." "The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." +"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." +"Define plot","Define plot" +"Choose color palette","Choose color palette" +"Additional variable","Additional variable" +"Grouping variable","Grouping variable" +"Secondary variable","Secondary variable" +"Reverse colors","Reverse colors" +"Plot survey results","Plot survey results" +"Additional variables","Additional variables" +"Other variables","Other variables" From e8307d3a2e267090adad4da7916a56fd908964e3 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:25:50 +0200 Subject: [PATCH 61/62] feat: major restructuring of the visuals module --- inst/translations/translation_da.csv | 1 + inst/translations/translation_sw.csv | 1 + 2 files changed, 2 insertions(+) diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 8b230b1c..517df60d 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -323,3 +323,4 @@ "Plot survey results","Plot survey results" "Additional variables","Additional variables" "Other variables","Other variables" +"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 4b0d628a..c56e9549 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -323,3 +323,4 @@ "Plot survey results","Plot survey results" "Additional variables","Additional variables" "Other variables","Other variables" +"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" From acbed08a0db5bd381a165951efc9f5b95f7e82e0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:35:12 +0200 Subject: [PATCH 62/62] new version ready for release --- CITATION.cff | 2 +- R/sysdata.rda | Bin 2691 -> 2796 bytes SESSION.md | 43 +- app_docker/app.R | 1722 +++++++++++++------- app_docker/translations/translation_da.csv | 18 +- app_docker/translations/translation_sw.csv | 18 +- inst/apps/FreesearchR/app.R | 1722 +++++++++++++------- 7 files changed, 2237 insertions(+), 1288 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 86c9ebe0..9d517f96 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.4.2 +version: 26.6.1 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/R/sysdata.rda b/R/sysdata.rda index c56ca282b6b07bc77e3fda961193f62c47cf5e58..1829eab4c6b894f7f0b020e1f38304579981f4bd 100644 GIT binary patch literal 2796 zcmVB^SQH>P6wHkS3Zm4FMSiJxnzjH8T*J4^T7)MusCygH-UE zG))CIr=*^zf}2$HQ5p|OF#s4wh7f4e(qXCL2&!sm0LWwpfB(OK$ESd3fRo*nj;z^_05$>2KG)qhVvD13yD`q&;FBMKZ7LDCi3zS?A{4yXl zTiv@BO)bojHm6B*6<(DZoU*x;Ze7#0C|$I;pd#_e8|O!Tg*F$3V!vLma8lSXbmY6R zJf>u8s=E@nk=jdQk}hdp#;_&LaWpZj6;(Y-_W!#tvnfw|lc^bztj#;Ey2zs}&C|>O z&eVV}VKSPjHZ8m1FJrhYx7wO}&0U)%t`g=k66Tswk0P$l3w3ceiaMASOEc5Fot7}= z;E=b-AG2m^NhMp&JR=u=I4h~(X38AO-R^UHg$&}GD4L`YAlR3ico?h2R5y5eM%a09 zytw6N?BrA^oP*LPTZI6ftaZ zwmpA`z03afvIHlhcKT`xBE({-h@glf3ltTIsxeU*q)}92BNU8cih>BD5kX+FQIQp5 z2#N|ZQBLn?$LrUnzUrrE#)=>)^;ss(+kUHkE%4E~P!@8us)(6M#P}Ln0f&kLe z+q=>%8U~QVQFW!7c3Up{8>l9xmut&L*-ki^a@4IGH0Il804^AU+|?FF$kaLz;H(&{ zWKJ5Q@bcexZ8*xA#~GSvY>NX~jI{Tag=L6Qgl@OKxo0fW;|N+*7MzY8F7bm>?Q@xk z9#=V;Gix_d!GyLs%ihlH7+aYcXN7QVr+W%hue)SL**DBPCUj8fRvy)~o4m@W&_Rb8 zd#h9ifC4InkVqgst1w|&cWzM?A4I9Q4$Up@Mp$QgW^HMuYS(8R<*I2I>sg$x`71X< zhKew}T2qx&Mzx?NB(<~x5i3YVMUq+4sJ3~TN~oL1Ztd0raSKth8%Y>~Cw$wMIBRvF z^+=G8i6|69RlCL}%H_q}&1$r|2mp~Jfo#fGTIS}a`;=52lTnE;c|brdGD{@jBCSGM zK=*^iv})w}CHF^HARJ}S7883AghYZWBp}EHM34-~B*7bNkboHsXuwu^qXtiT_p$O) zsxin3LXy!avRIQc;uRI|e2|df2%$g6+{dXRLfdsj+0D0RuZ7)Cyl;vQRvKV z!zhj=S%s_%XsR0}Y86>3AajR2VNEiS$^M)&Lf(YTNn$A!CMG6ZD2g8odEg1$X#tEN zs}Ny1xXc3!MS*3Y&u+sFy}h~Jo`jWI*27)i|8Kw(MXeeoZMzacY7R>Z$}*xQXv7>E z#e+-|bU;ER@R9WJ>Cj}Vfg^qt#$$np(x3*2svhdnwk#V8Efl3BXe&wu5mOBW%TOy; zwA-@9Rujy<2{O_hEaJF|R1m%WU}^%2HLPJpv@FsmYMo39#AE%N#0GM=bgPt}M|+xX zgR?@KYKQ`m+R-6acW)UxEQe@;2+ZtRz?>n@n8{xQn_}2ht)*3FWF{~plqE?b!ZKh1 zCoNet{Ex4yY3fcBTH&izwWYNzMUaw~4hABTQOn-{2XB`yUYl@fQ;guWwX0NYr7uok zu978s8PhG-D?3Sen&oX(rNIfQq)kw~Tz0!{Yf+_bltr{sDJHzOO`fCa>3~8gJC%+4 za4H$VfC2(28nO+CTClugW^+RYEDOu0SvpZDf@!mQ_RO^G-IE#uI+B-X@9p&rUOrx` z0z0|2&=KAFarLS#w)Mp{TaQlPc&1@?L9Jpu+dF=*fZgF4uJ_K0`1n3DL0?M|!;UNs zSR6?BcF3fUJJ-xa(;qKa7A@|gWG~h04@ihB>FE0TvBeQ`=WK=6i=-9p_a@y2P-|jCKyILCE9hJ?336-cbM2G(_It?n0C%6MCt^Jguswq zCksPX#5YKI?i-CluGI)18Ix zS7Vel5!QDy_4>5E&b{u29-N;+gGWzVzJ;#GRX|Ua!)v&SA=m2lI*PkB+)xPI2^KL^ zqnMCjl;oi_A;c&h1cxJWNS?&Dj{5%nR*8U)CwX-hZf)IiI`x7q>`HGIWIodv=u^l@ zNNaBFx3*o_hv-ivcG8*pjpgBV4$6ug-O94&*=DK1c+Q4QT-NKxpp+{;wTWUw<{vCu zthvEeuC(Ek5H_uClY04(QYhcx!y#!4{7L{Fv@ZcWS2xr#tvcH_P7t9sI zk&3OvDlxpQ`wUNBDDuE%K(%Lx9N^Brggsi(JL+qaZj)=G@FGA2g==6rZ8a>GO|PgItW5|#sW7< zH!ckcLfXohy;`Fgl57czHqr&hq$}j-sr1@ViteQi#$zH5q?p_m7a`WaB8Y|ds%|^q z#0y1$5HnsolsE{!9s7qy8R~rmDq3sGm}oJ|sq^LTa<{tY#}l5IH7rJrmK0zg5?3N@ yUSgo#eY1QB36f^G;_R-jg6m3lE#=d&ejtBj29Nf2j75h{%rqecelQ|E%A~d;b5AJcs<3w{OgNTpvXK zGE}l--wQtPb<&_+O%T3(j`F;L6-`=%fh8|197)z)Vzumja1Bva$&`Ch+xd- zR8XR2W46RXe}r!4D^n8oDQ@J`nwX@jjMgo=1ZBfwBE0WYlf~m6bdOK7>-WQ#4I?6M zS{~-%b+=xPz{VukH3m=2IqnG;#GoAZiO#97-|*Wjx6pi|o*e^XM;WIqv%?l|)Z-tN zX+;I_DXFTHu6G|2_(mYH>8UjJx?61xTMZ06w4o_+@GGzQwl`pJ7I1JzSocBo zXO1(}f?gb#nYdxvt>wJSvt8Z#xUI5d^6jd0asDi9fMj(oc0Hje6P*G8ctX3*1+u7#y&j%G$ z@y|^e7sAw&Zf~!S-yaxg;HV2Zw5o`l?&hod#@8i(9jUlLka-2gpldc46+KR zF}tZ#B+`{C>=Q^!NQi`yXd;&BITmK+5Xrp6w8U18ObZv+|cXst?;;Y`qGU5eftS5zq zsN&Yvxg?TOBLP#;V3XW^%zWgkjBo_9!qF(Cu_k52Dkt?J4Cn=rgCGQ8c$orrvPgAg zkl8#*iHtn9Lb1wEGt17hotay3$|m&Ti!@RVs-cN(3aph7JJY=wQ%u$n)c0K&Lf*{8 znGr~#F)=dP@Zm)d1@90O#MlEF0ahS{>(?+0EfxiqgFTuUZ`s+Wv68FbPbCZ6+u`mB zqSlQ{*JL0#gOb9sjHroPF$V^qG{Gli20hzY1Y6!1W5QXrdXamat(s zES5smmJ(VN2@d6fNJ)Ix@$Y1d2=`c9V0anLaZ<5aeQdyBD5Iva3N4{cF+2CjU{)hP zr7uV*Coc($l%I3O)=oCiruT71NT8(4NF^k7a8NCP;z0&A!$;$O%9ckAD+ZIhy_UkI zZ7QoQfGA4BMF`1~LKCK}non0LkDi>SwaZ1S($%Gj2`NFq#X*QYzq82ak9VINnrTG6 z4z#tZQKed2MR9^xyw41@*A{jqQkv-kO&B0suvLAd%%EUD3!RMi+qG(Cs4}vv6hQOZ~K_m=ll8e;$67q?j)C;eo%` zR^;WU7VtDg>69#Yo4P3&GKkTNMOw>$mTRE}Dg>vQTG$+iZTCzcq+pebI_yMTZ`l_w z9~rX}-XG2h=fUn}uGNXLQ7-|G5W1|fMWACM=U!SAHV#7uRJ~CQ-2@F%I&5?xH zbO=4u5DzClJ;?>c;!@FDt>nWlfJi$I@=BT*epPz7g|4B#nb#&K9W{oC_nu}9mT-s^ z+A^3>_h5cFMx=k(g?r|rjyl<3q{MoB102Hvp2{4u7y-k9q!_qJz8_Xj)qX(XazF6#-pCtG0$WKvHZ#H<6XWi5HJ-JPq!L2%d z#(=#S2|O$hPq|QXBD5h07+(8QqAbkFy$7NTj!Z5;IR(bMVz`a|bD)F`QP;ofs2>aj zNvfXOXPK{?eZ?jYL^dLe+a`9C3=?QZSixZVh(Vl*$?Qt!*52>g!x11Z+v$QHa@IBQ3VJTa!ZX`OvSm$+B2 zZ_iVUMJ?k=Nb5~B zz8I~sV7!o2(_{GK0tBJ>OeG;!S-#fOm37%+$^A)LOK@#V2!#j+^S30%pi?rL!~s2m zHW7(JvkPiev=Pf?Q-=&MsSU}4I%dp|YVPly7GP4nxY)<(Ns$QH=jM=gt@bN2!D{g3 zPlGTQuz{O&=~2`$uby67bbQoSLTyd;)v(>aDz)wUqP~dZP356V%HED<&!W3C6y8g6 xYPppojg?UulPDzBX9mF_(JD$TTFbLh_ks107Al1d3OmQ*F64@Ep&?Xj+0M%_{yP8w diff --git a/SESSION.md b/SESSION.md index 1e301770..55c29962 100644 --- a/SESSION.md +++ b/SESSION.md @@ -1,21 +1,21 @@ -------------------------------------------------------------------------------- -------------------------------- R environment --------------------------------- -------------------------------------------------------------------------------- -|setting |value | -|:-----------|:------------------------------------------| -|version |R version 4.5.2 (2025-10-31) | -|os |macOS Tahoe 26.4.1 | -|system |aarch64, darwin20 | -|ui |RStudio | -|language |(EN) | -|collate |en_US.UTF-8 | -|ctype |en_US.UTF-8 | -|tz |Europe/Copenhagen | -|date |2026-04-10 | -|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.4.2.260410 | +|setting |value | +|:-----------|:--------------------------------------------------------------------------------------------------| +|version |R version 4.5.2 (2025-10-31) | +|os |macOS Tahoe 26.5 | +|system |aarch64, darwin20 | +|ui |RStudio | +|language |(EN) | +|collate |en_US.UTF-8 | +|ctype |en_US.UTF-8 | +|tz |Europe/Copenhagen | +|date |2026-06-01 | +|rstudio |2026.04.0+526 Globemaster Allium (desktop) | +|pandoc |3.8.3 @ /Applications/RStudio.app/Contents/Resources/app/quarto/bin/tools/aarch64/ (via rmarkdown) | +|quarto |1.9.37 @ /usr/local/bin/quarto | +|FreesearchR |26.6.1.260601 | -------------------------------------------------------------------------------- @@ -26,6 +26,8 @@ |apexcharter |0.4.5 |2026-01-07 |CRAN (R 4.5.2) | |askpass |1.2.1 |2024-10-04 |CRAN (R 4.5.0) | |assertthat |0.2.1 |2019-03-21 |CRAN (R 4.5.0) | +|attachment |0.4.5 |2025-03-14 |CRAN (R 4.5.0) | +|attempt |0.3.1 |2020-05-03 |CRAN (R 4.5.0) | |backports |1.5.0 |2024-05-23 |CRAN (R 4.5.0) | |base64enc |0.1-6 |2026-02-02 |CRAN (R 4.5.2) | |bayestestR |0.17.0 |2025-08-29 |CRAN (R 4.5.0) | @@ -44,6 +46,7 @@ |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | +|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | @@ -61,6 +64,7 @@ |devtools |2.4.6 |2025-10-03 |CRAN (R 4.5.0) | |DHARMa |0.4.7 |2024-10-18 |CRAN (R 4.5.0) | |digest |0.6.39 |2025-11-19 |CRAN (R 4.5.2) | +|dockerfiler |0.2.5 |2025-05-07 |CRAN (R 4.5.0) | |doParallel |1.0.17 |2022-02-07 |CRAN (R 4.5.0) | |dplyr |1.2.0 |2026-02-03 |CRAN (R 4.5.2) | |DT |0.34.0 |2025-09-02 |CRAN (R 4.5.0) | @@ -83,7 +87,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.4.2 |NA |NA | +|FreesearchR |26.6.1 |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) | @@ -93,7 +97,7 @@ |ggplot2 |4.0.2 |2026-02-03 |CRAN (R 4.5.2) | |ggridges |0.5.7 |2025-08-27 |CRAN (R 4.5.0) | |ggstats |0.13.0 |2026-03-06 |CRAN (R 4.5.2) | -|glue |1.8.0 |2024-09-30 |CRAN (R 4.5.0) | +|glue |1.8.0 |2024-09-30 |CRAN (R 4.5.2) | |gridExtra |2.3 |2017-09-09 |CRAN (R 4.5.0) | |gt |1.3.0 |2026-01-22 |CRAN (R 4.5.2) | |gtable |0.3.6 |2024-10-25 |CRAN (R 4.5.0) | @@ -124,6 +128,7 @@ |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | |Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.0) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | +|mgcv |1.9-4 |2025-11-07 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | |mvtnorm |1.3-2 |2024-11-04 |CRAN (R 4.5.2) | @@ -136,6 +141,7 @@ |openssl |2.3.5 |2026-02-26 |CRAN (R 4.5.2) | |openxlsx2 |1.25 |2026-03-07 |CRAN (R 4.5.2) | |otel |0.2.0 |2025-08-29 |CRAN (R 4.5.0) | +|pak |0.9.2 |2025-12-22 |CRAN (R 4.5.2) | |parameters |0.28.3 |2025-11-25 |CRAN (R 4.5.2) | |patchwork |1.3.2 |2025-08-25 |CRAN (R 4.5.0) | |pbmcapply |1.5.1 |2022-04-28 |CRAN (R 4.5.0) | @@ -147,6 +153,7 @@ |pkgload |1.5.0 |2026-02-03 |CRAN (R 4.5.2) | |plyr |1.8.9 |2023-10-02 |CRAN (R 4.5.0) | |polyclip |1.10-7 |2024-07-23 |CRAN (R 4.5.0) | +|polylabelr |1.0.0 |2026-01-19 |CRAN (R 4.5.2) | |pracma |2.4.6 |2025-10-22 |CRAN (R 4.5.0) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.5.0) | |promises |1.5.0 |2025-11-01 |CRAN (R 4.5.0) | @@ -191,6 +198,7 @@ |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) | +|shiny2docker |0.0.3 |2025-06-28 |CRAN (R 4.5.0) | |shinybusy |0.3.3 |2024-03-09 |CRAN (R 4.5.0) | |shinyjs |2.1.1 |2026-01-15 |CRAN (R 4.5.2) | |shinyTime |1.0.3 |2022-08-19 |CRAN (R 4.5.0) | @@ -223,4 +231,5 @@ |xml2 |1.5.2 |2026-01-17 |CRAN (R 4.5.2) | |xtable |1.8-8 |2026-02-22 |CRAN (R 4.5.2) | |yaml |2.3.12 |2025-12-10 |CRAN (R 4.5.2) | +|yesno |0.1.3 |2024-07-26 |CRAN (R 4.5.0) | |zip |2.3.3 |2025-05-13 |CRAN (R 4.5.0) | diff --git a/app_docker/app.R b/app_docker/app.R index 4dd38592..9eb30b87 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprUCGcI/file4761ae70bf7.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpAe8F1F/file150d92b07c28b.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.4.2' +app_version <- function()'26.6.1' ######## @@ -2151,12 +2151,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { list( bslib::layout_sidebar( sidebar = bslib::sidebar( + shiny::actionButton( + inputId = ns("act_plot"), + label = i18n$t("Plot"), + width = "100%", + icon = phosphoricons::ph("paint-brush", weight = "bold"), + # icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText( + i18n$t('Adjust plot input and settings below, then press "Plot".') + ), bslib::accordion( id = "acc_plot", multiple = FALSE, bslib::accordion_panel( value = "acc_pan_plot", - title = "Create plot", + title = i18n$t("Define plot"), icon = phosphoricons::ph("chart-line"), # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), @@ -2167,19 +2178,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), + shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), shiny::uiOutput(outputId = ns("color_palette")), - shiny::br(), - shiny::actionButton( - inputId = ns("act_plot"), - label = i18n$t("Plot"), - width = "100%", - icon = phosphoricons::ph("paint-brush",weight = "bold"), - # icon = shiny::icon("palette"), - disabled = FALSE - ), - shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) + shiny::uiOutput(outputId = ns("basic_parameters")), ), bslib::accordion_panel( value = "acc_pan_download", @@ -2232,14 +2240,14 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::plotOutput(ns("plot"), height = "65vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -2256,10 +2264,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, - data, - palettes, - ...) { +data_visuals_server <- function(id, data, palettes = color_choices(), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -2311,69 +2316,99 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data) + plots <- possible_plots(data = plot_data, source_list = available_plots()) - plots_named <- get_plot_options(plots) |> + plots_named <- get_input_params(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x) { + # stats::setNames(.x$descr, .x$note) + # }) + vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h4(i18n$t("Plot type")), + label = shiny::h5(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_plot_options(input$type) |> purrr::pluck(1) + get_input_params(input$type) |> purrr::pluck(1) + # get_plot_options(input$type) |> purrr::pluck(1) }) + + ### Include two additional variable inputs output$secondary <- shiny::renderUI({ shiny::req(input$type) - cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - subset_types(data(), rv$plot.params()[["secondary.type"]]) - ), input$primary)) + # Get the plot function name + base_params <- rv$plot.params()[["base"]] - columnSelectInput( - inputId = ns("secondary"), - data = data, - selected = cols[1], - placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) - i18n$t("Additional variables") - else - i18n$t("Secondary variable"), - multiple = rv$plot.params()[["secondary.multi"]], - maxItems = rv$plot.params()[["secondary.max"]], - col_subset = cols, - none_label = i18n$t("No variable") + filtered_params <- base_params[sapply(base_params, function(params) { + params$id %in% "secondary" + })][[1]] + + filtered_params$exclude <- input$primary + + create_input_element( + input_id = "secondary", + ns = ns, + params = append_list(data(), filtered_params, "data") ) + }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - columnSelectInput( - inputId = ns("tertiary"), - data = data, - placeholder = i18n$t("Please select"), - label = i18n$t("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 = i18n$t("No stratification") + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + params$id %in% "tertiary" + })][[1]] + + filtered_params$exclude <- c(input$primary, input$secondary) + + create_input_element( + input_id = "tertiary", + ns = ns, + params = append_list(data(), filtered_params, "data") ) }) + + ### Generating additional parameter inputs if any specified + output$basic_parameters <- renderUI({ + req(input$type, rv$plot.params) + + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + !params$id %in% c("secondary", "tertiary") + })] + + + # Create UI elements for base parameters + base_inputs <- lapply(filtered_params, function(params) { + input_id <- paste0("base_", params$id) + params$id <- NULL + if (params$type %in% "select_variables") { + params$data <- data() + } + + create_input_element(params, ns, input_id) + }) + tagList(base_inputs) + + }) + ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) @@ -2387,19 +2422,49 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ + # Get all input values with prefixes + base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] + # advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] + + # Remove the prefix from names + names(base_inputs) <- gsub("^base_", "", names(base_inputs)) + # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) + + base_inputs <- c(base_inputs, + list(color.palette = input$color_palette)) + + # If any of the specified parameters are NULL/missing, the settings + # accordion/panel was never opened, and they can be ignored, as + # default settings will the be used. + if (any(sapply(base_inputs, is.null))) { + dynamic_params <- list() + } else { + dynamic_params <- base_inputs + } + + # Build parameters for plotting function parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, sec = input$secondary, - ter = input$tertiary, - color.palette = input$color_palette + ter = input$tertiary ) + parameters <- modifyList(parameters, dynamic_params) + ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included if (!is.null(rv$plot.params()[["fun.args"]])) { - parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + default_params <- rv$plot.params()[["fun.args"]] + + ## Ensure not to overwrite user defined parameters are overwritten + ## This allows to define default parameters. + ## + ## This will create a strange edge case, where the plot looks in + ## one way, when plotted initially, but may change, when the settings + ## accordion is opened. Problem for future me. Really mostly an edge case. + parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -2435,7 +2500,25 @@ data_visuals_server <- function(id, if (!is.null(rv$plot)) { rv$plot } else { - return(NULL) + # Create a placeholder plot with instructions using ggplot2 + ggplot2::ggplot() + + ggplot2::annotate( + "text", + x = 0.5, + y = 0.5, + label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), + size = 5, + color = "gray50", + lineheight = 0.8 + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + + ggplot2::theme( + panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white") + ) + # return(NULL) } }) @@ -2480,506 +2563,6 @@ data_visuals_server <- function(id, ) } -#' Select all from vector but -#' -#' @param data vector -#' @param ... exclude -#' -#' @returns vector -#' @export -#' -#' @examples -#' all_but(1:10, c(2, 3), 11, 5) -all_but <- function(data, ...) { - data[!data %in% c(...)] -} - -#' Easily subset by data type function -#' -#' @param data data -#' @param types desired types -#' @param type.fun function to get type. Default is outcome_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) -#' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { - data[sapply(data, type.fun) %in% types] -} - - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - descr: Plot description -#' -#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.extra: "none" or NULL to have option to choose none. -#' -#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' supported_plots() |> str() -supported_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = "none", - tertiary.type = c("dichotomous", "categorical") - ), - # plot_ridge = list( - # descr = "Ridge plot", - # note = "An alternative option to visualise data distribution", - # primary.type = "continuous", - # secondary.type = c("dichotomous" ,"categorical"), - # tertiary.type = c("dichotomous" ,"categorical"), - # secondary.extra = NULL - # ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical") - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - secondary.type = c("datatime", "continuous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - secondary.type = c("dichotomous"), - secondary.multi = TRUE, - secondary.max = 4, - tertiary.type = c("dichotomous"), - secondary.extra = NULL - ), - plot_euler = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t( - "Plot survey results" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = TRUE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ) - ) -} - -#' Get possible regression models -#' -#' @param data data -#' -#' @returns character vector -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' dplyr::pull("cyl") |> -#' possible_plots() -#' -#' mtcars |> -#' default_parsing() |> -#' dplyr::select("mpg") |> -#' possible_plots() -possible_plots <- function(data) { - # browser() - # data <- if (is.reactive(data)) data() else data - if (is.data.frame(data)) { - data <- data[[1]] - } - - type <- data_type(data) - - if (type == "unknown") { - out <- type - } else { - out <- supported_plots() |> - lapply(\(.x) { - if (type %in% .x$primary.type) { - .x$descr - } - }) |> - unlist() - } - unname(out) -} - -#' Get the function options based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_plot_options() -get_plot_options <- function(data) { - descrs <- supported_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - supported_plots() |> - (\(.x) { - .x[match(data, descrs)] - })() -} - - - -#' Wrapper to create plot based on provided type -#' -#' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable -#' @param type plot type (derived from possible_plots() and matches custom function) -#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. -#' @param ... ignored for now -#' -#' @name data-plots -#' -#' @returns ggplot2 object -#' @export -#' -#' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, - type, - pri, - sec, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(sec)) { - if (!any(sec %in% names(data))) { - sec <- NULL - } - } - - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } - } - - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - color.palette = color.palette, - ... - ) - - out <- do.call(type, modifyList(parameters, list(data = data))) - - code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") - - attr(out, "code") <- code - out -} - -#' Print label, and if missing print variable name for plots -#' -#' @param data vector or data frame -#' @param var variable name. Optional. -#' -#' @returns character string -#' @export -#' -#' @examples -#' mtcars |> get_label(var = "mpg") -#' mtcars |> get_label() -#' mtcars$mpg |> get_label() -#' gtsummary::trial |> get_label(var = "trt") -#' gtsummary::trial$trt |> get_label() -#' 1:10 |> get_label() -get_label <- function(data, var = NULL) { - # data <- if (is.reactive(data)) data() else data - if (!is.null(var) & is.data.frame(data)) { - data <- data[[var]] - } - out <- REDCapCAST::get_attr(data = data, attr = "label") - if (is.na(out)) { - if (is.null(var)) { - out <- deparse(substitute(data)) - } else { - if (is.symbol(var)) { - out <- gsub('\"', "", deparse(substitute(var))) - } else { - out <- var - } - } - } - out -} - - -#' Line breaking at given number of characters for nicely plotting labels -#' -#' @param data string -#' @param lineLength maximum line length -#' @param fixed flag to force split at exactly the value given in lineLength. -#' Default is FALSE, only splitting at spaces. -#' -#' @returns character string -#' @export -#' -#' @examples -#' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, - lineLength = 20, - force = FALSE) { - if (isTRUE(force)) { - ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), - "\\1\n", - data) - } else { - paste(strwrap(data, lineLength), collapse = "\n") - } - ## https://stackoverflow.com/a/29847221 -} - - -#' Wrapping -#' -#' @param data list of ggplot2 objects -#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL -#' @param title panel title -#' @param guides passed to patchwork::wrap_plots() -#' @param axes passed to patchwork::wrap_plots() -#' @param axis_titles passed to patchwork::wrap_plots() -#' @param ... passed to patchwork::wrap_plots() -#' -#' @returns list of ggplot2 objects -#' @export -#' -wrap_plot_list <- function(data, - tag_levels = NULL, - title = NULL, - axis.font.family = NULL, - guides = "collect", - axes = "collect", - axis_titles = "collect", - y.axis.percentage = FALSE, - ...) { - if (ggplot2::is_ggplot(data[[1]])) { - if (length(data) > 1) { - out <- data |> - (\(.x) { - if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i) { - .y + ggplot2::ggtitle(.i) - }) - } else { - .x - } - })() |> - align_axes(percentage=y.axis.percentage) |> - patchwork::wrap_plots(guides = guides, - axes = axes, - axis_titles = axis_titles, - ...) - if (!is.null(tag_levels)) { - out <- out + patchwork::plot_annotation(tag_levels = tag_levels) - } - if (!is.null(title)) { - out <- out + - patchwork::plot_annotation( - title = title, - theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) - ) - } - } else { - out <- data[[1]] - } - } else { - cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") - } - - if (!is.null(axis.font.family)) { - if (inherits(x = out, what = "patchwork")) { - out <- out & - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } else { - out <- out + - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } - } - - out -} - - -#' Aligns axes between plots -#' -#' @param ... ggplot2 objects or list of ggplot2 objects -#' -#' @returns list of ggplot2 objects -#' @export -#' -align_axes <- function(..., - x.axis = TRUE, - y.axis = TRUE, - percentage = FALSE) { - # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object - # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 - if (ggplot2::is_ggplot(..1)) { - ## Assumes list of ggplots - p <- list(...) - } else if (is.list(..1)) { - ## Assumes list with list of ggplots - p <- ..1 - } else { - cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") - } - - yr <- clean_common_axis(p, "y") - - xr <- clean_common_axis(p, "x") - - suppressWarnings({ - p_out <- purrr::map(p, \(.x) { - out <- .x - if (isTRUE(x.axis)) { - out <- out + ggplot2::xlim(xr) - } - if (isTRUE(y.axis)) { - out <- out + ggplot2::ylim(yr) - } - out - }) - }) - - if(isTRUE(percentage)){ - lapply(p_out,\(.x){ - .x+ - ggplot2::scale_y_continuous(labels = scales::percent) - }) - } else { - p_out - } -} - -#' Extract and clean axis ranges -#' -#' @param p plot -#' @param axis axis. x or y. -#' -#' @returns vector -#' @export -#' -clean_common_axis <- function(p, axis) { - purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> - unlist() |> - (\(.x) { - if (is.numeric(.x)) { - range(.x) - } else { - as.character(.x) - } - })() |> - unique() -} - ######## #### Current file: /Users/au301842/FreesearchR/R//data-summary.R @@ -3845,38 +3428,25 @@ footer_ui <- function(i18n) { #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { + + # --- Input validation ------------------------------------------------------- + if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { stop("`n` must be a single positive integer.") } + if (!is.function(palette) && (!is.character(palette) || length(palette) != 1)) { + stop("`palette` must be a single character string or a function.") + } - # Function passthrough — call directly with n and ... + # --- Function passthrough --------------------------------------------------- if (is.function(palette)) { return(palette(n, ...)) } - if (!is.character(palette) || length(palette) != 1) { - stop("`palette` must be a single character string or a function.") - } - - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { - stop("`n` must be a single positive integer.") - } - if (!is.character(palette) || length(palette) != 1) { - stop("`palette` must be a single character string.") - } - + # --- Named palette dispatch ------------------------------------------------- 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, ...) @@ -3896,35 +3466,42 @@ generate_colors <- function(n, palette = "viridis", ...) { } else if (palette_lower == "topo") { grDevices::topo.colors(n = n, ...) - } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { - max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] - fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() - base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) - grDevices::colorRampPalette(base_colors)(n) - - } else if (palette %in% grDevices::palette.pals()) { - grDevices::colorRampPalette(palette.colors(palette = palette))(n) - - } else if (palette %in% grDevices::hcl.pals()) { - grDevices::hcl.colors(n = n, palette = palette, ...) - } else { - message( - paste0( - "Unknown palette: '", - palette, - "'. ", - "Falling back to default R colors.\n", - "Available options:\n", - " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", - " grDevices : hcl, rainbow, heat, terrain, topo\n", - " grDevices HCL: use grDevices::hcl.pals() to see all options\n", - " grDevices : use grDevices::palette.pals() to see all options\n", - " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" - ) - ) - viridisLite::viridis(n = n, option = "viridis") - # grDevices::hcl.colors(n = n) + # Case-insensitive RColorBrewer lookup + brewer_names <- rownames(RColorBrewer::brewer.pal.info) + brewer_match <- brewer_names[match(palette_lower, tolower(brewer_names))] + + if (!is.na(brewer_match)) { + max_n <- RColorBrewer::brewer.pal.info[brewer_match, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = brewer_match) + grDevices::colorRampPalette(base_colors)(n) + + } else { + # Case-insensitive grDevices palette.pals() lookup + pal_names <- grDevices::palette.pals() + pal_match <- pal_names[match(palette_lower, tolower(pal_names))] + + if (!is.na(pal_match)) { + grDevices::colorRampPalette(grDevices::palette.colors(palette = pal_match))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + # Named HCL palettes (e.g. "Rocket", "Plasma") — distinct from viridisLite + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + warning( + "Unknown palette: '", palette, "'. Falling back to viridis.\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") + } + } } } @@ -4957,7 +4534,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.4.2-260410' +hosted_version <- function()'v26.6.1' ######## @@ -6971,14 +6548,14 @@ plot_bar <- function(data, sec = sec, style = style, max_level = max_level, - color.palette = color.palette + color.palette = color.palette, + ... ) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE, - ...) + y.axis.percentage = TRUE) } @@ -7099,11 +6676,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette + color.palette=color.palette, ... ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) } @@ -7297,7 +6874,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis") { +plot_euler_single <- function(data,color.palette="viridis", ...) { data |> ggeulerr(shape = "circle") + @@ -7340,13 +6917,15 @@ plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette + color.palette = color.palette, + ... ) } @@ -7399,7 +6978,7 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse)) { + if (isTRUE(reverse) | reverse=="TRUE") { colors <- rev(colors) } @@ -7456,7 +7035,8 @@ plot_likert <- function(data, pri, sec = NULL, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7633,7 +7213,8 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing") { + missing.level = "Missing", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7867,7 +7448,7 @@ color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -7904,7 +7485,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7919,7 +7500,8 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + ytitle = get_label(data, var = pri), + ... )+ scale_fill_generate(palette=color.palette) }) @@ -8065,6 +7647,890 @@ plot_download_demo_app <- function() { # plot_download_demo_app() +######## +#### Current file: /Users/au301842/FreesearchR/R//plot-helpers.R +######## + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - fun: the plotting function +#' +#' - fun.args: default parameters for the plotting function +#' +#' - descr: Plot description +#' +#' - note: Short note/description of the function for displaying in ui and docs +#' +#' - primary.type: Primary variable data type (see [data_type]) +#' +#' - base: holds a list of parameters for plot input fields generation +#' Secondary and tertiary variable input fields are mandatory. +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' available_plots() |> str() +available_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Additional variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ), + list( + id = "reverse", + type = "select_input", + label = i18n$t("Reverse colors"), + choices = c(yes = TRUE, no = FALSE) + ) + ), + advanced = list() + ######### + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("datatime", "continuous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = TRUE, + maxItems = 4 + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = TRUE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ) + ) +} + +# Helper function to create input elements dynamically +create_input_element <- function(params, ns, input_id) { + # Add the namespaced inputId to the arguments + params$inputId <- ns(input_id) + + # Map input types to Shiny functions + input_function <- switch( + params$type, + "numeric_input" = shiny::numericInput, + "select_input" = shiny::selectInput, + "checkbox_input" = shiny::checkboxInput, + "slider_input" = shiny::sliderInput, + "text_input" = shiny::textInput, + "select_variables" = selectPlotVariables + ) + + params$type <- NULL + params$id <- NULL + + + # Call the function with all arguments + do.call(input_function, params) +} + +#' Wrapper for columnSelectInput +#' +selectPlotVariables <- function(data, + exclude = NULL, + allow_none = TRUE, + var_types, + ...) { + datar <- if (is.reactive(data)) { + data + } else { + reactive(data) + } + + cols <- all_but(colnames(subset_types(datar(), var_types)), exclude) + + if (isTRUE(allow_none)) { + cols <- c("none", cols) + } + + params <- list(...) + + params$none_label <- i18n$t("No variable") + params$col_subset <- cols + + rlang::exec(columnSelectInput, !!!append_list(datar(), params, "data")) +} + + + +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + secondary.type = c("dichotomous"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous"), + secondary.extra = NULL + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data, source_list = supported_plots()) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- source_list |> + lapply(\(.x) { + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x) { + .x[match(data, descrs)] + })() +} + +#' Get the function parameters based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_input_params() +get_input_params <- function(data) { + descr <- available_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + available_plots() |> + (\(.x) { + .x[match(data, descr)] + })() +} + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + color.palette = color.palette, + ... + ) + + out <- do.call(type, modifyList(parameters, list(data = data))) + + code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") + + attr(out, "code") <- code + out +} + +#' Print label, and if missing print variable name for plots +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, + lineLength = 20, + force = FALSE) { + if (isTRUE(force)) { + ## This eats some letters when splitting a sentence... ?? + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' @param title panel title +#' @param guides passed to patchwork::wrap_plots() +#' @param axes passed to patchwork::wrap_plots() +#' @param axis_titles passed to patchwork::wrap_plots() +#' @param ... passed to patchwork::wrap_plots() +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, + tag_levels = NULL, + title = NULL, + axis.font.family = NULL, + guides = "collect", + axes = "collect", + axis_titles = "collect", + y.axis.percentage = FALSE, + ...) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x) { + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i) { + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes(percentage = y.axis.percentage) |> + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + if (!is.null(title)) { + out <- out + + patchwork::plot_annotation( + title = title, + theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) + ) + } + } else { + out <- data[[1]] + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + + if (!is.null(axis.font.family)) { + if (inherits(x = out, what = "patchwork")) { + out <- out & + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } else { + out <- out + + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } + } + + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE, + percentage = FALSE) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + p_out <- purrr::map(p, \(.x) { + out <- .x + if (isTRUE(x.axis)) { + out <- out + ggplot2::xlim(xr) + } + if (isTRUE(y.axis)) { + out <- out + ggplot2::ylim(yr) + } + out + }) + }) + + if (isTRUE(percentage)) { + lapply(p_out, \(.x) { + .x + + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x) { + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//redcap_read_shiny_module.R ######## @@ -12003,7 +12469,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -12450,7 +12916,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/", + href = "https://freesearchr.github.io/FreesearchR-knowledge/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 927131ba..517df60d 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -89,7 +89,6 @@ "and","og" "from each pair","fra hvert par" "Plot","Tegn" -"Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" "Plot width (mm)","Bredde af grafik (mm)" "File format","File format" @@ -97,12 +96,7 @@ "Select variable","Vælg variabel" "Response variable","Svarvariable" "Plot type","Type af grafik" -"Please select","Vælg" -"Additional variables","Yderligere variabler" -"Secondary variable","Sekundær variabel" "No variable","Ingen variabel" -"Grouping variable","Variabel til gruppering" -"No stratification","Ingen stratificering" "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" @@ -320,3 +313,14 @@ "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." "The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." +"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." +"Define plot","Define plot" +"Choose color palette","Choose color palette" +"Additional variable","Additional variable" +"Grouping variable","Grouping variable" +"Secondary variable","Secondary variable" +"Reverse colors","Reverse colors" +"Plot survey results","Plot survey results" +"Additional variables","Additional variables" +"Other variables","Other variables" +"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 134ec155..c56e9549 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -89,7 +89,6 @@ "and","na" "from each pair","kutoka kwa kila jozi" "Plot","Kipande cha habari" -"Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" "Plot width (mm)","Upana wa kiwanja (mm)" "File format","Umbizo la faili" @@ -97,12 +96,7 @@ "Select variable","Chagua kigezo" "Response variable","Kigezo cha majibu" "Plot type","Aina ya kiwanja" -"Please select","Tafadhali chagua" -"Additional variables","Vigezo vya ziada" -"Secondary variable","Kigezo cha pili" "No variable","Hakuna kigezo" -"Grouping variable","Kigezo cha kuweka katika makundi" -"No stratification","Hakuna matabaka" "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" @@ -320,3 +313,14 @@ "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." "The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." +"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." +"Define plot","Define plot" +"Choose color palette","Choose color palette" +"Additional variable","Additional variable" +"Grouping variable","Grouping variable" +"Secondary variable","Secondary variable" +"Reverse colors","Reverse colors" +"Plot survey results","Plot survey results" +"Additional variables","Additional variables" +"Other variables","Other variables" +"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index fbadebb2..7baeb26b 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//RtmprUCGcI/file47614d090a4c.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpAe8F1F/file150d9fbea069.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.4.2' +app_version <- function()'26.6.1' ######## @@ -2151,12 +2151,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { list( bslib::layout_sidebar( sidebar = bslib::sidebar( + shiny::actionButton( + inputId = ns("act_plot"), + label = i18n$t("Plot"), + width = "100%", + icon = phosphoricons::ph("paint-brush", weight = "bold"), + # icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText( + i18n$t('Adjust plot input and settings below, then press "Plot".') + ), bslib::accordion( id = "acc_plot", multiple = FALSE, bslib::accordion_panel( value = "acc_pan_plot", - title = "Create plot", + title = i18n$t("Define plot"), icon = phosphoricons::ph("chart-line"), # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), @@ -2167,19 +2178,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), + shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), shiny::uiOutput(outputId = ns("color_palette")), - shiny::br(), - shiny::actionButton( - inputId = ns("act_plot"), - label = i18n$t("Plot"), - width = "100%", - icon = phosphoricons::ph("paint-brush",weight = "bold"), - # icon = shiny::icon("palette"), - disabled = FALSE - ), - shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) + shiny::uiOutput(outputId = ns("basic_parameters")), ), bslib::accordion_panel( value = "acc_pan_download", @@ -2232,14 +2240,14 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::plotOutput(ns("plot"), height = "65vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -2256,10 +2264,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, - data, - palettes, - ...) { +data_visuals_server <- function(id, data, palettes = color_choices(), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -2311,69 +2316,99 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data) + plots <- possible_plots(data = plot_data, source_list = available_plots()) - plots_named <- get_plot_options(plots) |> + plots_named <- get_input_params(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x) { + # stats::setNames(.x$descr, .x$note) + # }) + vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h4(i18n$t("Plot type")), + label = shiny::h5(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_plot_options(input$type) |> purrr::pluck(1) + get_input_params(input$type) |> purrr::pluck(1) + # get_plot_options(input$type) |> purrr::pluck(1) }) + + ### Include two additional variable inputs output$secondary <- shiny::renderUI({ shiny::req(input$type) - cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - subset_types(data(), rv$plot.params()[["secondary.type"]]) - ), input$primary)) + # Get the plot function name + base_params <- rv$plot.params()[["base"]] - columnSelectInput( - inputId = ns("secondary"), - data = data, - selected = cols[1], - placeholder = i18n$t("Please select"), - label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) - i18n$t("Additional variables") - else - i18n$t("Secondary variable"), - multiple = rv$plot.params()[["secondary.multi"]], - maxItems = rv$plot.params()[["secondary.max"]], - col_subset = cols, - none_label = i18n$t("No variable") + filtered_params <- base_params[sapply(base_params, function(params) { + params$id %in% "secondary" + })][[1]] + + filtered_params$exclude <- input$primary + + create_input_element( + input_id = "secondary", + ns = ns, + params = append_list(data(), filtered_params, "data") ) + }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - columnSelectInput( - inputId = ns("tertiary"), - data = data, - placeholder = i18n$t("Please select"), - label = i18n$t("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 = i18n$t("No stratification") + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + params$id %in% "tertiary" + })][[1]] + + filtered_params$exclude <- c(input$primary, input$secondary) + + create_input_element( + input_id = "tertiary", + ns = ns, + params = append_list(data(), filtered_params, "data") ) }) + + ### Generating additional parameter inputs if any specified + output$basic_parameters <- renderUI({ + req(input$type, rv$plot.params) + + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + !params$id %in% c("secondary", "tertiary") + })] + + + # Create UI elements for base parameters + base_inputs <- lapply(filtered_params, function(params) { + input_id <- paste0("base_", params$id) + params$id <- NULL + if (params$type %in% "select_variables") { + params$data <- data() + } + + create_input_element(params, ns, input_id) + }) + tagList(base_inputs) + + }) + ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) @@ -2387,19 +2422,49 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ + # Get all input values with prefixes + base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] + # advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] + + # Remove the prefix from names + names(base_inputs) <- gsub("^base_", "", names(base_inputs)) + # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) + + base_inputs <- c(base_inputs, + list(color.palette = input$color_palette)) + + # If any of the specified parameters are NULL/missing, the settings + # accordion/panel was never opened, and they can be ignored, as + # default settings will the be used. + if (any(sapply(base_inputs, is.null))) { + dynamic_params <- list() + } else { + dynamic_params <- base_inputs + } + + # Build parameters for plotting function parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, sec = input$secondary, - ter = input$tertiary, - color.palette = input$color_palette + ter = input$tertiary ) + parameters <- modifyList(parameters, dynamic_params) + ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included if (!is.null(rv$plot.params()[["fun.args"]])) { - parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) + default_params <- rv$plot.params()[["fun.args"]] + + ## Ensure not to overwrite user defined parameters are overwritten + ## This allows to define default parameters. + ## + ## This will create a strange edge case, where the plot looks in + ## one way, when plotted initially, but may change, when the settings + ## accordion is opened. Problem for future me. Really mostly an edge case. + parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -2435,7 +2500,25 @@ data_visuals_server <- function(id, if (!is.null(rv$plot)) { rv$plot } else { - return(NULL) + # Create a placeholder plot with instructions using ggplot2 + ggplot2::ggplot() + + ggplot2::annotate( + "text", + x = 0.5, + y = 0.5, + label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), + size = 5, + color = "gray50", + lineheight = 0.8 + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + + ggplot2::theme( + panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white") + ) + # return(NULL) } }) @@ -2480,506 +2563,6 @@ data_visuals_server <- function(id, ) } -#' Select all from vector but -#' -#' @param data vector -#' @param ... exclude -#' -#' @returns vector -#' @export -#' -#' @examples -#' all_but(1:10, c(2, 3), 11, 5) -all_but <- function(data, ...) { - data[!data %in% c(...)] -} - -#' Easily subset by data type function -#' -#' @param data data -#' @param types desired types -#' @param type.fun function to get type. Default is outcome_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) -#' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { - data[sapply(data, type.fun) %in% types] -} - - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - descr: Plot description -#' -#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.extra: "none" or NULL to have option to choose none. -#' -#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' supported_plots() |> str() -supported_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = "none", - tertiary.type = c("dichotomous", "categorical") - ), - # plot_ridge = list( - # descr = "Ridge plot", - # note = "An alternative option to visualise data distribution", - # primary.type = "continuous", - # secondary.type = c("dichotomous" ,"categorical"), - # tertiary.type = c("dichotomous" ,"categorical"), - # secondary.extra = NULL - # ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical") - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - secondary.type = c("datatime", "continuous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - secondary.type = c("dichotomous"), - secondary.multi = TRUE, - secondary.max = 4, - tertiary.type = c("dichotomous"), - secondary.extra = NULL - ), - plot_euler = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t( - "Plot survey results" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = TRUE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ) - ) -} - -#' Get possible regression models -#' -#' @param data data -#' -#' @returns character vector -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' dplyr::pull("cyl") |> -#' possible_plots() -#' -#' mtcars |> -#' default_parsing() |> -#' dplyr::select("mpg") |> -#' possible_plots() -possible_plots <- function(data) { - # browser() - # data <- if (is.reactive(data)) data() else data - if (is.data.frame(data)) { - data <- data[[1]] - } - - type <- data_type(data) - - if (type == "unknown") { - out <- type - } else { - out <- supported_plots() |> - lapply(\(.x) { - if (type %in% .x$primary.type) { - .x$descr - } - }) |> - unlist() - } - unname(out) -} - -#' Get the function options based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_plot_options() -get_plot_options <- function(data) { - descrs <- supported_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - supported_plots() |> - (\(.x) { - .x[match(data, descrs)] - })() -} - - - -#' Wrapper to create plot based on provided type -#' -#' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable -#' @param type plot type (derived from possible_plots() and matches custom function) -#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. -#' @param ... ignored for now -#' -#' @name data-plots -#' -#' @returns ggplot2 object -#' @export -#' -#' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, - type, - pri, - sec, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(sec)) { - if (!any(sec %in% names(data))) { - sec <- NULL - } - } - - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } - } - - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - color.palette = color.palette, - ... - ) - - out <- do.call(type, modifyList(parameters, list(data = data))) - - code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") - - attr(out, "code") <- code - out -} - -#' Print label, and if missing print variable name for plots -#' -#' @param data vector or data frame -#' @param var variable name. Optional. -#' -#' @returns character string -#' @export -#' -#' @examples -#' mtcars |> get_label(var = "mpg") -#' mtcars |> get_label() -#' mtcars$mpg |> get_label() -#' gtsummary::trial |> get_label(var = "trt") -#' gtsummary::trial$trt |> get_label() -#' 1:10 |> get_label() -get_label <- function(data, var = NULL) { - # data <- if (is.reactive(data)) data() else data - if (!is.null(var) & is.data.frame(data)) { - data <- data[[var]] - } - out <- REDCapCAST::get_attr(data = data, attr = "label") - if (is.na(out)) { - if (is.null(var)) { - out <- deparse(substitute(data)) - } else { - if (is.symbol(var)) { - out <- gsub('\"', "", deparse(substitute(var))) - } else { - out <- var - } - } - } - out -} - - -#' Line breaking at given number of characters for nicely plotting labels -#' -#' @param data string -#' @param lineLength maximum line length -#' @param fixed flag to force split at exactly the value given in lineLength. -#' Default is FALSE, only splitting at spaces. -#' -#' @returns character string -#' @export -#' -#' @examples -#' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, - lineLength = 20, - force = FALSE) { - if (isTRUE(force)) { - ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), - "\\1\n", - data) - } else { - paste(strwrap(data, lineLength), collapse = "\n") - } - ## https://stackoverflow.com/a/29847221 -} - - -#' Wrapping -#' -#' @param data list of ggplot2 objects -#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL -#' @param title panel title -#' @param guides passed to patchwork::wrap_plots() -#' @param axes passed to patchwork::wrap_plots() -#' @param axis_titles passed to patchwork::wrap_plots() -#' @param ... passed to patchwork::wrap_plots() -#' -#' @returns list of ggplot2 objects -#' @export -#' -wrap_plot_list <- function(data, - tag_levels = NULL, - title = NULL, - axis.font.family = NULL, - guides = "collect", - axes = "collect", - axis_titles = "collect", - y.axis.percentage = FALSE, - ...) { - if (ggplot2::is_ggplot(data[[1]])) { - if (length(data) > 1) { - out <- data |> - (\(.x) { - if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i) { - .y + ggplot2::ggtitle(.i) - }) - } else { - .x - } - })() |> - align_axes(percentage=y.axis.percentage) |> - patchwork::wrap_plots(guides = guides, - axes = axes, - axis_titles = axis_titles, - ...) - if (!is.null(tag_levels)) { - out <- out + patchwork::plot_annotation(tag_levels = tag_levels) - } - if (!is.null(title)) { - out <- out + - patchwork::plot_annotation( - title = title, - theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) - ) - } - } else { - out <- data[[1]] - } - } else { - cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") - } - - if (!is.null(axis.font.family)) { - if (inherits(x = out, what = "patchwork")) { - out <- out & - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } else { - out <- out + - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } - } - - out -} - - -#' Aligns axes between plots -#' -#' @param ... ggplot2 objects or list of ggplot2 objects -#' -#' @returns list of ggplot2 objects -#' @export -#' -align_axes <- function(..., - x.axis = TRUE, - y.axis = TRUE, - percentage = FALSE) { - # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object - # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 - if (ggplot2::is_ggplot(..1)) { - ## Assumes list of ggplots - p <- list(...) - } else if (is.list(..1)) { - ## Assumes list with list of ggplots - p <- ..1 - } else { - cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") - } - - yr <- clean_common_axis(p, "y") - - xr <- clean_common_axis(p, "x") - - suppressWarnings({ - p_out <- purrr::map(p, \(.x) { - out <- .x - if (isTRUE(x.axis)) { - out <- out + ggplot2::xlim(xr) - } - if (isTRUE(y.axis)) { - out <- out + ggplot2::ylim(yr) - } - out - }) - }) - - if(isTRUE(percentage)){ - lapply(p_out,\(.x){ - .x+ - ggplot2::scale_y_continuous(labels = scales::percent) - }) - } else { - p_out - } -} - -#' Extract and clean axis ranges -#' -#' @param p plot -#' @param axis axis. x or y. -#' -#' @returns vector -#' @export -#' -clean_common_axis <- function(p, axis) { - purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> - unlist() |> - (\(.x) { - if (is.numeric(.x)) { - range(.x) - } else { - as.character(.x) - } - })() |> - unique() -} - ######## #### Current file: /Users/au301842/FreesearchR/R//data-summary.R @@ -3845,38 +3428,25 @@ footer_ui <- function(i18n) { #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { + + # --- Input validation ------------------------------------------------------- + if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { stop("`n` must be a single positive integer.") } + if (!is.function(palette) && (!is.character(palette) || length(palette) != 1)) { + stop("`palette` must be a single character string or a function.") + } - # Function passthrough — call directly with n and ... + # --- Function passthrough --------------------------------------------------- if (is.function(palette)) { return(palette(n, ...)) } - if (!is.character(palette) || length(palette) != 1) { - stop("`palette` must be a single character string or a function.") - } - - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { - stop("`n` must be a single positive integer.") - } - if (!is.character(palette) || length(palette) != 1) { - stop("`palette` must be a single character string.") - } - + # --- Named palette dispatch ------------------------------------------------- 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, ...) @@ -3896,35 +3466,42 @@ generate_colors <- function(n, palette = "viridis", ...) { } else if (palette_lower == "topo") { grDevices::topo.colors(n = n, ...) - } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { - max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] - fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() - base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) - grDevices::colorRampPalette(base_colors)(n) - - } else if (palette %in% grDevices::palette.pals()) { - grDevices::colorRampPalette(palette.colors(palette = palette))(n) - - } else if (palette %in% grDevices::hcl.pals()) { - grDevices::hcl.colors(n = n, palette = palette, ...) - } else { - message( - paste0( - "Unknown palette: '", - palette, - "'. ", - "Falling back to default R colors.\n", - "Available options:\n", - " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", - " grDevices : hcl, rainbow, heat, terrain, topo\n", - " grDevices HCL: use grDevices::hcl.pals() to see all options\n", - " grDevices : use grDevices::palette.pals() to see all options\n", - " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" - ) - ) - viridisLite::viridis(n = n, option = "viridis") - # grDevices::hcl.colors(n = n) + # Case-insensitive RColorBrewer lookup + brewer_names <- rownames(RColorBrewer::brewer.pal.info) + brewer_match <- brewer_names[match(palette_lower, tolower(brewer_names))] + + if (!is.na(brewer_match)) { + max_n <- RColorBrewer::brewer.pal.info[brewer_match, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = brewer_match) + grDevices::colorRampPalette(base_colors)(n) + + } else { + # Case-insensitive grDevices palette.pals() lookup + pal_names <- grDevices::palette.pals() + pal_match <- pal_names[match(palette_lower, tolower(pal_names))] + + if (!is.na(pal_match)) { + grDevices::colorRampPalette(grDevices::palette.colors(palette = pal_match))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + # Named HCL palettes (e.g. "Rocket", "Plasma") — distinct from viridisLite + grDevices::hcl.colors(n = n, palette = palette, ...) + + } else { + warning( + "Unknown palette: '", palette, "'. Falling back to viridis.\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") + } + } } } @@ -4957,7 +4534,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.4.2-260410' +hosted_version <- function()'v26.6.1' ######## @@ -6971,14 +6548,14 @@ plot_bar <- function(data, sec = sec, style = style, max_level = max_level, - color.palette = color.palette + color.palette = color.palette, + ... ) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE, - ...) + y.axis.percentage = TRUE) } @@ -7099,11 +6676,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette + color.palette=color.palette, ... ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) } @@ -7297,7 +6874,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis") { +plot_euler_single <- function(data,color.palette="viridis", ...) { data |> ggeulerr(shape = "circle") + @@ -7340,13 +6917,15 @@ plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette + color.palette = color.palette, + ... ) } @@ -7399,7 +6978,7 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse)) { + if (isTRUE(reverse) | reverse=="TRUE") { colors <- rev(colors) } @@ -7456,7 +7035,8 @@ plot_likert <- function(data, pri, sec = NULL, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7633,7 +7213,8 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing") { + missing.level = "Missing", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7867,7 +7448,7 @@ color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -7904,7 +7485,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7919,7 +7500,8 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + ytitle = get_label(data, var = pri), + ... )+ scale_fill_generate(palette=color.palette) }) @@ -8065,6 +7647,890 @@ plot_download_demo_app <- function() { # plot_download_demo_app() +######## +#### Current file: /Users/au301842/FreesearchR/R//plot-helpers.R +######## + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - fun: the plotting function +#' +#' - fun.args: default parameters for the plotting function +#' +#' - descr: Plot description +#' +#' - note: Short note/description of the function for displaying in ui and docs +#' +#' - primary.type: Primary variable data type (see [data_type]) +#' +#' - base: holds a list of parameters for plot input fields generation +#' Secondary and tertiary variable input fields are mandatory. +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' available_plots() |> str() +available_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Additional variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ), + list( + id = "reverse", + type = "select_input", + label = i18n$t("Reverse colors"), + choices = c(yes = TRUE, no = FALSE) + ) + ), + advanced = list() + ######### + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("datatime", "continuous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = TRUE, + maxItems = 4 + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = TRUE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ) + ) +} + +# Helper function to create input elements dynamically +create_input_element <- function(params, ns, input_id) { + # Add the namespaced inputId to the arguments + params$inputId <- ns(input_id) + + # Map input types to Shiny functions + input_function <- switch( + params$type, + "numeric_input" = shiny::numericInput, + "select_input" = shiny::selectInput, + "checkbox_input" = shiny::checkboxInput, + "slider_input" = shiny::sliderInput, + "text_input" = shiny::textInput, + "select_variables" = selectPlotVariables + ) + + params$type <- NULL + params$id <- NULL + + + # Call the function with all arguments + do.call(input_function, params) +} + +#' Wrapper for columnSelectInput +#' +selectPlotVariables <- function(data, + exclude = NULL, + allow_none = TRUE, + var_types, + ...) { + datar <- if (is.reactive(data)) { + data + } else { + reactive(data) + } + + cols <- all_but(colnames(subset_types(datar(), var_types)), exclude) + + if (isTRUE(allow_none)) { + cols <- c("none", cols) + } + + params <- list(...) + + params$none_label <- i18n$t("No variable") + params$col_subset <- cols + + rlang::exec(columnSelectInput, !!!append_list(datar(), params, "data")) +} + + + +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + secondary.type = c("dichotomous"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous"), + secondary.extra = NULL + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data, source_list = supported_plots()) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- source_list |> + lapply(\(.x) { + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x) { + .x[match(data, descrs)] + })() +} + +#' Get the function parameters based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_input_params() +get_input_params <- function(data) { + descr <- available_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + available_plots() |> + (\(.x) { + .x[match(data, descr)] + })() +} + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + color.palette = color.palette, + ... + ) + + out <- do.call(type, modifyList(parameters, list(data = data))) + + code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") + + attr(out, "code") <- code + out +} + +#' Print label, and if missing print variable name for plots +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, + lineLength = 20, + force = FALSE) { + if (isTRUE(force)) { + ## This eats some letters when splitting a sentence... ?? + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' @param title panel title +#' @param guides passed to patchwork::wrap_plots() +#' @param axes passed to patchwork::wrap_plots() +#' @param axis_titles passed to patchwork::wrap_plots() +#' @param ... passed to patchwork::wrap_plots() +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, + tag_levels = NULL, + title = NULL, + axis.font.family = NULL, + guides = "collect", + axes = "collect", + axis_titles = "collect", + y.axis.percentage = FALSE, + ...) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x) { + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i) { + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes(percentage = y.axis.percentage) |> + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + if (!is.null(title)) { + out <- out + + patchwork::plot_annotation( + title = title, + theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) + ) + } + } else { + out <- data[[1]] + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + + if (!is.null(axis.font.family)) { + if (inherits(x = out, what = "patchwork")) { + out <- out & + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } else { + out <- out + + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } + } + + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE, + percentage = FALSE) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + p_out <- purrr::map(p, \(.x) { + out <- .x + if (isTRUE(x.axis)) { + out <- out + ggplot2::xlim(xr) + } + if (isTRUE(y.axis)) { + out <- out + ggplot2::ylim(yr) + } + out + }) + }) + + if (isTRUE(percentage)) { + lapply(p_out, \(.x) { + .x + + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x) { + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//redcap_read_shiny_module.R ######## @@ -12003,7 +12469,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -12450,7 +12916,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/", + href = "https://freesearchr.github.io/FreesearchR-knowledge/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank",