From f2c1c974e0dd85615cc3872573a1e5d44d451f1a Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 3 Dec 2025 22:01:03 +0100 Subject: [PATCH 1/2] feat: new cut methods --- R/cut-variable-ext.R | 30 +++++++++++++++++++++++---- R/cut_var.R | 48 +++++++++++++++++++++++++++++++++++++++----- 2 files changed, 69 insertions(+), 9 deletions(-) diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index cb27543c..508e846c 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -40,7 +40,7 @@ cut_variable_ui <- function(id) { column( width = 3, shiny::conditionalPanel( - condition = "input.method != 'top' && input.method != 'bottom'", + condition = "input.method != 'top' && input.method != 'bottom' && input.method != 'words' && input.method != 'characters'", ns = ns, checkboxInput( inputId = ns("right"), @@ -94,7 +94,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { data <- data_r() rv$data <- data vars_num <- vapply(data, \(.x){ - is.numeric(.x) || is_datetime(.x) || (is.factor(.x) && length(levels(.x)) > 2) + is.numeric(.x) || is_datetime(.x) || (is.factor(.x) && length(levels(.x)) > 2) || is.character(.x) }, logical(1)) vars_num <- names(vars_num)[vars_num] @@ -216,6 +216,12 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { "top", "bottom" ) + } else if ("character" %in% class(data[[variable]])) { + choices <- c( + choices, + "characters", + "words" + ) } else { choices <- c( choices, @@ -294,7 +300,9 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { list(var = f, brks = levels(f)) } else if (input$method %in% c( "top", - "bottom" + "bottom", + "characters", + "words" )) { # This allows factor simplification to get the top or bottom count f <- cut_var(data[[variable]], breaks = input$n_breaks) @@ -409,7 +417,6 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { responseName = "count" ) count_data$freq <- paste(signif(count_data$count / nrow(data) * 100, 3), "%") - # browser() gridTheme <- getOption("datagrid.theme") if (length(gridTheme) < 1) { datamods:::apply_grid_theme() @@ -476,6 +483,9 @@ plot_histogram <- function(data, column = NULL, bins = 30, breaks = NULL, color } else { x <- data[[column]] } + if (is.character(x)){ + x <- REDCapCAST::as_factor(x) + } x <- as.numeric(x) op <- par(mar = rep(1.5, 4)) on.exit(par(op)) @@ -551,6 +561,18 @@ cut_methods <- function() { min = 1, max = 50 ), + "characters" = list( + descr = i18n$t("Shorten to first letters"), + breaks = i18n$t("Letters"), + min = 1, + max = 20 + ), + "words" = list( + descr = i18n$t("Shorten to first words"), + breaks = i18n$t("Words"), + min = 1, + max = 50 + ), "fixed" = list( descr = i18n$t("By specified numbers"), breaks = i18n$t("Breaks"), diff --git a/R/cut_var.R b/R/cut_var.R index d2fab621..16635694 100644 --- a/R/cut_var.R +++ b/R/cut_var.R @@ -184,21 +184,24 @@ cut_var.factor <- function(x, breaks = NULL, type = c("top", "bottom"), other = tbl <- sort(table(x), decreasing = TRUE) if (type == "top") { - if (length(levels(x)) <= breaks){ + if (length(levels(x)) <= breaks) { return(x) } lvls <- names(tbl[seq_len(breaks)]) } else if (type == "bottom") { freqs_check <- tbl / NROW(x) * 100 < breaks - if (!any(freqs_check)){ + if (!any(freqs_check)) { return(x) } lvls <- names(tbl)[!freqs_check] } - if (other %in% lvls) { - other <- paste(other, "_freesearchr") - } + # if (other %in% lvls) { + # other <- paste(other, "_freesearchr") + # } + + # Ensure unique new level name + other <- unique_names(other, lvls) ## Relabel and relevel out <- forcats::fct_relabel( @@ -214,6 +217,41 @@ cut_var.factor <- function(x, breaks = NULL, type = c("top", "bottom"), other = } +#' Subset first part of string to factor +#' +#' @name cut_var +#' +#' @returns factor +#' @export +#' +#' @examples +#' c("Sunday", "This week is short") |> cut_var(breaks = 3) +cut_var.character <- function(x, breaks = NULL, type = c("characters", "words"), ...) { + args <- list(...) + + if (is.null(breaks)) { + return(x) + } + + type <- match.arg(type) + + if (type == "characters") { + out <- substr(x, start = 1, stop = breaks) + } else if (type == "words") { + out <- strsplit(x, " ") |> + sapply(\(.x){ + if (length(.x) > breaks) { + paste(.x[seq_len(breaks)], collapse = " ") + } else { + paste(.x, collapse = " ") + } + }) + } + + attr(out, which = "brks") <- breaks + REDCapCAST::as_factor(out) +} + #' Test class #' #' @param data data From fab5c6cf22822024b269376aad0e20f038af78b3 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 3 Dec 2025 22:01:28 +0100 Subject: [PATCH 2/2] fix: modal ui hanging, rerender --- CITATION.cff | 2 +- DESCRIPTION | 2 +- NAMESPACE | 1 + NEWS.md | 6 ++ R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/sysdata.rda | Bin 2685 -> 2806 bytes SESSION.md | 18 +++- app_docker/app.R | 98 +++++++++++++++++---- app_docker/translations/translation_da.csv | 4 + app_docker/translations/translation_de.csv | 4 + app_docker/translations/translation_sv.csv | 4 + app_docker/translations/translation_sw.csv | 4 + inst/apps/FreesearchR/app.R | 98 +++++++++++++++++---- inst/translations/translation_da.csv | 4 + inst/translations/translation_de.csv | 4 + inst/translations/translation_sv.csv | 4 + inst/translations/translation_sw.csv | 4 + man/cut_var.Rd | 8 ++ 19 files changed, 228 insertions(+), 41 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 41ce08b6..8969cf76 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: 25.12.1 +version: 25.12.2 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index 035421e6..2bacd4a2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 25.12.1 +Version: 25.12.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 1365c2d0..8acdcd86 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(cut_var,character) S3method(cut_var,default) S3method(cut_var,factor) S3method(cut_var,hms) diff --git a/NEWS.md b/NEWS.md index 9e59a927..3c3bdd79 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# FreesearchR 25.12.2 + +*FIX* Fixed hanging interface when splitting strings. + +*NEW* New option to shorten character variables to the first N words or characters. Shortening by characters could be useful working with eg. ICD-10 diagnostic codes. + # FreesearchR 25.12.1 *NEW* Option to edit factor label names in the "New factor" pop-up. This allows for easier naming for tables, but also to combine levels. A new variable is appended to the dataset if label names are changed. Code is now also exported. diff --git a/R/app_version.R b/R/app_version.R index c86ba1bf..58ba4d68 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'25.12.1' +app_version <- function()'25.12.2' diff --git a/R/hosted_version.R b/R/hosted_version.R index 920e146f..302b8b0e 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v25.12.1-251202' +hosted_version <- function()'v25.12.2-251203' diff --git a/R/sysdata.rda b/R/sysdata.rda index d526373777ba70aaa9d861488b1b6d8e0a62ffc1..63d5ca85e1631fa0e02bab38143e3a27a3e7edf4 100644 GIT binary patch literal 2806 zcmVT4*^jL0KkKS%SzD9snA1|HA+OXazuj|KNXb-@w2B|L{Nn5C8}P;0%8k z5QUzgI4YEY8UPc3^a7rNsxBIsfFff+nFfet0Fk39>Nb-QG#VbG)Y_VUlp>y*2Brx{ zO+8GEN2#Cy0000000F7u1eG+69!cdH0h30610c`<000dHnn;SCN}Fhj={+MuCPte? zVFp7JLm{RF(<3GhX^6pWM~*eAVj27(K31>G-5qK(UFk#8UsO~ z88)CZL}+Bpl{iVDP`-u|+5ug3MN-J14`WJ#s`GHzRH%(r5WTng*3g##x)*tOxw%Xt zZpAGmu7FY)3op!eXZGv3AYFh8j+94_22C6pf7iIN*zeEs`e^w7&#OTL_Du=VI>)6f zN~<5u*GkWf2HDCs-8q?BwZ^#;I`>wY1o!GBcdo1~a*0BWcbrCykqX_-wUk>C(?BVP zsn*2JQ`6eRF-XJ#BI^Xq7Of>1=<0JGypIp>>we?;HN!aEQO5S{ z!t1TM0mqrgViQ=?VX%pEs*0cf{#-D(IGE^ycx@UIG|1CSEty_KGLYPo zkIpnA!F-Cfn$}I5bn+$qp#WE$l0Qjq)yr$$iH8f*(OBM7iwDD0Ck`ZCPRlyQ+)O8X)*Ts)U`m@gi!n{FheM(Pe&?QZy6 z;>3f%LAu~^D(apYDMiv|Zn&a1d$gxlCt;=+ZX#_9D-lt>@iy|FLW<&T8YUv@nQw0v z?<`o3PJXXfsn;R$g{7`E@2>vVyN<&xI``_?MoCmo5n2k%e-ji%K|w=t1RUrB7Tb#D zy0#r$&^)jNQ(RP0f(QhI0zyI}fU*LVilCv%5)hhX2nKoWI{e}DsF6W~6jc&JB#?xN zs9)d6W5lT9f+%Y1==XQ@tljW31Sfdu+fJy6s;VlHRwzXl3JNR*ixCzo$Re^Vih?ML zf-)kB6j5R_DuRN7#aY?q`2Ke+--$d}lS$!hY;@;NGdRhl)(XRc+pD@)dNCB+3i>%i zHEXU6IXT?pMO8M#mlKv=cyPGsz{Lcay;5|rAC!=5fg)+<)j%T5+uFt=1>;Ema8Yg!u63ipRa#~U0gtSn4z zcdhSA&I)jxA*sGN$RZUtGqnoaIrq#SZp3;$zbD3{+zHy9tUK(LknlAnV7JJOMHE*fa!5-IrKv0* za*>nWPj-G?QABWwcFZQJqawiGv}S~DpVQ%lox%u6$UuxFf!tsQ;~K}E@_e2<&v>+`vfA71@l7VB zWvfbCmbr*jDTsGuWLHN*%B5BFwrL}oWLjB5keEwjc=)OYNTLS$*c&ELq%D$?7O5#A z5JEzBe~za2A^2G+$S4my)6H>)h6*S>wDOXiJE~I4S?X97RaP)W88nTss>T}ar{1$=LP(nyf>O;Cfgif8E zF!*}e79Dlb>q{z9iy(|36@(NjtcHw9j707-psIdtSh&ko4berFOBNF*(=|zmczw?A zPFH;Q^@Yxk?WJncwX6}5Nu&YH=-%0yHNJmdgU0{d9CWtY($dxo$(RQOtWeEq(?Pbi zp=!mG&e&Aj(O`HdWN>$TpQmvF24bC=Vz0> zY}Dig@aOaGMN^|GpOe4|y|s+a-0SKfBgdzwVeIKpQk0?b{}{6FpcD=Njuqp(4m*bJ zpeRx@KBv9P_kI6=zw{kmLuUtNMM}HF$I%gJ;Sg#A}sZuL`=ao3|Z8X|C|{gu1g>*yD%QI-h` z*ws(?CftuQ3K&L}Fn(hM)FaNU?_*ni$e8)~*sKa6!;{n7vCUPDsagor z+%C1#pkHz>khcN78x)Ief(2kQdsLD_7-R}a-Y6|b)*;dqE%O1AAlza?ZR_Um=>Qm< z^3@v17aCwVOm`2)l(zD5R=GeB#Gk3Zg^aE@uk?c3C0&)Fp(<_@6FTs4o8Qm%oau2z z!;DgaWGXBry&<0cC%OB`eID)|H_GxFtf4$!yBbcP9k5#tNW=#Y;Hp*#Rwx9oI0dzLq&bx958FkHuhDIBwb1M5-qE}eVcmME zPOD6;?bwGNu)$`fl+p?~(M!7%(rc?*B}NX|5TVBP z%mYZ%8U{2qPB97Vkf8xNwHd3z9yS=4M78BWl|`uDX`2<-47)de5O%q$s4<66>@)?+ z(NmPSo?qo@(nV-O4=}rIN(iwsV3X7sq6EWUD?9Hne6?^ZrxEi`f+gq=BcWuG+JO(k zh+aQOKRh$-&%SzE90^?D=2Og+3=<-XsX;TWcaVa(lhf9fS;?J$cH9L(TbbxyMRZ-S z*7#(=MQNTkp26=yn9_%lhr0`Vq0y{DJIX|_T}e-g&|VSLa~ivT%BR-p<|q`di63pb z<5~c{o9q&i4j(*SnRWuQ!@m{_DwNQKhVQe&#c1X-wt;;U)Z zBbNRIsWFQ;DAjP@B*AI0f}@(d77)6CYEudAsrOt_F;H&awtan>I^6Z<;?FtOsz!ED zjXh%5Ub^0)GC?9!w7J9uAiB~5a3!jZEum|`gry`vSyW0EK~G7}3k3jbvqj{#2APln z#v@wMbjdVbRynf`cy!v#^MJO5Hl@npTChF(r`ud=xT&?5)Te7H5fmzGu}8MXde*Ei zT2bA`UCOw5T%!nW%Yw&HzEpCv71`yM?+R=yx(wRAvnu!vn{%g5&wOw?U0`hrAtLpAOHXW literal 2685 zcmV-@3WD`QT4*^jL0KkKS%{gEeE=B$f5iX)Xazuj|L}ir-@w2B|L{Nn0RRXA;0ym3 zAqx)yz?C2df`jdS@Bj~>XdW7vfFRRBG|xg z00000000008lE6YRA@G*sPzmJPg6h{05oVc0002UB+^7vMNR3cqfDla3<0U2!Wj(> z0fb>R&}pD)Q$eAi2188%000dD007fK03uQ*jSW-NPz?HrM@XlMh;0h08o z$V{aSKx8hU71u-sEP^U#<4^%z|HXw$Ak|R}J}2;KKUT^LgN z++{_rYLS_1wu2z|>LhnA-MolIp+-B7BT}^r+zMGG!RsItOIua2qNRtmhGL0`)QG$j zEVXGG-i!@vh|m+s7PMgjEt$^(-oa0|ciiu>&l*PpmdzWxEAPJ)Ic!)(g`Ar9-imwVSYIa1d^|97?*ZiK8}Ah@LQw-t8&X z$=pMLy%~wLEb+LWIGMML8hk{fB-CY7h>gxCLCy|JwquOG(en!{X!lco`rQxar=f zS|Tc{h{%X36cktrC<-Ve1z7}Cia`b}L>37U6-FSWP*Ft{PR~2P;pLn0r;ie8JWZ6X z>BZfdX}T&KH+6SP;ZaR6udkFdi(PPG$=b&&$*MlDuG;;Q!%42;K_Zy{a^Q1GE!FE)gm-rkvXrS7P`D1)dlHx~y# zJsA~bkZKB`VP-KqP<48i9N1*ca9)OnkXp?WbTZS?6m45kZ8%wU!rH1ba8CHgd_W*x zdUYV?Wfj7@xMWJ&?_1u6a8TPaYkSQ-9p$^-o7VMe2y?uc_BIeo1h=jWVkae;nBY(> zRX`?`O45Q_>&@Ow>)si3B~>yIiEIJ_Q=3{OZY}DCK}{MYfrTA35j&SRdUkB3EhA=5 zqH?BW*@8B5bflrmIR{^{-+dmt^t}$JH6Of5-SY<6q zL4RsSPk}xO=W2?M5hz$?Fvy^5TFnUCKY#U*ol*=4l1T(11F0mNkVNRoQE`!cTh-OPzSixY%Lsv3eek8@)<9odL=oQx7xD?&r9)s>^ErhlIp*OIF)* z*D(spV>@JFq@=Hwz5icpHRUTyC=|$D94D|#A`7_`0J88Gl9XtLvRFdZg@hvzfjd4P zvwM*9St}s2JrQ9>D6#Fc#FXgnsY+U(j=-ua#t4HZk+v0B!?imtkwG7l*P#l*UK6R9 zn3DQl9)}!TYQ=93@H8mF7%Y(xV<#4Yx>$=LP>P`45V%knTZ-C`mKrRHhPz}Vh7_W} zfmlIhRglq)F^HW^s4AX4QOhk=P0>qfRHDdaE>a#Jf48R#zC4{_bE(~>6r*imjEYSl z4t49jE{xweA8SUrS~Akq7iM8M3dIc8oitIjTP;|!ehr09zr)Esj^YG?QD2=mlFUR9 z1VK>7$;S-y9`;R+7G?u|0RQ;R9B@A4>nbao7WUT(S| zI=MXY0TAoR^qoi|0K_#O-2{({kVJ?Ef$5SBHGwCO9sgoIF$sf(7D1fZ-&0tMnFzBC zFbRT2Et4V}PDvsWkwf6NqqX~G|8IvGlZO}vSVNGI9!`?rCUy|x23VLCIyVAX>(VrG> zG(_cF?QgxfNMNYKIHVTEUHms@&7>F#Ld&x%G3Q|I!ux^wj8efK%XY17!t+eL{AR36 zaCckN-?`0I&9z#_zVU_brC8vLtZP|y*_LGeL6bpA%S1D4&@p6kwXb_lHW9K)5F|mo z$5^9z_B;AO1}1gF;swg5jyDeR_EeO_oL0&JhAul9`1dYw#eap1ZA!y!;h`*UR1`Vn z;YYup=sH&DxO7D-7edm?TEk6v@NT3%U!Rv&F~Ehi)7U>xlLBZv=yxj0q}WQTcjt30#Ki;@+N4I_>HV68uk^4y(BclDj@l z4|cEVgl5P52zC37qP{epvM~Y6z$&$Z6BPniqytkH!capkP`P0oS?-D zvn=eHSvRs!Asi5l#9;IAZqns(iF8XnwFz2Q8_hIgpPz33+V#59`^O$eNh+RH! z9i#2X&{ZgMC3D>7R<2~D1jwSTP_%dudb$az>q{rt&fl+gBCsj6^)Di%U9;BsX23;x zo>!iO>Or(?Q^>>JmHrUu%twJlmFu-C@;MibD>@4M{+d&psi3O0)g$h|O_M+uyIX{$ zLzm^T+81eDR~9=M6{{NMg0RFV6wf#E1;18}H^;o36vJLw?6agv%@%Oy>Zzrg%P9o; z`xv{PLUfA9)>r cut_var(breaks = 3) +cut_var.character <- function(x, breaks = NULL, type = c("characters", "words"), ...) { + args <- list(...) + + if (is.null(breaks)) { + return(x) + } + + type <- match.arg(type) + + if (type == "characters") { + out <- substr(x, start = 1, stop = breaks) + } else if (type == "words") { + out <- strsplit(x, " ") |> + sapply(\(.x){ + if (length(.x) > breaks) { + paste(.x[seq_len(breaks)], collapse = " ") + } else { + paste(.x, collapse = " ") + } + }) + } + + attr(out, which = "brks") <- breaks + REDCapCAST::as_factor(out) +} + #' Test class #' #' @param data data @@ -1322,7 +1360,7 @@ cut_variable_ui <- function(id) { column( width = 3, shiny::conditionalPanel( - condition = "input.method != 'top' && input.method != 'bottom'", + condition = "input.method != 'top' && input.method != 'bottom' && input.method != 'words' && input.method != 'characters'", ns = ns, checkboxInput( inputId = ns("right"), @@ -1376,7 +1414,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { data <- data_r() rv$data <- data vars_num <- vapply(data, \(.x){ - is.numeric(.x) || is_datetime(.x) || (is.factor(.x) && length(levels(.x)) > 2) + is.numeric(.x) || is_datetime(.x) || (is.factor(.x) && length(levels(.x)) > 2) || is.character(.x) }, logical(1)) vars_num <- names(vars_num)[vars_num] @@ -1498,6 +1536,12 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { "top", "bottom" ) + } else if ("character" %in% class(data[[variable]])) { + choices <- c( + choices, + "characters", + "words" + ) } else { choices <- c( choices, @@ -1576,7 +1620,9 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { list(var = f, brks = levels(f)) } else if (input$method %in% c( "top", - "bottom" + "bottom", + "characters", + "words" )) { # This allows factor simplification to get the top or bottom count f <- cut_var(data[[variable]], breaks = input$n_breaks) @@ -1691,7 +1737,6 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { responseName = "count" ) count_data$freq <- paste(signif(count_data$count / nrow(data) * 100, 3), "%") - # browser() gridTheme <- getOption("datagrid.theme") if (length(gridTheme) < 1) { datamods:::apply_grid_theme() @@ -1758,6 +1803,9 @@ plot_histogram <- function(data, column = NULL, bins = 30, breaks = NULL, color } else { x <- data[[column]] } + if (is.character(x)){ + x <- REDCapCAST::as_factor(x) + } x <- as.numeric(x) op <- par(mar = rep(1.5, 4)) on.exit(par(op)) @@ -1833,6 +1881,18 @@ cut_methods <- function() { min = 1, max = 50 ), + "characters" = list( + descr = i18n$t("Shorten to first letters"), + breaks = i18n$t("Letters"), + min = 1, + max = 20 + ), + "words" = list( + descr = i18n$t("Shorten to first words"), + breaks = i18n$t("Words"), + min = 1, + max = 50 + ), "fixed" = list( descr = i18n$t("By specified numbers"), breaks = i18n$t("Breaks"), @@ -4369,7 +4429,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v25.12.1-251202' +hosted_version <- function()'v25.12.2-251203' ######## @@ -12974,11 +13034,14 @@ server <- function(input, output, session) { data_r = reactive(rv$data) ) - shiny::observeEvent(data_modal_update(), { - shiny::removeModal() - rv$data <- data_modal_update() - rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") - }) + shiny::observeEvent( + data_modal_update(), + { + shiny::removeModal() + rv$data <- data_modal_update() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + } + ) ######### Split string @@ -12998,6 +13061,7 @@ server <- function(input, output, session) { shiny::observeEvent( data_modal_string(), { + shiny::removeModal() rv$data <- data_modal_string() rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") } diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 6f697a07..e639f6c9 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/app_docker/translations/translation_de.csv b/app_docker/translations/translation_de.csv index 54a25983..682e35bf 100644 --- a/app_docker/translations/translation_de.csv +++ b/app_docker/translations/translation_de.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/app_docker/translations/translation_sv.csv b/app_docker/translations/translation_sv.csv index 99bed52e..47fca535 100644 --- a/app_docker/translations/translation_sv.csv +++ b/app_docker/translations/translation_sv.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index d94b1894..5fa91537 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 6278a8e3..e3c8aca9 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//RtmpyM6210/file1267841f7ff86.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpejDCIE/filec7541d50b50.R ######## i18n_path <- system.file("translations", package = "FreesearchR") @@ -62,7 +62,7 @@ i18n$set_translation_language("en") #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'25.12.1' +app_version <- function()'25.12.2' ######## @@ -1214,21 +1214,24 @@ cut_var.factor <- function(x, breaks = NULL, type = c("top", "bottom"), other = tbl <- sort(table(x), decreasing = TRUE) if (type == "top") { - if (length(levels(x)) <= breaks){ + if (length(levels(x)) <= breaks) { return(x) } lvls <- names(tbl[seq_len(breaks)]) } else if (type == "bottom") { freqs_check <- tbl / NROW(x) * 100 < breaks - if (!any(freqs_check)){ + if (!any(freqs_check)) { return(x) } lvls <- names(tbl)[!freqs_check] } - if (other %in% lvls) { - other <- paste(other, "_freesearchr") - } + # if (other %in% lvls) { + # other <- paste(other, "_freesearchr") + # } + + # Ensure unique new level name + other <- unique_names(other, lvls) ## Relabel and relevel out <- forcats::fct_relabel( @@ -1244,6 +1247,41 @@ cut_var.factor <- function(x, breaks = NULL, type = c("top", "bottom"), other = } +#' Subset first part of string to factor +#' +#' @name cut_var +#' +#' @returns factor +#' @export +#' +#' @examples +#' c("Sunday", "This week is short") |> cut_var(breaks = 3) +cut_var.character <- function(x, breaks = NULL, type = c("characters", "words"), ...) { + args <- list(...) + + if (is.null(breaks)) { + return(x) + } + + type <- match.arg(type) + + if (type == "characters") { + out <- substr(x, start = 1, stop = breaks) + } else if (type == "words") { + out <- strsplit(x, " ") |> + sapply(\(.x){ + if (length(.x) > breaks) { + paste(.x[seq_len(breaks)], collapse = " ") + } else { + paste(.x, collapse = " ") + } + }) + } + + attr(out, which = "brks") <- breaks + REDCapCAST::as_factor(out) +} + #' Test class #' #' @param data data @@ -1322,7 +1360,7 @@ cut_variable_ui <- function(id) { column( width = 3, shiny::conditionalPanel( - condition = "input.method != 'top' && input.method != 'bottom'", + condition = "input.method != 'top' && input.method != 'bottom' && input.method != 'words' && input.method != 'characters'", ns = ns, checkboxInput( inputId = ns("right"), @@ -1376,7 +1414,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { data <- data_r() rv$data <- data vars_num <- vapply(data, \(.x){ - is.numeric(.x) || is_datetime(.x) || (is.factor(.x) && length(levels(.x)) > 2) + is.numeric(.x) || is_datetime(.x) || (is.factor(.x) && length(levels(.x)) > 2) || is.character(.x) }, logical(1)) vars_num <- names(vars_num)[vars_num] @@ -1498,6 +1536,12 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { "top", "bottom" ) + } else if ("character" %in% class(data[[variable]])) { + choices <- c( + choices, + "characters", + "words" + ) } else { choices <- c( choices, @@ -1576,7 +1620,9 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { list(var = f, brks = levels(f)) } else if (input$method %in% c( "top", - "bottom" + "bottom", + "characters", + "words" )) { # This allows factor simplification to get the top or bottom count f <- cut_var(data[[variable]], breaks = input$n_breaks) @@ -1691,7 +1737,6 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { responseName = "count" ) count_data$freq <- paste(signif(count_data$count / nrow(data) * 100, 3), "%") - # browser() gridTheme <- getOption("datagrid.theme") if (length(gridTheme) < 1) { datamods:::apply_grid_theme() @@ -1758,6 +1803,9 @@ plot_histogram <- function(data, column = NULL, bins = 30, breaks = NULL, color } else { x <- data[[column]] } + if (is.character(x)){ + x <- REDCapCAST::as_factor(x) + } x <- as.numeric(x) op <- par(mar = rep(1.5, 4)) on.exit(par(op)) @@ -1833,6 +1881,18 @@ cut_methods <- function() { min = 1, max = 50 ), + "characters" = list( + descr = i18n$t("Shorten to first letters"), + breaks = i18n$t("Letters"), + min = 1, + max = 20 + ), + "words" = list( + descr = i18n$t("Shorten to first words"), + breaks = i18n$t("Words"), + min = 1, + max = 50 + ), "fixed" = list( descr = i18n$t("By specified numbers"), breaks = i18n$t("Breaks"), @@ -4369,7 +4429,7 @@ data_types <- function() { #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v25.12.1-251202' +hosted_version <- function()'v25.12.2-251203' ######## @@ -12974,11 +13034,14 @@ server <- function(input, output, session) { data_r = reactive(rv$data) ) - shiny::observeEvent(data_modal_update(), { - shiny::removeModal() - rv$data <- data_modal_update() - rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") - }) + shiny::observeEvent( + data_modal_update(), + { + shiny::removeModal() + rv$data <- data_modal_update() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + } + ) ######### Split string @@ -12998,6 +13061,7 @@ server <- function(input, output, session) { shiny::observeEvent( data_modal_string(), { + shiny::removeModal() rv$data <- data_modal_string() rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") } diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 6f697a07..e639f6c9 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/inst/translations/translation_de.csv b/inst/translations/translation_de.csv index 54a25983..682e35bf 100644 --- a/inst/translations/translation_de.csv +++ b/inst/translations/translation_de.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/inst/translations/translation_sv.csv b/inst/translations/translation_sv.csv index 99bed52e..47fca535 100644 --- a/inst/translations/translation_sv.csv +++ b/inst/translations/translation_sv.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index d94b1894..5fa91537 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -295,3 +295,7 @@ "Level of detail","Level of detail" "Minimal","Minimal" "Extensive","Extensive" +"Letters","Letters" +"Words","Words" +"Shorten to first letters","Shorten to first letters" +"Shorten to first words","Shorten to first words" diff --git a/man/cut_var.Rd b/man/cut_var.Rd index 7d74b22c..7fa6dd61 100644 --- a/man/cut_var.Rd +++ b/man/cut_var.Rd @@ -8,6 +8,7 @@ \alias{cut_var.POSIXct} \alias{cut_var.Date} \alias{cut_var.factor} +\alias{cut_var.character} \title{Extended cutting function with fall-back to the native base::cut} \usage{ cut_var(x, ...) @@ -37,6 +38,8 @@ cut_var(x, ...) \method{cut_var}{Date}(x, breaks = NULL, start.on.monday = TRUE, ...) \method{cut_var}{factor}(x, breaks = NULL, type = c("top", "bottom"), other = "Other", ...) + +\method{cut_var}{character}(x, breaks = NULL, type = c("characters", "words"), ...) } \arguments{ \item{x}{an object inheriting from class "POSIXct"} @@ -48,12 +51,16 @@ cut_var(x, ...) \value{ factor +factor + factor } \description{ Extended cutting function with fall-back to the native base::cut Simplify a factor to only the top or bottom n levels + +Subset first part of string to factor } \examples{ readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(2) @@ -80,4 +87,5 @@ mtcars$carb |> as.factor() |> cut_var(20, "bottom") |> table() +c("Sunday", "This week is short") |> cut_var(breaks = 3) }