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