mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-12-15 17:12:09 +01:00
This commit is contained in:
parent
8c7fafe51c
commit
cc853b2ede
2 changed files with 501 additions and 113 deletions
269
app_docker/app.R
269
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("<pre><code class='language-{lang}'>{string}
|
||||
</code></pre>")
|
||||
}
|
||||
|
|
@ -10222,7 +10300,6 @@ ui_elements <- function(selection) {
|
|||
#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R
|
||||
########
|
||||
|
||||
|
||||
## Works, but not implemented
|
||||
##
|
||||
## These edits mainly allows for
|
||||
|
|
@ -10325,7 +10402,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
|
|||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
|
||||
rv <- reactiveValues(data = NULL, data_grid = NULL)
|
||||
|
||||
bindEvent(observe({
|
||||
|
|
@ -10431,19 +10507,37 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
|
|||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
grid <- req(input$grid_data)
|
||||
name_var <- if (isTRUE(input$new_var)) {
|
||||
paste0(variable, "_updated")
|
||||
} 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")
|
||||
)
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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("<pre><code class='language-{lang}'>{string}
|
||||
</code></pre>")
|
||||
}
|
||||
|
|
@ -9914,6 +10019,17 @@ ui_elements <- function(selection) {
|
|||
value = "acc_pan_chars",
|
||||
title = "Settings",
|
||||
icon = bsicons::bs_icon("table"),
|
||||
# vectorSelectInput(
|
||||
# inputId = "baseline_theme",
|
||||
# selected = "none",
|
||||
# label = i18n$t("Select table theme"),
|
||||
# choices = c(
|
||||
# "The Journal of the American Medical Association" = "jama",
|
||||
# "The Lancet"="lancet",
|
||||
# "The New England Journal of Medicine" = "nejm",
|
||||
# "The Quarterly Journal of Economics" = "qjecon")
|
||||
# ),
|
||||
shiny::uiOutput("detail_level"),
|
||||
shiny::uiOutput("strat_var"),
|
||||
shiny::helpText(i18n$t("Only factor/categorical variables are available for stratification. Go back to the 'Prepare' tab to reclass a variable if it's not on the list.")),
|
||||
shiny::conditionalPanel(
|
||||
|
|
@ -10184,7 +10300,6 @@ ui_elements <- function(selection) {
|
|||
#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R
|
||||
########
|
||||
|
||||
|
||||
## Works, but not implemented
|
||||
##
|
||||
## These edits mainly allows for
|
||||
|
|
@ -10287,7 +10402,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
|
|||
moduleServer(
|
||||
id,
|
||||
function(input, output, session) {
|
||||
|
||||
rv <- reactiveValues(data = NULL, data_grid = NULL)
|
||||
|
||||
bindEvent(observe({
|
||||
|
|
@ -10393,19 +10507,37 @@ update_factor_server <- function(id, data_r = reactive(NULL)) {
|
|||
data <- req(data_r())
|
||||
variable <- req(input$variable)
|
||||
grid <- req(input$grid_data)
|
||||
name_var <- if (isTRUE(input$new_var)) {
|
||||
paste0(variable, "_updated")
|
||||
} 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(
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue