new version coming

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",
@@ -4067,11 +4071,75 @@ pipe_string <- function(data, collapse = "|>\n") {
 #'   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,13 +9481,23 @@ 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") {
   glue::glue("<pre><code class='language-{lang}'>{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")
+        parameters <- list(
-        } else {
+          variable = 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 <- 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")
           }
-        data[[name_var]] <- factor(
-          as.character(data[[variable]]),
-          levels = grid[["Var1"]]
         )
-        data[[name_var]] <- factor(
+
-          data[[variable]],
+        # browser()
-          labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+        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)
   )
@@ -13269,8 +13422,10 @@ server <- function(input, output, session) {
       inputId = "detail_level",
       label = i18n$t("Level of detail"),
       selected = "minimal",
-    inline = TRUE,choiceValues = c("minimal",
+      inline = TRUE, choiceValues = c(
-                                   "extended"),
+        "minimal",
+        "extended"
+      ),
       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",
@@ -4040,11 +4071,75 @@ pipe_string <- function(data, collapse = "|>\n") {
 #'   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,13 +9481,23 @@ 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") {
   glue::glue("<pre><code class='language-{lang}'>{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")
+        parameters <- list(
-        } else {
+          variable = 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 <- 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")
           }
-        data[[name_var]] <- factor(
-          as.character(data[[variable]]),
-          levels = grid[["Var1"]]
         )
-        data[[name_var]] <- factor(
+
-          data[[variable]],
+        # browser()
-          labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+        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,18 +13459,26 @@ 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.
@@ -13258,7 +13490,8 @@ server <- function(input, output, session) {
           } else {
             .x
           }
-        }) |> dplyr::bind_cols()
+        }) |>
+        dplyr::bind_cols()
 
       # Attempt to introduce error on analysing too large dataset
       # tryCatch(