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/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 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 d5263737..63d5ca85 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/SESSION.md b/SESSION.md index 41b64837..32d4c825 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 |2025-12-02 | +|date |2025-12-03 | |rstudio |2025.09.2+418 Cucumberleaf Sunflower (desktop) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |quarto |1.7.30 @ /usr/local/bin/quarto | -|FreesearchR |25.12.1.251202 | +|FreesearchR |25.12.2.251203 | -------------------------------------------------------------------------------- @@ -44,6 +44,7 @@ |cardx |0.2.5 |2025-07-03 |CRAN (R 4.4.1) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.4.1) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.4.0) | +|cffr |1.2.0 |2025-01-25 |CRAN (R 4.4.1) | |checkmate |2.3.2 |2024-07-29 |RSPM (R 4.4.0) | |class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.4.1) | @@ -53,6 +54,7 @@ |colorspace |2.1-1 |2024-07-26 |CRAN (R 4.4.1) | |commonmark |2.0.0 |2025-07-07 |CRAN (R 4.4.1) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.4.1) | +|curl |6.4.0 |2025-06-22 |RSPM (R 4.4.0) | |data.table |1.17.8 |2025-07-10 |CRAN (R 4.4.1) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.4.1) | |datawizard |1.2.0 |2025-07-17 |CRAN (R 4.4.1) | @@ -83,7 +85,7 @@ |foreach |1.5.2 |2022-02-02 |CRAN (R 4.4.0) | |foreign |0.8-90 |2025-03-31 |CRAN (R 4.4.1) | |Formula |1.2-5 |2023-02-24 |CRAN (R 4.4.1) | -|FreesearchR |25.12.1 |NA |NA | +|FreesearchR |25.12.2 |NA |NA | |fs |1.6.6 |2025-04-12 |CRAN (R 4.4.1) | |gdtools |0.4.2 |2025-03-27 |CRAN (R 4.4.1) | |generics |0.1.4 |2025-05-09 |CRAN (R 4.4.1) | @@ -111,9 +113,11 @@ |iterators |1.0.14 |2022-02-05 |CRAN (R 4.4.1) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) | |jsonlite |2.0.0 |2025-03-27 |CRAN (R 4.4.1) | +|jsonvalidate |1.5.0 |2025-02-07 |CRAN (R 4.4.1) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) | |keyring |1.4.1 |2025-06-15 |CRAN (R 4.4.1) | |knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) | +|labeling |0.4.3 |2023-08-29 |CRAN (R 4.4.1) | |later |1.4.2 |2025-04-08 |RSPM (R 4.4.0) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.4.1) | |lifecycle |1.0.4 |2023-11-07 |CRAN (R 4.4.1) | @@ -156,9 +160,14 @@ |qqconf |1.3.2 |2023-04-14 |CRAN (R 4.4.0) | |qqplotr |0.0.6 |2023-01-25 |CRAN (R 4.4.0) | |quarto |1.5.0 |2025-07-28 |RSPM (R 4.4.0) | +|R.cache |0.17.0 |2025-05-02 |CRAN (R 4.4.1) | +|R.methodsS3 |1.8.2 |2022-06-13 |CRAN (R 4.4.1) | +|R.oo |1.27.1 |2025-05-02 |CRAN (R 4.4.1) | +|R.utils |2.13.0 |2025-02-24 |CRAN (R 4.4.1) | |R6 |2.6.1 |2025-02-15 |CRAN (R 4.4.1) | |ragg |1.4.0 |2025-04-10 |RSPM (R 4.4.0) | |rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.4.0) | +|rappdirs |0.3.3 |2021-01-31 |CRAN (R 4.4.1) | |rbibutils |2.3 |2024-10-04 |CRAN (R 4.4.1) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.4.1) | |Rcpp |1.1.0 |2025-07-02 |CRAN (R 4.4.1) | @@ -197,6 +206,7 @@ |stringi |1.8.7 |2025-03-27 |CRAN (R 4.4.1) | |stringr |1.5.1 |2023-11-14 |RSPM (R 4.4.0) | |stRoke |25.9.2 |2025-09-30 |CRAN (R 4.4.1) | +|styler |1.10.3 |2024-04-07 |CRAN (R 4.4.0) | |systemfonts |1.2.3 |2025-04-30 |CRAN (R 4.4.1) | |testthat |3.2.3 |2025-01-13 |CRAN (R 4.4.1) | |textshaping |1.0.1 |2025-05-01 |RSPM (R 4.4.0) | @@ -211,7 +221,9 @@ |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.4.1) | |urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) | |usethis |3.1.0 |2024-11-26 |RSPM (R 4.4.0) | +|utf8 |1.2.6 |2025-06-08 |CRAN (R 4.4.1) | |uuid |1.2-1 |2024-07-29 |CRAN (R 4.4.1) | +|V8 |6.0.6 |2025-08-18 |CRAN (R 4.4.1) | |vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) | |vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) | |withr |3.0.2 |2024-10-28 |CRAN (R 4.4.1) | diff --git a/app_docker/app.R b/app_docker/app.R index 5e769d05..a0b72083 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpyM6210/file126781ad7585e.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpejDCIE/filec7542b7ed14.R ######## i18n_path <- here::here("translations") @@ -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/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) }