mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-12-16 09:32:10 +01:00
Compare commits
2 commits
cc853b2ede
...
fab5c6cf22
| Author | SHA1 | Date | |
|---|---|---|---|
| fab5c6cf22 | |||
| f2c1c974e0 |
21 changed files with 297 additions and 50 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")),
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
6
NEWS.md
6
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.
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'25.12.1'
|
||||
app_version <- function()'25.12.2'
|
||||
|
|
|
|||
|
|
@ -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"),
|
||||
|
|
|
|||
48
R/cut_var.R
48
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
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
hosted_version <- function()'v25.12.1-251202'
|
||||
hosted_version <- function()'v25.12.2-251203'
|
||||
|
|
|
|||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
18
SESSION.md
18
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) |
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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"
|
||||
|
|
|
|||
|
|
|
@ -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)
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue