diff --git a/CITATION.cff b/CITATION.cff index fcab7f68..41ce08b6 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.11.1 +version: 25.12.1 doi: 10.5281/zenodo.14527429 identifiers: - type: url @@ -1063,6 +1063,40 @@ references: orcid: https://orcid.org/0000-0002-7559-1154 year: '2025' doi: 10.32614/CRAN.package.stRoke +- type: software + title: data.table + abstract: 'data.table: Extension of `data.frame`' + notes: Imports + url: https://r-datatable.com + repository: https://CRAN.R-project.org/package=data.table + authors: + - family-names: Barrett + given-names: Tyson + email: t.barrett88@gmail.com + orcid: https://orcid.org/0000-0002-2137-1391 + - family-names: Dowle + given-names: Matt + email: mattjdowle@gmail.com + - family-names: Srinivasan + given-names: Arun + email: asrini@pm.me + - family-names: Gorecki + given-names: Jan + - family-names: Chirico + given-names: Michael + orcid: https://orcid.org/0000-0003-0787-087X + - family-names: Hocking + given-names: Toby + orcid: https://orcid.org/0000-0002-3146-0865 + - family-names: Schwendinger + given-names: Benjamin + orcid: https://orcid.org/0000-0003-3315-8114 + - family-names: Krylov + given-names: Ivan + email: ikrylov@disroot.org + orcid: https://orcid.org/0000-0002-0172-3812 + year: '2025' + doi: 10.32614/CRAN.package.data.table - type: software title: styler abstract: 'styler: Non-Invasive Pretty Printing of R Code' diff --git a/DESCRIPTION b/DESCRIPTION index 7301de4b..035421e6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 25.11.2 +Version: 25.12.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/NAMESPACE b/NAMESPACE index 127b112c..1365c2d0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -51,6 +51,7 @@ export(default_parsing) export(detect_delimiter) export(drop_empty_event) export(expression_string) +export(factor_new_levels_labels) export(factorize) export(file_export) export(format_writer) @@ -148,6 +149,7 @@ export(symmetrical_scale_x_log10) export(tbl_merge) export(type_icons) export(ui_elements) +export(unique_names) export(unique_short) export(update_factor_server) export(update_factor_ui) diff --git a/NEWS.md b/NEWS.md index 6a4a4600..9e59a927 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# 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. + +*FIX* Fixes a bug, where white space in code exported was removed. Now a little too many spaces are included. Fine tuning continues. + +*NEW* Easily copy code by just clicking "copy" in code blocks. + # FreesearchR 25.11.2 *NEW* Vignettes were moved to the [FreesearchR project knowledge base](https://freesearchr.github.io/FreesearchR-knowledge/). This was mainly to ease rendering and allow quick and easy updates as well as future translations. diff --git a/R/app_version.R b/R/app_version.R index 54c6cdf0..c86ba1bf 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'25.11.2' +app_version <- function()'25.12.1' diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index c1879b7c..cb27543c 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -374,7 +374,11 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { } ) - data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right") + data <- append_column(data, + column = new_variable, + name = unique_names(paste0(variable, "_cut"), + existing = names(data)), + index = "right") code <- rlang::call2( "append_column", diff --git a/R/helpers.R b/R/helpers.R index c038c5c1..635f6799 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -515,18 +515,82 @@ pipe_string <- function(data, collapse = "|>\n") { #' @examples #' list( #' as.symbol(paste0("mtcars$", "mpg")), -#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), +#' rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"), #' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") #' ) |> #' merge_expression() |> #' expression_string() expression_string <- function(data, assign.str = "") { exp.str <- if (is.call(data)) deparse(data) else data - # browser() + out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", paste(exp.str, collapse = "")), collapse = ""))) - gsub(" |`", "", out) + out <- collapse_spaces(out,preserve_newlines = FALSE) + gsub("`", "", out) } +#' Substitue spaces/tabs with single space excluding text within quotes +#' +#' @description +#' Written assisted by Claude.ai. It is long and possibly too complicated, +#' but it works +#' +#' +#' @param x character string +#' @param preserve_newlines flag to preserve new lines +#' +#' @returns character string +#' +#' @examples +#' collapse_spaces(c("cyl", "di sp","s e d","d e'dl e'")) +collapse_spaces <- function(x, preserve_newlines = TRUE) { + # Function to process a single string + process_string <- function(text) { + # Pattern to match single-quoted strings + quote_pattern <- "'[^']*'" + + # Find all quoted strings and their positions + quotes <- gregexpr(quote_pattern, text, perl = TRUE)[[1]] + + if (quotes[1] == -1) { + # No quoted strings, process entire text + if (preserve_newlines) { + return(gsub("[ \\t]{1,}", " ", text)) + } else { + return(gsub("\\s{1,}", " ", text)) + } + } + + # Extract quoted strings + quote_lengths <- attr(quotes, "match.length") + quoted_parts <- substring(text, quotes, quotes + quote_lengths - 1) + + # Create placeholders + placeholders <- paste0("__QUOTE_", seq_along(quoted_parts), "__") + + # Replace quoted strings with placeholders + result <- text + for (i in seq_along(quoted_parts)) { + result <- sub(quote_pattern, placeholders[i], result, perl = TRUE) + } + + # Collapse spaces in non-quoted parts + if (preserve_newlines) { + result <- gsub("[ \\t]{2,}", "", result) + } else { + result <- gsub("\\s{2,}", "", result) + } + + # Restore quoted strings + for (i in seq_along(quoted_parts)) { + result <- sub(placeholders[i], quoted_parts[i], result, fixed = TRUE) + } + + return(result) + } + + # Apply to each element of vector + sapply(x, process_string, USE.NAMES = FALSE) +} #' Very simple function to remove nested lists, like when uploading .rds #' diff --git a/R/hosted_version.R b/R/hosted_version.R index b477b7ff..920e146f 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v25.11.2-251119' +hosted_version <- function()'v25.12.1-251202' diff --git a/R/syntax_highlight.R b/R/syntax_highlight.R index e90f14b1..29ae8a82 100644 --- a/R/syntax_highlight.R +++ b/R/syntax_highlight.R @@ -11,15 +11,25 @@ prismCodeBlock <- function(code) { prismDependencies <- tags$head( tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/prism.min.js"), - tags$link(rel = "stylesheet", type = "text/css", - href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css") + tags$link( + rel = "stylesheet", type = "text/css", + href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css" + ), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js"), + tags$link( + rel = "stylesheet", + href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/toolbar/prism-toolbar.min.css" + ), + tags$script( + src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/toolbar/prism-toolbar.min.js" + ), + tags$script( + src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/copy-to-clipboard/prism-copy-to-clipboard.min.js" + ) ) -prismRDependency <- tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js") -) -html_code_wrap <- function(string,lang="r"){ +html_code_wrap <- function(string, lang = "r") { glue::glue("
{string}
")
}
diff --git a/R/sysdata.rda b/R/sysdata.rda
index d644c198..d5263737 100644
Binary files a/R/sysdata.rda and b/R/sysdata.rda differ
diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R
index 7c1236e0..a895350f 100644
--- a/R/update-factor-ext.R
+++ b/R/update-factor-ext.R
@@ -1,4 +1,3 @@
-
## Works, but not implemented
##
## These edits mainly allows for
@@ -101,7 +100,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
moduleServer(
id,
function(input, output, session) {
-
rv <- reactiveValues(data = NULL, data_grid = NULL)
bindEvent(observe({
@@ -207,19 +205,37 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
data <- req(data_r())
variable <- req(input$variable)
grid <- req(input$grid_data)
- name_var <- if (isTRUE(input$new_var)) {
- paste0(variable, "_updated")
- } else {
- variable
- }
- data[[name_var]] <- factor(
- as.character(data[[variable]]),
- levels = grid[["Var1"]]
+
+ parameters <- list(
+ variable = variable,
+ new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
+ new_levels = as.character(grid[["Var1"]]),
+ new_labels = as.character(grid[["Var1_toset"]]),
+ ignore = "New label"
)
- data[[name_var]] <- factor(
- data[[variable]],
- labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+
+ data <- tryCatch(
+ {
+ 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:", err), type = "err")
+ }
)
+
+ # browser()
+ code <- rlang::call2(
+ "factor_new_levels_labels",
+ !!!parameters,
+ .ns = "FreesearchR"
+ )
+ attr(data, "code") <- code
+
data
})
@@ -231,6 +247,62 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
)
}
+#' Simple function to apply new levels and/or labels to factor
+#'
+#' @param variable factor variable
+#' @param new_level new levels, same length as original
+#' @param new_label new labels, same length as original
+#' @param ignore character string to ignore in new labels
+#'
+#' @returns factor
+#' @export
+#'
+#' @examples
+#' data_n <- mtcars
+#' data_n$cyl <- factor(data_n$cyl)
+#' factor_new_levels_labels(data_n, "cyl", new_labels = c("four", "New label", "New label"))
+factor_new_levels_labels <- function(
+ data,
+ variable,
+ new_variable = TRUE,
+ new_levels = NULL,
+ new_labels = NULL,
+ ignore = "New label") {
+ if (!is.factor(data[[variable]])) {
+ return(data)
+ }
+
+ if (is.null(new_levels)) {
+ new_levels <- levels(data[[variable]])
+ }
+
+ if (is.null(new_labels)) {
+ new_labels <- labels(data[[variable]])
+ }
+
+ with_level <- factor(
+ as.character(data[[variable]]),
+ levels = new_levels
+ )
+ with_label <- factor(
+ with_level,
+ labels = ifelse(new_labels == "New label", new_levels, new_labels)
+ )
+
+ # browser()
+
+ if (isTRUE(new_variable)) {
+ append_column(
+ data = data,
+ column = with_label,
+ name = unique_names(new = paste0(variable, "_updated"), existing = names(data))
+ )
+ } else {
+ data[[variable]] <- new_variable
+ data
+ }
+}
+
#' @inheritParams shiny::modalDialog
@@ -289,3 +361,22 @@ winbox_update_factor <- function(id,
)
}
+
+#' Make unique variable names
+#'
+#' Helper function to create new variable names that are unique
+#' given a set of existing names (in a data set, for example).
+#' If a variable name already exists, a number will be appended.
+#'
+#' @param new a vector of proposed new variable names
+#' @param existing a vector of existing variable names
+#' @return a vector of unique new variable names
+#' @examples
+#' unique_names(c("var_x", "var_y", "var_x"), c("var_x", "var_z"))
+#'
+#' @export
+unique_names <- function(new, existing = character()) {
+ new_names <- make.unique(c(existing, new), sep = "_")
+
+ new_names[-seq_along(existing)]
+}
diff --git a/SESSION.md b/SESSION.md
index 80527531..41b64837 100644
--- a/SESSION.md
+++ b/SESSION.md
@@ -1,21 +1,21 @@
--------------------------------------------------------------------------------
-------------------------------- R environment ---------------------------------
--------------------------------------------------------------------------------
-|setting |value |
-|:-----------|:------------------------------------------|
-|version |R version 4.4.1 (2024-06-14) |
-|os |macOS 15.7.1 |
-|system |aarch64, darwin20 |
-|ui |RStudio |
-|language |(EN) |
-|collate |en_US.UTF-8 |
-|ctype |en_US.UTF-8 |
-|tz |Europe/Copenhagen |
-|date |2025-11-09 |
-|rstudio |2025.05.0+496 Mariposa Orchid (desktop) |
-|pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
-|quarto |1.7.30 @ /usr/local/bin/quarto |
-|FreesearchR |25.11.1.251109 |
+|setting |value |
+|:-----------|:----------------------------------------------|
+|version |R version 4.4.1 (2024-06-14) |
+|os |macOS 26.1 |
+|system |aarch64, darwin20 |
+|ui |RStudio |
+|language |(EN) |
+|collate |en_US.UTF-8 |
+|ctype |en_US.UTF-8 |
+|tz |Europe/Copenhagen |
+|date |2025-12-02 |
+|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 |
--------------------------------------------------------------------------------
@@ -83,7 +83,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.11.1 |NA |NA |
+|FreesearchR |25.12.1 |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) |
@@ -117,11 +117,9 @@
|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) |
-|litedown |0.7 |2025-04-08 |CRAN (R 4.4.1) |
|lme4 |1.1-37 |2025-03-26 |CRAN (R 4.4.1) |
|lubridate |1.9.4 |2024-12-08 |CRAN (R 4.4.1) |
|magrittr |2.0.3 |2022-03-30 |RSPM (R 4.4.0) |
-|markdown |2.0 |2025-03-23 |CRAN (R 4.4.1) |
|MASS |7.3-65 |2025-02-28 |CRAN (R 4.4.1) |
|Matrix |1.7-3 |2025-03-11 |RSPM (R 4.4.0) |
|memoise |2.0.1 |2021-11-26 |CRAN (R 4.4.0) |
diff --git a/app_docker/app.R b/app_docker/app.R
index 0f193d1d..5e769d05 100644
--- a/app_docker/app.R
+++ b/app_docker/app.R
@@ -1,7 +1,7 @@
########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpFr1XvR/file15f634a33505f.R
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpyM6210/file126781ad7585e.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.11.1'
+app_version <- function()'25.12.1'
########
@@ -1656,7 +1656,11 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
}
)
- data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right")
+ data <- append_column(data,
+ column = new_variable,
+ name = unique_names(paste0(variable, "_cut"),
+ existing = names(data)),
+ index = "right")
code <- rlang::call2(
"append_column",
@@ -4060,18 +4064,82 @@ pipe_string <- function(data, collapse = "|>\n") {
#' @examples
#' list(
#' as.symbol(paste0("mtcars$", "mpg")),
-#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
+#' rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"),
#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
#' ) |>
#' merge_expression() |>
#' expression_string()
expression_string <- function(data, assign.str = "") {
exp.str <- if (is.call(data)) deparse(data) else data
- # browser()
+
out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", paste(exp.str, collapse = "")), collapse = "")))
- gsub(" |`", "", out)
+ out <- collapse_spaces(out,preserve_newlines = FALSE)
+ gsub("`", "", out)
}
+#' Substitue spaces/tabs with single space excluding text within quotes
+#'
+#' @description
+#' Written assisted by Claude.ai. It is long and possibly too complicated,
+#' but it works
+#'
+#'
+#' @param x character string
+#' @param preserve_newlines flag to preserve new lines
+#'
+#' @returns character string
+#'
+#' @examples
+#' collapse_spaces(c("cyl", "di sp","s e d","d e'dl e'"))
+collapse_spaces <- function(x, preserve_newlines = TRUE) {
+ # Function to process a single string
+ process_string <- function(text) {
+ # Pattern to match single-quoted strings
+ quote_pattern <- "'[^']*'"
+
+ # Find all quoted strings and their positions
+ quotes <- gregexpr(quote_pattern, text, perl = TRUE)[[1]]
+
+ if (quotes[1] == -1) {
+ # No quoted strings, process entire text
+ if (preserve_newlines) {
+ return(gsub("[ \\t]{1,}", " ", text))
+ } else {
+ return(gsub("\\s{1,}", " ", text))
+ }
+ }
+
+ # Extract quoted strings
+ quote_lengths <- attr(quotes, "match.length")
+ quoted_parts <- substring(text, quotes, quotes + quote_lengths - 1)
+
+ # Create placeholders
+ placeholders <- paste0("__QUOTE_", seq_along(quoted_parts), "__")
+
+ # Replace quoted strings with placeholders
+ result <- text
+ for (i in seq_along(quoted_parts)) {
+ result <- sub(quote_pattern, placeholders[i], result, perl = TRUE)
+ }
+
+ # Collapse spaces in non-quoted parts
+ if (preserve_newlines) {
+ result <- gsub("[ \\t]{2,}", "", result)
+ } else {
+ result <- gsub("\\s{2,}", "", result)
+ }
+
+ # Restore quoted strings
+ for (i in seq_along(quoted_parts)) {
+ result <- sub(placeholders[i], quoted_parts[i], result, fixed = TRUE)
+ }
+
+ return(result)
+ }
+
+ # Apply to each element of vector
+ sapply(x, process_string, USE.NAMES = FALSE)
+}
#' Very simple function to remove nested lists, like when uploading .rds
#'
@@ -4301,7 +4369,7 @@ data_types <- function() {
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
########
-hosted_version <- function()'v25.11.1-251109'
+hosted_version <- function()'v25.12.1-251202'
########
@@ -9413,15 +9481,25 @@ prismCodeBlock <- function(code) {
prismDependencies <- tags$head(
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/prism.min.js"),
- tags$link(rel = "stylesheet", type = "text/css",
- href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
+ tags$link(
+ rel = "stylesheet", type = "text/css",
+ href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css"
+ ),
+ tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js"),
+ tags$link(
+ rel = "stylesheet",
+ href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/toolbar/prism-toolbar.min.css"
+ ),
+ tags$script(
+ src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/toolbar/prism-toolbar.min.js"
+ ),
+ tags$script(
+ src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/copy-to-clipboard/prism-copy-to-clipboard.min.js"
+ )
)
-prismRDependency <- tags$head(
- tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js")
-)
-html_code_wrap <- function(string,lang="r"){
+html_code_wrap <- function(string, lang = "r") {
glue::glue("{string}
")
}
@@ -10222,7 +10300,6 @@ ui_elements <- function(selection) {
#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R
########
-
## Works, but not implemented
##
## These edits mainly allows for
@@ -10325,7 +10402,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
moduleServer(
id,
function(input, output, session) {
-
rv <- reactiveValues(data = NULL, data_grid = NULL)
bindEvent(observe({
@@ -10431,19 +10507,37 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
data <- req(data_r())
variable <- req(input$variable)
grid <- req(input$grid_data)
- name_var <- if (isTRUE(input$new_var)) {
- paste0(variable, "_updated")
- } else {
- variable
- }
- data[[name_var]] <- factor(
- as.character(data[[variable]]),
- levels = grid[["Var1"]]
+
+ parameters <- list(
+ variable = variable,
+ new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
+ new_levels = as.character(grid[["Var1"]]),
+ new_labels = as.character(grid[["Var1_toset"]]),
+ ignore = "New label"
)
- data[[name_var]] <- factor(
- data[[variable]],
- labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+
+ data <- tryCatch(
+ {
+ 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:", err), type = "err")
+ }
)
+
+ # browser()
+ code <- rlang::call2(
+ "factor_new_levels_labels",
+ !!!parameters,
+ .ns = "FreesearchR"
+ )
+ attr(data, "code") <- code
+
data
})
@@ -10455,6 +10549,62 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
)
}
+#' Simple function to apply new levels and/or labels to factor
+#'
+#' @param variable factor variable
+#' @param new_level new levels, same length as original
+#' @param new_label new labels, same length as original
+#' @param ignore character string to ignore in new labels
+#'
+#' @returns factor
+#' @export
+#'
+#' @examples
+#' data_n <- mtcars
+#' data_n$cyl <- factor(data_n$cyl)
+#' factor_new_levels_labels(data_n, "cyl", new_labels = c("four", "New label", "New label"))
+factor_new_levels_labels <- function(
+ data,
+ variable,
+ new_variable = TRUE,
+ new_levels = NULL,
+ new_labels = NULL,
+ ignore = "New label") {
+ if (!is.factor(data[[variable]])) {
+ return(data)
+ }
+
+ if (is.null(new_levels)) {
+ new_levels <- levels(data[[variable]])
+ }
+
+ if (is.null(new_labels)) {
+ new_labels <- labels(data[[variable]])
+ }
+
+ with_level <- factor(
+ as.character(data[[variable]]),
+ levels = new_levels
+ )
+ with_label <- factor(
+ with_level,
+ labels = ifelse(new_labels == "New label", new_levels, new_labels)
+ )
+
+ # browser()
+
+ if (isTRUE(new_variable)) {
+ append_column(
+ data = data,
+ column = with_label,
+ name = unique_names(new = paste0(variable, "_updated"), existing = names(data))
+ )
+ } else {
+ data[[variable]] <- new_variable
+ data
+ }
+}
+
#' @inheritParams shiny::modalDialog
@@ -10514,6 +10664,25 @@ winbox_update_factor <- function(id,
}
+#' Make unique variable names
+#'
+#' Helper function to create new variable names that are unique
+#' given a set of existing names (in a data set, for example).
+#' If a variable name already exists, a number will be appended.
+#'
+#' @param new a vector of proposed new variable names
+#' @param existing a vector of existing variable names
+#' @return a vector of unique new variable names
+#' @examples
+#' unique_names(c("var_x", "var_y", "var_x"), c("var_x", "var_z"))
+#'
+#' @export
+unique_names <- function(new, existing = character()) {
+ new_names <- make.unique(c(existing, new), sep = "_")
+
+ new_names[-seq_along(existing)]
+}
+
########
#### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R
@@ -11817,7 +11986,6 @@ make_validation_alerts <- function(data) {
#' @returns Shiny ui module
#' @export
#'
-#' @example examples/visual_summary_demo.R
visual_summary_ui <- function(id) {
ns <- shiny::NS(id)
@@ -11911,14 +12079,6 @@ modal_visual_summary <- function(id,
#' @returns An [apexchart()] `htmlwidget` object.
#' @export
#'
-#' @examples
-#' data_demo <- mtcars
-#' data_demo[2:4, "cyl"] <- NA
-#' rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot()
-#' data_demo |> missings_apex_plot()
-#' mtcars |> missings_apex_plot(animation = TRUE)
-#' # dplyr::storms |> missings_apex_plot()
-#' visdat::vis_dat(dplyr::storms)
missings_apex_plot <- function(data, animation = FALSE, ...) {
l <- data_summary_gather(data, ...)
@@ -11969,14 +12129,6 @@ missings_apex_plot <- function(data, animation = FALSE, ...) {
#' @returns ggplot2 object
#' @export
#'
-#' @examples
-#' data_demo <- mtcars
-#' data_demo[sample(1:32, 10), "cyl"] <- NA
-#' data_demo[sample(1:32, 8), "vs"] <- NA
-#' visual_summary(data_demo)
-#' visual_summary(data_demo, palette.fun = scales::hue_pal())
-#' visual_summary(dplyr::storms, summary.fun = data_type)
-#' visual_summary(dplyr::storms, summary.fun = data_type, na.label = "Missings", legend.title = "Class")
visual_summary <- function(data, legend.title = NULL, ylab = "Observations", ...) {
l <- data_summary_gather(data, ...)
@@ -12028,7 +12180,7 @@ visual_summary <- function(data, legend.title = NULL, ylab = "Observations", ...
#' @export
#'
#' @examples
-#' mtcars |> data_summary_gather()
+#' mtcars |> data_summary_gather() |> names()
data_summary_gather <- function(data, summary.fun = class, palette.fun = viridisLite::viridis, na.label = "NA", ...) {
df_plot <- setNames(data, unique_short(names(data))) |>
purrr::map_df(\(x){
@@ -12308,7 +12460,6 @@ ui <- bslib::page_fixed(
usei18n(i18n),
## Code formatting dependencies
prismDependencies,
- prismRDependency,
# html_dependency_FreesearchR(),
## Version dependent header
header_include(),
@@ -12813,10 +12964,12 @@ server <- function(input, output, session) {
shiny::observeEvent(
input$modal_update,
- datamods::modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
+ # datamods::modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
+ modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
)
- data_modal_update <- datamods::update_factor_server(
+ # data_modal_update <- datamods::update_factor_server(
+ data_modal_update <- update_factor_server(
id = "modal_update",
data_r = reactive(rv$data)
)
@@ -13265,17 +13418,19 @@ server <- function(input, output, session) {
output$detail_level <- shiny::renderUI({
- shiny::radioButtons(
- inputId = "detail_level",
- label = i18n$t("Level of detail"),
- selected = "minimal",
- inline = TRUE,choiceValues = c("minimal",
- "extended"),
- choiceNames = c(
- i18n$t("Minimal"),
- i18n$t("Extensive")
+ shiny::radioButtons(
+ inputId = "detail_level",
+ label = i18n$t("Level of detail"),
+ selected = "minimal",
+ inline = TRUE, choiceValues = c(
+ "minimal",
+ "extended"
+ ),
+ choiceNames = c(
+ i18n$t("Minimal"),
+ i18n$t("Extensive")
+ )
)
- )
})
diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R
index 5ffb389a..6278a8e3 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//RtmpigVRui/file787d74b713ef.R
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpyM6210/file1267841f7ff86.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.10.5'
+app_version <- function()'25.12.1'
########
@@ -83,7 +83,6 @@ app_version <- function()'25.10.5'
#' mtcars |> baseline_table()
#' mtcars |> baseline_table(fun.args = list(by = "gear"))
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)
}
@@ -94,19 +93,26 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary,
#'
#' @param data data
#' @param ... passed as fun.arg to baseline_table()
-#' @param strat.var grouping/strat variable
#' @param add.p add comparison/p-value
#' @param add.overall add overall column
+#' @param by.var specify stratification variable
+#' @param theme set table theme
+#' @param detail_level specify detail level. Either "minimal" or "extended".
#'
#' @returns gtsummary table list object
#' @export
#'
#' @examples
#' mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
+#' mtcars |> create_baseline(by.var = "gear", detail_level = "extended")
+#' 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.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon")) {
+create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon"), detail_level = c("minimal", "extended")) {
theme <- match.arg(theme)
+ detail_level <- match.arg(detail_level)
+
if (by.var == "none" | !by.var %in% names(data)) {
by.var <- NULL
}
@@ -124,11 +130,32 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS
args <- list(...)
+ # browser()
+
+ 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}"))
+ )
+ )
+ }
+ }
+
parameters <- list(
data = data,
- fun.args = list(by = by.var, ...)
+ fun.args = purrr::list_flatten(list(by = by.var, args))
)
+
+ # browser()
out <- do.call(
baseline_table,
parameters
@@ -1629,7 +1656,11 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
}
)
- data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right")
+ data <- append_column(data,
+ column = new_variable,
+ name = unique_names(paste0(variable, "_cut"),
+ existing = names(data)),
+ index = "right")
code <- rlang::call2(
"append_column",
@@ -4033,18 +4064,82 @@ pipe_string <- function(data, collapse = "|>\n") {
#' @examples
#' list(
#' as.symbol(paste0("mtcars$", "mpg")),
-#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
+#' rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"),
#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
#' ) |>
#' merge_expression() |>
#' expression_string()
expression_string <- function(data, assign.str = "") {
exp.str <- if (is.call(data)) deparse(data) else data
- # browser()
+
out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", paste(exp.str, collapse = "")), collapse = "")))
- gsub(" |`", "", out)
+ out <- collapse_spaces(out,preserve_newlines = FALSE)
+ gsub("`", "", out)
}
+#' Substitue spaces/tabs with single space excluding text within quotes
+#'
+#' @description
+#' Written assisted by Claude.ai. It is long and possibly too complicated,
+#' but it works
+#'
+#'
+#' @param x character string
+#' @param preserve_newlines flag to preserve new lines
+#'
+#' @returns character string
+#'
+#' @examples
+#' collapse_spaces(c("cyl", "di sp","s e d","d e'dl e'"))
+collapse_spaces <- function(x, preserve_newlines = TRUE) {
+ # Function to process a single string
+ process_string <- function(text) {
+ # Pattern to match single-quoted strings
+ quote_pattern <- "'[^']*'"
+
+ # Find all quoted strings and their positions
+ quotes <- gregexpr(quote_pattern, text, perl = TRUE)[[1]]
+
+ if (quotes[1] == -1) {
+ # No quoted strings, process entire text
+ if (preserve_newlines) {
+ return(gsub("[ \\t]{1,}", " ", text))
+ } else {
+ return(gsub("\\s{1,}", " ", text))
+ }
+ }
+
+ # Extract quoted strings
+ quote_lengths <- attr(quotes, "match.length")
+ quoted_parts <- substring(text, quotes, quotes + quote_lengths - 1)
+
+ # Create placeholders
+ placeholders <- paste0("__QUOTE_", seq_along(quoted_parts), "__")
+
+ # Replace quoted strings with placeholders
+ result <- text
+ for (i in seq_along(quoted_parts)) {
+ result <- sub(quote_pattern, placeholders[i], result, perl = TRUE)
+ }
+
+ # Collapse spaces in non-quoted parts
+ if (preserve_newlines) {
+ result <- gsub("[ \\t]{2,}", "", result)
+ } else {
+ result <- gsub("\\s{2,}", "", result)
+ }
+
+ # Restore quoted strings
+ for (i in seq_along(quoted_parts)) {
+ result <- sub(placeholders[i], quoted_parts[i], result, fixed = TRUE)
+ }
+
+ return(result)
+ }
+
+ # Apply to each element of vector
+ sapply(x, process_string, USE.NAMES = FALSE)
+}
#' Very simple function to remove nested lists, like when uploading .rds
#'
@@ -4274,7 +4369,7 @@ data_types <- function() {
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
########
-hosted_version <- function()'v25.10.5-251031'
+hosted_version <- function()'v25.12.1-251202'
########
@@ -9386,15 +9481,25 @@ prismCodeBlock <- function(code) {
prismDependencies <- tags$head(
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/prism.min.js"),
- tags$link(rel = "stylesheet", type = "text/css",
- href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
+ tags$link(
+ rel = "stylesheet", type = "text/css",
+ href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css"
+ ),
+ tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js"),
+ tags$link(
+ rel = "stylesheet",
+ href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/toolbar/prism-toolbar.min.css"
+ ),
+ tags$script(
+ src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/toolbar/prism-toolbar.min.js"
+ ),
+ tags$script(
+ src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.29.0/plugins/copy-to-clipboard/prism-copy-to-clipboard.min.js"
+ )
)
-prismRDependency <- tags$head(
- tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js")
-)
-html_code_wrap <- function(string,lang="r"){
+html_code_wrap <- function(string, lang = "r") {
glue::glue("{string}
")
}
@@ -9914,6 +10019,17 @@ ui_elements <- function(selection) {
value = "acc_pan_chars",
title = "Settings",
icon = bsicons::bs_icon("table"),
+ # vectorSelectInput(
+ # inputId = "baseline_theme",
+ # selected = "none",
+ # label = i18n$t("Select table theme"),
+ # choices = c(
+ # "The Journal of the American Medical Association" = "jama",
+ # "The Lancet"="lancet",
+ # "The New England Journal of Medicine" = "nejm",
+ # "The Quarterly Journal of Economics" = "qjecon")
+ # ),
+ shiny::uiOutput("detail_level"),
shiny::uiOutput("strat_var"),
shiny::helpText(i18n$t("Only factor/categorical variables are available for stratification. Go back to the 'Prepare' tab to reclass a variable if it's not on the list.")),
shiny::conditionalPanel(
@@ -10184,7 +10300,6 @@ ui_elements <- function(selection) {
#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R
########
-
## Works, but not implemented
##
## These edits mainly allows for
@@ -10287,7 +10402,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
moduleServer(
id,
function(input, output, session) {
-
rv <- reactiveValues(data = NULL, data_grid = NULL)
bindEvent(observe({
@@ -10393,19 +10507,37 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
data <- req(data_r())
variable <- req(input$variable)
grid <- req(input$grid_data)
- name_var <- if (isTRUE(input$new_var)) {
- paste0(variable, "_updated")
- } else {
- variable
- }
- data[[name_var]] <- factor(
- as.character(data[[variable]]),
- levels = grid[["Var1"]]
+
+ parameters <- list(
+ variable = variable,
+ new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
+ new_levels = as.character(grid[["Var1"]]),
+ new_labels = as.character(grid[["Var1_toset"]]),
+ ignore = "New label"
)
- data[[name_var]] <- factor(
- data[[variable]],
- labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+
+ data <- tryCatch(
+ {
+ 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:", err), type = "err")
+ }
)
+
+ # browser()
+ code <- rlang::call2(
+ "factor_new_levels_labels",
+ !!!parameters,
+ .ns = "FreesearchR"
+ )
+ attr(data, "code") <- code
+
data
})
@@ -10417,6 +10549,62 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
)
}
+#' Simple function to apply new levels and/or labels to factor
+#'
+#' @param variable factor variable
+#' @param new_level new levels, same length as original
+#' @param new_label new labels, same length as original
+#' @param ignore character string to ignore in new labels
+#'
+#' @returns factor
+#' @export
+#'
+#' @examples
+#' data_n <- mtcars
+#' data_n$cyl <- factor(data_n$cyl)
+#' factor_new_levels_labels(data_n, "cyl", new_labels = c("four", "New label", "New label"))
+factor_new_levels_labels <- function(
+ data,
+ variable,
+ new_variable = TRUE,
+ new_levels = NULL,
+ new_labels = NULL,
+ ignore = "New label") {
+ if (!is.factor(data[[variable]])) {
+ return(data)
+ }
+
+ if (is.null(new_levels)) {
+ new_levels <- levels(data[[variable]])
+ }
+
+ if (is.null(new_labels)) {
+ new_labels <- labels(data[[variable]])
+ }
+
+ with_level <- factor(
+ as.character(data[[variable]]),
+ levels = new_levels
+ )
+ with_label <- factor(
+ with_level,
+ labels = ifelse(new_labels == "New label", new_levels, new_labels)
+ )
+
+ # browser()
+
+ if (isTRUE(new_variable)) {
+ append_column(
+ data = data,
+ column = with_label,
+ name = unique_names(new = paste0(variable, "_updated"), existing = names(data))
+ )
+ } else {
+ data[[variable]] <- new_variable
+ data
+ }
+}
+
#' @inheritParams shiny::modalDialog
@@ -10476,6 +10664,25 @@ winbox_update_factor <- function(id,
}
+#' Make unique variable names
+#'
+#' Helper function to create new variable names that are unique
+#' given a set of existing names (in a data set, for example).
+#' If a variable name already exists, a number will be appended.
+#'
+#' @param new a vector of proposed new variable names
+#' @param existing a vector of existing variable names
+#' @return a vector of unique new variable names
+#' @examples
+#' unique_names(c("var_x", "var_y", "var_x"), c("var_x", "var_z"))
+#'
+#' @export
+unique_names <- function(new, existing = character()) {
+ new_names <- make.unique(c(existing, new), sep = "_")
+
+ new_names[-seq_along(existing)]
+}
+
########
#### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R
@@ -11779,7 +11986,6 @@ make_validation_alerts <- function(data) {
#' @returns Shiny ui module
#' @export
#'
-#' @example examples/visual_summary_demo.R
visual_summary_ui <- function(id) {
ns <- shiny::NS(id)
@@ -11873,14 +12079,6 @@ modal_visual_summary <- function(id,
#' @returns An [apexchart()] `htmlwidget` object.
#' @export
#'
-#' @examples
-#' data_demo <- mtcars
-#' data_demo[2:4, "cyl"] <- NA
-#' rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot()
-#' data_demo |> missings_apex_plot()
-#' mtcars |> missings_apex_plot(animation = TRUE)
-#' # dplyr::storms |> missings_apex_plot()
-#' visdat::vis_dat(dplyr::storms)
missings_apex_plot <- function(data, animation = FALSE, ...) {
l <- data_summary_gather(data, ...)
@@ -11931,14 +12129,6 @@ missings_apex_plot <- function(data, animation = FALSE, ...) {
#' @returns ggplot2 object
#' @export
#'
-#' @examples
-#' data_demo <- mtcars
-#' data_demo[sample(1:32, 10), "cyl"] <- NA
-#' data_demo[sample(1:32, 8), "vs"] <- NA
-#' visual_summary(data_demo)
-#' visual_summary(data_demo, palette.fun = scales::hue_pal())
-#' visual_summary(dplyr::storms, summary.fun = data_type)
-#' visual_summary(dplyr::storms, summary.fun = data_type, na.label = "Missings", legend.title = "Class")
visual_summary <- function(data, legend.title = NULL, ylab = "Observations", ...) {
l <- data_summary_gather(data, ...)
@@ -11990,7 +12180,7 @@ visual_summary <- function(data, legend.title = NULL, ylab = "Observations", ...
#' @export
#'
#' @examples
-#' mtcars |> data_summary_gather()
+#' mtcars |> data_summary_gather() |> names()
data_summary_gather <- function(data, summary.fun = class, palette.fun = viridisLite::viridis, na.label = "NA", ...) {
df_plot <- setNames(data, unique_short(names(data))) |>
purrr::map_df(\(x){
@@ -12270,7 +12460,6 @@ ui <- bslib::page_fixed(
usei18n(i18n),
## Code formatting dependencies
prismDependencies,
- prismRDependency,
# html_dependency_FreesearchR(),
## Version dependent header
header_include(),
@@ -12775,10 +12964,12 @@ server <- function(input, output, session) {
shiny::observeEvent(
input$modal_update,
- datamods::modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
+ # datamods::modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
+ modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
)
- data_modal_update <- datamods::update_factor_server(
+ # data_modal_update <- datamods::update_factor_server(
+ data_modal_update <- update_factor_server(
id = "modal_update",
data_r = reactive(rv$data)
)
@@ -13201,7 +13392,7 @@ server <- function(input, output, session) {
columnSelectInput(
inputId = "strat_var",
selected = "none",
- label = "Select variable to stratify baseline",
+ label = i18n$t("Select variable to stratify baseline"),
data = shiny::reactive(rv$data_filtered)(),
col_subset = c(
"none",
@@ -13210,6 +13401,39 @@ server <- function(input, output, session) {
)
})
+ # output$baseline_theme <- shiny::renderUI({
+ # choices <-
+ #
+ # vectorSelectInput(
+ # inputId = "baseline_theme",
+ # selected = "none",
+ # label = i18n$t("Select table theme"),
+ # choices = c(
+ # "The Journal of the American Medical Association" = "jama",
+ # "The Lancet"="lancet",
+ # "The New England Journal of Medicine" = "nejm",
+ # "The Quarterly Journal of Economics" = "qjecon")
+ # )
+ # })
+
+
+ output$detail_level <- shiny::renderUI({
+ shiny::radioButtons(
+ inputId = "detail_level",
+ label = i18n$t("Level of detail"),
+ selected = "minimal",
+ inline = TRUE, choiceValues = c(
+ "minimal",
+ "extended"
+ ),
+ choiceNames = c(
+ i18n$t("Minimal"),
+ i18n$t("Extensive")
+ )
+ )
+ })
+
+
##############################################################################
#########
######### Descriptive evaluations
@@ -13235,30 +13459,39 @@ server <- function(input, output, session) {
# })
+
+
shiny::observeEvent(
list(
input$act_eval
),
{
shiny::req(input$strat_var)
+ # shiny::req(input$baseline_theme)
+ shiny::req(input$detail_level)
shiny::req(rv$list$data)
+
+
parameters <- list(
by.var = input$strat_var,
add.p = input$add_p == "yes",
- add.overall = TRUE
+ add.overall = TRUE,
+ # theme = input$baseline_theme,
+ detail_level = input$detail_level
)
## Limits maximum number of levels included in baseline table to 20.
data <- rv$list$data |>
lapply(\(.x){
# browser()
- if (is.factor(.x)){
- cut_var(.x,breaks=20,type="top")
+ if (is.factor(.x)) {
+ cut_var(.x, breaks = 20, type = "top")
} else {
.x
}
- }) |> dplyr::bind_cols()
+ }) |>
+ dplyr::bind_cols()
# Attempt to introduce error on analysing too large dataset
# tryCatch(
diff --git a/man/collapse_spaces.Rd b/man/collapse_spaces.Rd
new file mode 100644
index 00000000..f93d5415
--- /dev/null
+++ b/man/collapse_spaces.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers.R
+\name{collapse_spaces}
+\alias{collapse_spaces}
+\title{Substitue spaces/tabs with single space excluding text within quotes}
+\usage{
+collapse_spaces(x, preserve_newlines = TRUE)
+}
+\arguments{
+\item{x}{character string}
+
+\item{preserve_newlines}{flag to preserve new lines}
+}
+\value{
+character string
+}
+\description{
+Written assisted by Claude.ai. It is long and possibly too complicated,
+but it works
+}
+\examples{
+collapse_spaces(c("cyl", "di sp","s e d","d e'dl e'"))
+}
diff --git a/man/expression_string.Rd b/man/expression_string.Rd
index 82719129..24487f0e 100644
--- a/man/expression_string.Rd
+++ b/man/expression_string.Rd
@@ -18,7 +18,7 @@ Deparses expression as string, substitutes native pipe and adds assign
\examples{
list(
as.symbol(paste0("mtcars$", "mpg")),
- rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"),
+ rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"),
rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
) |>
merge_expression() |>
diff --git a/man/factor_new_levels_labels.Rd b/man/factor_new_levels_labels.Rd
new file mode 100644
index 00000000..8a360e2a
--- /dev/null
+++ b/man/factor_new_levels_labels.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/update-factor-ext.R
+\name{factor_new_levels_labels}
+\alias{factor_new_levels_labels}
+\title{Simple function to apply new levels and/or labels to factor}
+\usage{
+factor_new_levels_labels(
+ data,
+ variable,
+ new_variable = TRUE,
+ new_levels = NULL,
+ new_labels = NULL,
+ ignore = "New label"
+)
+}
+\arguments{
+\item{variable}{factor variable}
+
+\item{ignore}{character string to ignore in new labels}
+
+\item{new_level}{new levels, same length as original}
+
+\item{new_label}{new labels, same length as original}
+}
+\value{
+factor
+}
+\description{
+Simple function to apply new levels and/or labels to factor
+}
+\examples{
+data_n <- mtcars
+data_n$cyl <- factor(data_n$cyl)
+factor_new_levels_labels(data_n, "cyl", new_labels = c("four", "New label", "New label"))
+}
diff --git a/man/unique_names.Rd b/man/unique_names.Rd
new file mode 100644
index 00000000..c6736652
--- /dev/null
+++ b/man/unique_names.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/update-factor-ext.R
+\name{unique_names}
+\alias{unique_names}
+\title{Make unique variable names}
+\usage{
+unique_names(new, existing = character())
+}
+\arguments{
+\item{new}{a vector of proposed new variable names}
+
+\item{existing}{a vector of existing variable names}
+}
+\value{
+a vector of unique new variable names
+}
+\description{
+Helper function to create new variable names that are unique
+given a set of existing names (in a data set, for example).
+If a variable name already exists, a number will be appended.
+}
+\examples{
+unique_names(c("var_x", "var_y", "var_x"), c("var_x", "var_z"))
+
+}