new version coming

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'

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")),

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)

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.

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'25.11.2'
+app_version <- function()'25.12.1'

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",

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
 #'

R/hosted_version.R

@@ -1 +1 @@
-hosted_version <- function()'v25.11.2-251119'
+hosted_version <- function()'v25.12.1-251202'

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",
+  tags$link(
-            href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
+    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("<pre><code class='language-{lang}'>{string}
   </code></pre>")
 }

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")
+        parameters <- list(
-        } else {
+          variable = variable,
-          variable
+          new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
-        }
+          new_levels = as.character(grid[["Var1"]]),
-        data[[name_var]] <- factor(
+          new_labels = as.character(grid[["Var1_toset"]]),
-          as.character(data[[variable]]),
+          ignore = "New label"
-          levels = grid[["Var1"]]
         )
-        data[[name_var]] <- factor(
+
-          data[[variable]],
+        data <- tryCatch(
-          labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+          {
+            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)]
+}

SESSION.md

@@ -1,21 +1,21 @@
 --------------------------------------------------------------------------------
 -------------------------------- R environment ---------------------------------
 --------------------------------------------------------------------------------
-|setting     |value                                      |
+|setting     |value                                          |
-|:-----------|:------------------------------------------|
+|:-----------|:----------------------------------------------|
-|version     |R version 4.4.1 (2024-06-14)               |
+|version     |R version 4.4.1 (2024-06-14)                   |
-|os          |macOS 15.7.1                               |
+|os          |macOS 26.1                                     |
-|system      |aarch64, darwin20                          |
+|system      |aarch64, darwin20                              |
-|ui          |RStudio                                    |
+|ui          |RStudio                                        |
-|language    |(EN)                                       |
+|language    |(EN)                                           |
-|collate     |en_US.UTF-8                                |
+|collate     |en_US.UTF-8                                    |
-|ctype       |en_US.UTF-8                                |
+|ctype       |en_US.UTF-8                                    |
-|tz          |Europe/Copenhagen                          |
+|tz          |Europe/Copenhagen                              |
-|date        |2025-11-09                                 |
+|date        |2025-12-02                                     |
-|rstudio     |2025.05.0+496 Mariposa Orchid (desktop)    |
+|rstudio     |2025.09.2+418 Cucumberleaf Sunflower (desktop) |
-|pandoc      |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
+|pandoc      |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown)     |
-|quarto      |1.7.30 @ /usr/local/bin/quarto             |
+|quarto      |1.7.30 @ /usr/local/bin/quarto                 |
-|FreesearchR |25.11.1.251109                             |
+|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) |

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",
+  tags$link(
-            href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
+    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("<pre><code class='language-{lang}'>{string}
   </code></pre>")
 }
@@ -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")
+        parameters <- list(
-        } else {
+          variable = variable,
-          variable
+          new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
-        }
+          new_levels = as.character(grid[["Var1"]]),
-        data[[name_var]] <- factor(
+          new_labels = as.character(grid[["Var1_toset"]]),
-          as.character(data[[variable]]),
+          ignore = "New label"
-          levels = grid[["Var1"]]
         )
-        data[[name_var]] <- factor(
+
-          data[[variable]],
+        data <- tryCatch(
-          labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+          {
+            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(
+    shiny::radioButtons(
-    inputId = "detail_level",
+      inputId = "detail_level",
-    label = i18n$t("Level of detail"),
+      label = i18n$t("Level of detail"),
-    selected = "minimal",
+      selected = "minimal",
-    inline = TRUE,choiceValues = c("minimal",
+      inline = TRUE, choiceValues = c(
-                                   "extended"),
+        "minimal",
-    choiceNames = c(
+        "extended"
-      i18n$t("Minimal"),
+      ),
-      i18n$t("Extensive")
+      choiceNames = c(
+        i18n$t("Minimal"),
+        i18n$t("Extensive")
+      )
     )
-  )
   })
 
 

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",
+  tags$link(
-            href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
+    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("<pre><code class='language-{lang}'>{string}
   </code></pre>")
 }
@@ -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")
+        parameters <- list(
-        } else {
+          variable = variable,
-          variable
+          new_variable = isTRUE(input$new_var) | any(grid[["Var1_toset"]] == "New label"),
-        }
+          new_levels = as.character(grid[["Var1"]]),
-        data[[name_var]] <- factor(
+          new_labels = as.character(grid[["Var1_toset"]]),
-          as.character(data[[variable]]),
+          ignore = "New label"
-          levels = grid[["Var1"]]
         )
-        data[[name_var]] <- factor(
+
-          data[[variable]],
+        data <- tryCatch(
-          labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+          {
+            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)){
+          if (is.factor(.x)) {
-            cut_var(.x,breaks=20,type="top")
+            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(

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'"))
+}

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() |>

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"))
+}

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"))
+
+}