diff --git a/CITATION.cff b/CITATION.cff index 41ce08b6..fcab7f68 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -8,7 +8,7 @@ message: 'To cite package "FreesearchR" in publications use:' type: software license: AGPL-3.0-or-later title: 'FreesearchR: Easy data analysis for clinicians' -version: 25.12.1 +version: 25.11.1 doi: 10.5281/zenodo.14527429 identifiers: - type: url @@ -1063,40 +1063,6 @@ 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 035421e6..7301de4b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 25.12.1 +Version: 25.11.2 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), diff --git a/NAMESPACE b/NAMESPACE index 1365c2d0..127b112c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -51,7 +51,6 @@ 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) @@ -149,7 +148,6 @@ 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 9e59a927..6a4a4600 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,11 +1,3 @@ -# 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 c86ba1bf..54c6cdf0 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'25.12.1' +app_version <- function()'25.11.2' diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index cb27543c..c1879b7c 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -374,11 +374,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { } ) - data <- append_column(data, - column = new_variable, - name = unique_names(paste0(variable, "_cut"), - existing = names(data)), - index = "right") + data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right") code <- rlang::call2( "append_column", diff --git a/R/helpers.R b/R/helpers.R index 635f6799..c038c5c1 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -515,82 +515,18 @@ pipe_string <- function(data, collapse = "|>\n") { #' @examples #' list( #' as.symbol(paste0("mtcars$", "mpg")), -#' rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"), +#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .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 = ""))) - out <- collapse_spaces(out,preserve_newlines = FALSE) - gsub("`", "", out) + 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 920e146f..b477b7ff 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v25.12.1-251202' +hosted_version <- function()'v25.11.2-251119' diff --git a/R/syntax_highlight.R b/R/syntax_highlight.R index 29ae8a82..e90f14b1 100644 --- a/R/syntax_highlight.R +++ b/R/syntax_highlight.R @@ -11,25 +11,15 @@ 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$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" - ) + tags$link(rel = "stylesheet", type = "text/css", + href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css") ) +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 d5263737..d644c198 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 a895350f..7c1236e0 100644
--- a/R/update-factor-ext.R
+++ b/R/update-factor-ext.R
@@ -1,3 +1,4 @@
+
## Works, but not implemented
##
## These edits mainly allows for
@@ -100,6 +101,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
moduleServer(
id,
function(input, output, session) {
+
rv <- reactiveValues(data = NULL, data_grid = NULL)
bindEvent(observe({
@@ -205,37 +207,19 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
data <- req(data_r())
variable <- req(input$variable)
grid <- req(input$grid_data)
-
- 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"
+ name_var <- if (isTRUE(input$new_var)) {
+ paste0(variable, "_updated")
+ } else {
+ variable
+ }
+ data[[name_var]] <- factor(
+ as.character(data[[variable]]),
+ levels = grid[["Var1"]]
)
-
- 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(
+ data[[variable]],
+ labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
)
-
- # browser()
- code <- rlang::call2(
- "factor_new_levels_labels",
- !!!parameters,
- .ns = "FreesearchR"
- )
- attr(data, "code") <- code
-
data
})
@@ -247,62 +231,6 @@ 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
@@ -361,22 +289,3 @@ 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 41b64837..80527531 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 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 |
+|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 |
--------------------------------------------------------------------------------
@@ -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.12.1 |NA |NA |
+|FreesearchR |25.11.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,9 +117,11 @@
|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 5e769d05..0f193d1d 100644
--- a/app_docker/app.R
+++ b/app_docker/app.R
@@ -1,7 +1,7 @@
########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpyM6210/file126781ad7585e.R
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpFr1XvR/file15f634a33505f.R
########
i18n_path <- here::here("translations")
@@ -62,7 +62,7 @@ i18n$set_translation_language("en")
#### Current file: /Users/au301842/FreesearchR/R//app_version.R
########
-app_version <- function()'25.12.1'
+app_version <- function()'25.11.1'
########
@@ -1656,11 +1656,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
}
)
- data <- append_column(data,
- column = new_variable,
- name = unique_names(paste0(variable, "_cut"),
- existing = names(data)),
- index = "right")
+ data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right")
code <- rlang::call2(
"append_column",
@@ -4064,82 +4060,18 @@ pipe_string <- function(data, collapse = "|>\n") {
#' @examples
#' list(
#' as.symbol(paste0("mtcars$", "mpg")),
-#' rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"),
+#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .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 = "")))
- out <- collapse_spaces(out,preserve_newlines = FALSE)
- gsub("`", "", out)
+ 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
#'
@@ -4369,7 +4301,7 @@ data_types <- function() {
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
########
-hosted_version <- function()'v25.12.1-251202'
+hosted_version <- function()'v25.11.1-251109'
########
@@ -9481,25 +9413,15 @@ 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$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"
- )
+ tags$link(rel = "stylesheet", type = "text/css",
+ href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
)
+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}
")
}
@@ -10300,6 +10222,7 @@ ui_elements <- function(selection) {
#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R
########
+
## Works, but not implemented
##
## These edits mainly allows for
@@ -10402,6 +10325,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
moduleServer(
id,
function(input, output, session) {
+
rv <- reactiveValues(data = NULL, data_grid = NULL)
bindEvent(observe({
@@ -10507,37 +10431,19 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
data <- req(data_r())
variable <- req(input$variable)
grid <- req(input$grid_data)
-
- 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"
+ name_var <- if (isTRUE(input$new_var)) {
+ paste0(variable, "_updated")
+ } else {
+ variable
+ }
+ data[[name_var]] <- factor(
+ as.character(data[[variable]]),
+ levels = grid[["Var1"]]
)
-
- 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(
+ data[[variable]],
+ labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
)
-
- # browser()
- code <- rlang::call2(
- "factor_new_levels_labels",
- !!!parameters,
- .ns = "FreesearchR"
- )
- attr(data, "code") <- code
-
data
})
@@ -10549,62 +10455,6 @@ 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
@@ -10664,25 +10514,6 @@ 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
@@ -11986,6 +11817,7 @@ 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)
@@ -12079,6 +11911,14 @@ 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, ...)
@@ -12129,6 +11969,14 @@ 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, ...)
@@ -12180,7 +12028,7 @@ visual_summary <- function(data, legend.title = NULL, ylab = "Observations", ...
#' @export
#'
#' @examples
-#' mtcars |> data_summary_gather() |> names()
+#' mtcars |> data_summary_gather()
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){
@@ -12460,6 +12308,7 @@ ui <- bslib::page_fixed(
usei18n(i18n),
## Code formatting dependencies
prismDependencies,
+ prismRDependency,
# html_dependency_FreesearchR(),
## Version dependent header
header_include(),
@@ -12964,12 +12813,10 @@ server <- function(input, output, session) {
shiny::observeEvent(
input$modal_update,
- # 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"))
+ datamods::modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
)
- # data_modal_update <- datamods::update_factor_server(
- data_modal_update <- update_factor_server(
+ data_modal_update <- datamods::update_factor_server(
id = "modal_update",
data_r = reactive(rv$data)
)
@@ -13418,19 +13265,17 @@ 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 6278a8e3..5ffb389a 100644
--- a/inst/apps/FreesearchR/app.R
+++ b/inst/apps/FreesearchR/app.R
@@ -1,7 +1,7 @@
########
-#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpyM6210/file1267841f7ff86.R
+#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpigVRui/file787d74b713ef.R
########
i18n_path <- system.file("translations", package = "FreesearchR")
@@ -62,7 +62,7 @@ i18n$set_translation_language("en")
#### Current file: /Users/au301842/FreesearchR/R//app_version.R
########
-app_version <- function()'25.12.1'
+app_version <- function()'25.10.5'
########
@@ -83,6 +83,7 @@ app_version <- function()'25.12.1'
#' 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)
}
@@ -93,26 +94,19 @@ 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"), detail_level = c("minimal", "extended")) {
+create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon")) {
theme <- match.arg(theme)
- detail_level <- match.arg(detail_level)
-
if (by.var == "none" | !by.var %in% names(data)) {
by.var <- NULL
}
@@ -130,32 +124,11 @@ 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 = purrr::list_flatten(list(by = by.var, args))
+ fun.args = list(by = by.var, ...)
)
-
- # browser()
out <- do.call(
baseline_table,
parameters
@@ -1656,11 +1629,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
}
)
- data <- append_column(data,
- column = new_variable,
- name = unique_names(paste0(variable, "_cut"),
- existing = names(data)),
- index = "right")
+ data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right")
code <- rlang::call2(
"append_column",
@@ -4064,82 +4033,18 @@ pipe_string <- function(data, collapse = "|>\n") {
#' @examples
#' list(
#' as.symbol(paste0("mtcars$", "mpg")),
-#' rlang::call2(.fn = "select", !!!list(c("cyl", "di sp")), .ns = "dplyr"),
+#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .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 = "")))
- out <- collapse_spaces(out,preserve_newlines = FALSE)
- gsub("`", "", out)
+ 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
#'
@@ -4369,7 +4274,7 @@ data_types <- function() {
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
########
-hosted_version <- function()'v25.12.1-251202'
+hosted_version <- function()'v25.10.5-251031'
########
@@ -9481,25 +9386,15 @@ 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$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"
- )
+ tags$link(rel = "stylesheet", type = "text/css",
+ href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css")
)
+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}
")
}
@@ -10019,17 +9914,6 @@ 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(
@@ -10300,6 +10184,7 @@ ui_elements <- function(selection) {
#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R
########
+
## Works, but not implemented
##
## These edits mainly allows for
@@ -10402,6 +10287,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
moduleServer(
id,
function(input, output, session) {
+
rv <- reactiveValues(data = NULL, data_grid = NULL)
bindEvent(observe({
@@ -10507,37 +10393,19 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
data <- req(data_r())
variable <- req(input$variable)
grid <- req(input$grid_data)
-
- 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"
+ name_var <- if (isTRUE(input$new_var)) {
+ paste0(variable, "_updated")
+ } else {
+ variable
+ }
+ data[[name_var]] <- factor(
+ as.character(data[[variable]]),
+ levels = grid[["Var1"]]
)
-
- 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(
+ data[[variable]],
+ labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
)
-
- # browser()
- code <- rlang::call2(
- "factor_new_levels_labels",
- !!!parameters,
- .ns = "FreesearchR"
- )
- attr(data, "code") <- code
-
data
})
@@ -10549,62 +10417,6 @@ 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
@@ -10664,25 +10476,6 @@ 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
@@ -11986,6 +11779,7 @@ 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)
@@ -12079,6 +11873,14 @@ 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, ...)
@@ -12129,6 +11931,14 @@ 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, ...)
@@ -12180,7 +11990,7 @@ visual_summary <- function(data, legend.title = NULL, ylab = "Observations", ...
#' @export
#'
#' @examples
-#' mtcars |> data_summary_gather() |> names()
+#' mtcars |> data_summary_gather()
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){
@@ -12460,6 +12270,7 @@ ui <- bslib::page_fixed(
usei18n(i18n),
## Code formatting dependencies
prismDependencies,
+ prismRDependency,
# html_dependency_FreesearchR(),
## Version dependent header
header_include(),
@@ -12964,12 +12775,10 @@ server <- function(input, output, session) {
shiny::observeEvent(
input$modal_update,
- # 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"))
+ datamods::modal_update_factor(id = "modal_update", title = i18n$t("Reorder factor levels"))
)
- # data_modal_update <- datamods::update_factor_server(
- data_modal_update <- update_factor_server(
+ data_modal_update <- datamods::update_factor_server(
id = "modal_update",
data_r = reactive(rv$data)
)
@@ -13392,7 +13201,7 @@ server <- function(input, output, session) {
columnSelectInput(
inputId = "strat_var",
selected = "none",
- label = i18n$t("Select variable to stratify baseline"),
+ label = "Select variable to stratify baseline",
data = shiny::reactive(rv$data_filtered)(),
col_subset = c(
"none",
@@ -13401,39 +13210,6 @@ 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
@@ -13459,39 +13235,30 @@ 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,
- # theme = input$baseline_theme,
- detail_level = input$detail_level
+ add.overall = TRUE
)
## 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
deleted file mode 100644
index f93d5415..00000000
--- a/man/collapse_spaces.Rd
+++ /dev/null
@@ -1,23 +0,0 @@
-% 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 24487f0e..82719129 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", "di sp")), .ns = "dplyr"),
+ rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .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
deleted file mode 100644
index 8a360e2a..00000000
--- a/man/factor_new_levels_labels.Rd
+++ /dev/null
@@ -1,35 +0,0 @@
-% 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
deleted file mode 100644
index c6736652..00000000
--- a/man/unique_names.Rd
+++ /dev/null
@@ -1,25 +0,0 @@
-% 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"))
-
-}