diff --git a/.Rbuildignore b/.Rbuildignore index a0e3635f..94927477 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,5 +17,3 @@ ^app*$ ^page$ ^demo$ -^\.positai$ -^\.claude$ diff --git a/.gitignore b/.gitignore index 25eb7609..ce227491 100644 --- a/.gitignore +++ b/.gitignore @@ -16,4 +16,3 @@ app page demo visuals -.positai diff --git a/CITATION.cff b/CITATION.cff index 9d517f96..f7e2ec6a 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: 26.6.1 +version: 26.3.4 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index cc854ec0..def9fc81 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.6.1 +Version: 26.3.4 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), @@ -118,12 +118,10 @@ Collate: 'launch_FreesearchR.R' 'missings-module.R' 'plot-download-module.R' - 'plot-helpers.R' 'plot_bar.R' 'plot_box.R' 'plot_euler.R' 'plot_hbar.R' - 'plot_likert.R' 'plot_ridge.R' 'plot_sankey.R' 'plot_scatter.R' diff --git a/NAMESPACE b/NAMESPACE index 947b97e8..97775d14 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,7 +16,6 @@ export(append_column) export(append_list) export(apply_labels) export(argsstring2list) -export(available_plots) export(baseline_table) export(class_icons) export(clean_common_axis) @@ -65,7 +64,6 @@ export(format_writer) export(generate_colors) export(get_data_packages) export(get_fun_options) -export(get_input_params) export(get_label) export(get_list_elements) export(get_plot_options) @@ -118,14 +116,12 @@ export(modify_qmd) export(names2val) export(overview_vars) export(pipe_string) -export(plot_bar) export(plot_bar_single) export(plot_box) export(plot_box_single) export(plot_euler) export(plot_euler_single) export(plot_hbars) -export(plot_likert) export(plot_ridge) export(plot_sankey) export(plot_sankey_single) @@ -170,7 +166,6 @@ export(update_factor_server) export(update_factor_ui) export(update_variables_server) export(update_variables_ui) -export(validate_redcap_filter) export(validation_server) export(validation_ui) export(vectorSelectInput) diff --git a/NEWS.md b/NEWS.md index ce86f7a7..3476df1d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,40 +1,10 @@ -# FreesearchR 26.6.1 - -*NEW* The visuals module has been restructured to allow for more advanced inputs, which will be added in the future. Basically a more future proof design allowing for more adjustments, while striving to keep the simplicity. Have fun! - -# FreesearchR 26.4.2 - -Bug fixes and revised color choices. - -# FreesearchR 26.4.1 - -Minor adjustments and bug fixes including streamlining icon use to only use phosphoricons across the app. - -# FreesearchR 26.3.6 - -*FIX* Plot single variable in Likert plot. - -*FIX* Horizontal stacked plot crashed. Fixed! - -# FreesearchR 26.3.5 - -*FIX* Labelled categorical variables were not handled correctly importing from REDCap resulting in lost labels. Fixed! - -*CHANGE* Testing in new data I realised, that automatically removing empty levels in categorical variables/factors is not desired. It should be a concious decision to remove levels. This is now possible in the "Modify factor" pop-up. - -*CHANGE* REDCap export now throws an error if no data was exported. The server side filtering prior to export is now validated and feedback is printed. Only valid filter statements are used when exporting data from the REDCap server. This is an advanced use case, but a great way to ensure only the minimum required data is exported from the server. - -*FIX* Applying filters now works also when the data contains text variables. - -*NEW* Initial support for plotting Likert scale survey results. This is expected to be further improved. For based on ggstats::gglikert. - # FreesearchR 26.3.4 *NEW* Color select for plotting across all plots for even more option. Ten palettes have been chosen, to provide varied and interpretable options. The selector will always show a preview of four colors. *NEW* Added app version check against latest release on GitHub. Only runs if internet connection present. No other polling. -*NEW* Added a "Missing" level to the Sankey plot function and adjusted the label font size. And fixed support for dichotomous data. +*NEW* Added a "Missing" level to the sankey plot function and adjusted the label font size. And fixed support for dichotomous data. # FreesearchR 26.3.3 diff --git a/R/app_version.R b/R/app_version.R index bce90462..c6d7307c 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.6.1' +app_version <- function()'26.3.4' diff --git a/R/baseline_table.R b/R/baseline_table.R index 39b51744..9d6f587f 100644 --- a/R/baseline_table.R +++ b/R/baseline_table.R @@ -11,10 +11,7 @@ #' @examples #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) -baseline_table <- function(data, - fun.args = NULL, - fun = gtsummary::tbl_summary, - vars = NULL) { +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) } @@ -40,15 +37,7 @@ baseline_table <- function(data, #' 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.diff = FALSE, - add.overall = FALSE, - theme = c("jama", "lancet", "nejm", "qjecon"), - detail_level = c("minimal", "extended"), - drop_empty = FALSE) { +create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=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) @@ -75,28 +64,31 @@ create_baseline <- function(data, 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}") + 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}")) ) - )) + ) } } - if (isTRUE(drop_empty)) { - ## Drops empty levels if minimal - data <- data |> REDCapCAST::fct_drop() - } - - parameters <- list(data = data, fun.args = purrr::list_flatten(list(by = by.var, args))) + parameters <- list( + data = data, + fun.args = purrr::list_flatten(list(by = by.var, args)) + ) # browser() - out <- do.call(baseline_table, parameters) + out <- do.call( + baseline_table, + parameters + ) if (!is.null(by.var)) { diff --git a/R/create-column-mod.R b/R/create-column-mod.R index 6047aa33..c2b6d403 100644 --- a/R/create-column-mod.R +++ b/R/create-column-mod.R @@ -76,7 +76,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") + phosphoricons::ph("pencil"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -84,7 +84,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle",weight = "bold"), + phosphoricons::ph("x-circle"), i18n$t("Cancel") ), class = "btn-outline-danger", diff --git a/R/custom_SelectInput.R b/R/custom_SelectInput.R index cd460b78..8ac469be 100644 --- a/R/custom_SelectInput.R +++ b/R/custom_SelectInput.R @@ -270,7 +270,7 @@ vectorSelectInput <- function(inputId, colorSelectInput <- function(inputId, label, choices, - selected = NULL, + selected = "", previews = 4, ..., placeholder = "") { @@ -306,43 +306,31 @@ colorSelectInput <- function(inputId, choices_new <- stats::setNames(vals, labels) - if (is.null(selected) || selected == "") { - selected <- vals[[1]] - } - shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., - options = list( + options = list( render = I( "{ - option: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '
' + escape(item.data.name) + '
' + - (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + - '
' + item.data.swatch + '
' + - '
'; - }, - item: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '' + escape(item.data.name) + '' + - item.data.swatch + - '
'; - } - }" - ), - onInitialize = I( - "function() { - var self = this; - self.$control_input.prop('readonly', true); - self.$control_input.css('cursor', 'default'); - self.$control.css('cursor', 'pointer'); - }" + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" ) ) ) diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index 84418736..508e846c 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -64,7 +64,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -378,7 +378,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { rlang::exec(cut_var, !!!parameters) }, error = function(err) { - showNotification(paste("We encountered the following error creating the new factor:", err), type = "error") + showNotification(paste("We encountered the following error creating the new factor:", err), type = "err") } ) diff --git a/R/data-summary.R b/R/data-summary.R index 27c11b3e..62f5e0bf 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -309,29 +309,21 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - phosphoricons::ph("calculator") - # shiny::icon("calculator") + shiny::icon("calculator") } else if (identical(x, "factor")) { - phosphoricons::ph("chart-bar") - # shiny::icon("chart-simple") + shiny::icon("chart-simple") } else if (identical(x, "integer")) { - phosphoricons::ph("list-numbers") - # shiny::icon("arrow-down-1-9") + shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - phosphoricons::ph("text-aa") - # shiny::icon("arrow-down-a-z") + shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - phosphoricons::ph("toggle-left") - # shiny::icon("toggle-off") + shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - phosphoricons::ph("calendar") - # shiny::icon("calendar-days") + shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - phosphoricons::ph("clock") - # shiny::icon("clock") + shiny::icon("clock") } else { - phosphoricons::ph("calendar") - # shiny::icon("table") + shiny::icon("table") }} } @@ -350,29 +342,21 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - phosphoricons::ph("calculator") - # shiny::icon("calculator") + shiny::icon("calculator") } else if (identical(x, "categorical")) { - phosphoricons::ph("chart-bar") - # shiny::icon("chart-simple") + shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - phosphoricons::ph("list-numbers") - # shiny::icon("arrow-down-1-9") + shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - phosphoricons::ph("text-aa") - # shiny::icon("arrow-down-a-z") + shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - phosphoricons::ph("toggle-left") - # shiny::icon("toggle-off") + shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - phosphoricons::ph("calendar") - # shiny::icon("calendar-days") + shiny::icon("calendar-days") } else if (identical(x,"id")) { - phosphoricons::ph("identification-badge") - # shiny::icon("id-card") + shiny::icon("id-card") } else { - phosphoricons::ph("table") - # shiny::icon("table") + shiny::icon("table") } } } diff --git a/R/data_plots.R b/R/data_plots.R index b9e84c85..cd590cce 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -14,25 +14,13 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { list( bslib::layout_sidebar( sidebar = bslib::sidebar( - shiny::actionButton( - inputId = ns("act_plot"), - label = i18n$t("Plot"), - width = "100%", - icon = phosphoricons::ph("paint-brush", weight = "bold"), - # icon = shiny::icon("palette"), - disabled = FALSE - ), - shiny::helpText( - i18n$t('Adjust plot input and settings below, then press "Plot".') - ), bslib::accordion( id = "acc_plot", multiple = FALSE, bslib::accordion_panel( value = "acc_pan_plot", - title = i18n$t("Define plot"), - icon = phosphoricons::ph("chart-line"), - # icon = bsicons::bs_icon("graph-up"), + title = "Create plot", + icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -41,22 +29,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")) - ), - bslib::accordion_panel( - value = "acc_pan_params", - title = i18n$t("Settings"), - icon = phosphoricons::ph("gear"), + shiny::uiOutput(outputId = ns("tertiary")), shiny::uiOutput(outputId = ns("color_palette")), - shiny::uiOutput(outputId = ns("basic_parameters")), + shiny::br(), + shiny::actionButton( + inputId = ns("act_plot"), + label = i18n$t("Plot"), + width = "100%", + icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) ), bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = phosphoricons::ph("download-simple"), - # icon = bsicons::bs_icon("download"), + icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -95,22 +84,21 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ), shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "65vh"), + shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -127,7 +115,21 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, data, palettes = color_choices(), ...) { +data_visuals_server <- function(id, + data, + palettes = c( + "Perceptual (blue-yellow)" = "viridis", + "Perceptual (fire)" = "plasma", + "Colour-blind friendly" = "Okabe-Ito", + "Qualitative (bold)" = "Dark 2", + "Qualitative (paired)" = "Paired", + "Sequential (blues)" = "Blues", + "Diverging (red-blue)" = "RdBu", + "Tableau style" = "Tableau 10", + "Pastel" = "Pastel 1", + "Rainbow" = "rainbow" + ), + ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -148,6 +150,100 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { title = i18n$t("Download")) }) + # ## --- New attempt + # + # rv$plot.params <- shiny::reactive({ + # get_plot_options(input$type) |> purrr::pluck(1) + # }) + # + # c(output, + # list(shiny::renderUI({ + # columnSelectInput( + # inputId = ns("primary"), + # data = data, + # placeholder = "Select variable", + # label = "Response variable", + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$primary) + # # browser() + # + # if (!input$primary %in% names(data())) { + # plot_data <- data()[1] + # } else { + # plot_data <- data()[input$primary] + # } + # + # plots <- possible_plots( + # data = plot_data + # ) + # + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x){ + # stats::setNames(.x$descr, .x$note) + # }) + # + # vectorSelectInput( + # inputId = ns("type"), + # selected = NULL, + # label = shiny::h4("Plot type"), + # choices = Reduce(c, plots_named), + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # + # cols <- c( + # rv$plot.params()[["secondary.extra"]], + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["secondary.type"]] + # )), + # input$primary + # ) + # ) + # + # columnSelectInput( + # inputId = ns("secondary"), + # data = data, + # selected = cols[1], + # placeholder = "Please select", + # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable", + # multiple = rv$plot.params()[["secondary.multi"]], + # maxItems = rv$plot.params()[["secondary.max"]], + # col_subset = cols, + # none_label = "No variable" + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # columnSelectInput( + # inputId = ns("tertiary"), + # data = data, + # placeholder = "Please select", + # label = "Grouping variable", + # multiple = FALSE, + # col_subset = c( + # "none", + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["tertiary.type"]] + # )), + # input$primary, + # input$secondary + # ) + # ), + # none_label = "No stratification" + # ) + # }) + # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE) + + output$primary <- shiny::renderUI({ shiny::req(data()) columnSelectInput( @@ -162,12 +258,13 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { # shiny::observeEvent(data, { # if (is.null(data()) | NROW(data()) == 0) { - # shiny::updateActionButton(inputId = "act_plot", disabled = TRUE) + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE) # } else { - # shiny::updateActionButton(inputId = "act_plot", disabled = FALSE) + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE) # } # }) + output$type <- shiny::renderUI({ shiny::req(input$primary) shiny::req(data()) @@ -179,155 +276,94 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data, source_list = available_plots()) + plots <- possible_plots(data = plot_data) - plots_named <- get_input_params(plots) |> + plots_named <- get_plot_options(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) - # plots_named <- get_plot_options(plots) |> - # lapply(\(.x) { - # stats::setNames(.x$descr, .x$note) - # }) - vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h5(i18n$t("Plot type")), + label = shiny::h4(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_input_params(input$type) |> purrr::pluck(1) - # get_plot_options(input$type) |> purrr::pluck(1) + get_plot_options(input$type) |> purrr::pluck(1) }) - - ### Include two additional variable inputs output$secondary <- shiny::renderUI({ shiny::req(input$type) - # Get the plot function name - base_params <- rv$plot.params()[["base"]] + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) - filtered_params <- base_params[sapply(base_params, function(params) { - params$id %in% "secondary" - })][[1]] - - filtered_params$exclude <- input$primary - - create_input_element( - input_id = "secondary", - ns = ns, - params = append_list(data(), filtered_params, "data") + columnSelectInput( + inputId = ns("secondary"), + data = data, + selected = cols[1], + placeholder = i18n$t("Please select"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), + multiple = rv$plot.params()[["secondary.multi"]], + maxItems = rv$plot.params()[["secondary.max"]], + col_subset = cols, + none_label = i18n$t("No variable") ) - }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - # Get the plot function name - base_params <- rv$plot.params()[["base"]] - - filtered_params <- base_params[sapply(base_params, function(params) { - params$id %in% "tertiary" - })][[1]] - - filtered_params$exclude <- c(input$primary, input$secondary) - - create_input_element( - input_id = "tertiary", - ns = ns, - params = append_list(data(), filtered_params, "data") + columnSelectInput( + inputId = ns("tertiary"), + data = data, + placeholder = i18n$t("Please select"), + label = i18n$t("Grouping variable"), + multiple = FALSE, + col_subset = c( + "none", + all_but( + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), + input$primary, + input$secondary + ) + ), + none_label = i18n$t("No stratification") ) }) - - ### Generating additional parameter inputs if any specified - output$basic_parameters <- renderUI({ - req(input$type, rv$plot.params) - - # Get the plot function name - base_params <- rv$plot.params()[["base"]] - - filtered_params <- base_params[sapply(base_params, function(params) { - !params$id %in% c("secondary", "tertiary") - })] - - - # Create UI elements for base parameters - base_inputs <- lapply(filtered_params, function(params) { - input_id <- paste0("base_", params$id) - params$id <- NULL - if (params$type %in% "select_variables") { - params$data <- data() - } - - create_input_element(params, ns, input_id) - }) - tagList(base_inputs) - - }) - ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes, - previews = 5 + choices = palettes ) }) shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { tryCatch({ - # Get all input values with prefixes - base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] - # advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] - - # Remove the prefix from names - names(base_inputs) <- gsub("^base_", "", names(base_inputs)) - # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) - - base_inputs <- c(base_inputs, - list(color.palette = input$color_palette)) - - # If any of the specified parameters are NULL/missing, the settings - # accordion/panel was never opened, and they can be ignored, as - # default settings will the be used. - if (any(sapply(base_inputs, is.null))) { - dynamic_params <- list() - } else { - dynamic_params <- base_inputs - } - - # Build parameters for plotting function parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, sec = input$secondary, - ter = input$tertiary + ter = input$tertiary, + color.palette = input$color_palette ) - parameters <- modifyList(parameters, dynamic_params) - ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included if (!is.null(rv$plot.params()[["fun.args"]])) { - default_params <- rv$plot.params()[["fun.args"]] - - ## Ensure not to overwrite user defined parameters are overwritten - ## This allows to define default parameters. - ## - ## This will create a strange edge case, where the plot looks in - ## one way, when plotted initially, but may change, when the settings - ## accordion is opened. Problem for future me. Really mostly an edge case. - parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)]) + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -341,7 +377,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } }, ignoreInit = TRUE) @@ -363,25 +399,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { if (!is.null(rv$plot)) { rv$plot } else { - # Create a placeholder plot with instructions using ggplot2 - ggplot2::ggplot() + - ggplot2::annotate( - "text", - x = 0.5, - y = 0.5, - label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), - size = 5, - color = "gray50", - lineheight = 0.8 - ) + - ggplot2::xlim(0, 1) + - ggplot2::ylim(0, 1) + - ggplot2::theme_void() + - ggplot2::theme( - panel.background = ggplot2::element_rect(fill = "white"), - plot.background = ggplot2::element_rect(fill = "white") - ) - # return(NULL) + return(NULL) } }) @@ -425,3 +443,479 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { } ) } + +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + secondary.type = c("dichotomous"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- supported_plots() |> + lapply(\(.x) { + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x) { + .x[match(data, descrs)] + })() +} + + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + color.palette = color.palette, + ... + ) + + out <- do.call(type, modifyList(parameters, list(data = data))) + + code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") + + attr(out, "code") <- code + out +} + +#' Print label, and if missing print variable name for plots +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, + lineLength = 20, + force = FALSE) { + if (isTRUE(force)) { + ## This eats some letters when splitting a sentence... ?? + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' @param title panel title +#' @param guides passed to patchwork::wrap_plots() +#' @param axes passed to patchwork::wrap_plots() +#' @param axis_titles passed to patchwork::wrap_plots() +#' @param ... passed to patchwork::wrap_plots() +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, + tag_levels = NULL, + title = NULL, + axis.font.family = NULL, + guides = "collect", + axes = "collect", + axis_titles = "collect", + ...) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x) { + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i) { + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes() |> + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + if (!is.null(title)) { + out <- out + + patchwork::plot_annotation( + title = title, + theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) + ) + } + } else { + out <- data[[1]] + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + + if (!is.null(axis.font.family)) { + if (inherits(x = out, what = "patchwork")) { + out <- out & + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } else { + out <- out + + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } + } + + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + purrr::map(p, \(.x) { + out <- .x + if (isTRUE(x.axis)) { + out <- out + ggplot2::xlim(xr) + } + if (isTRUE(y.axis)) { + out <- out + ggplot2::ylim(yr) + } + out + }) + }) +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x) { + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} diff --git a/R/generate_colors.R b/R/generate_colors.R index 9daec605..ae9fa869 100644 --- a/R/generate_colors.R +++ b/R/generate_colors.R @@ -56,25 +56,32 @@ #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - - # --- Input validation ------------------------------------------------------- - if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { stop("`n` must be a single positive integer.") } - if (!is.function(palette) && (!is.character(palette) || length(palette) != 1)) { - stop("`palette` must be a single character string or a function.") - } - # --- Function passthrough --------------------------------------------------- + # Function passthrough — call directly with n and ... if (is.function(palette)) { return(palette(n, ...)) } - # --- Named palette dispatch ------------------------------------------------- + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + palette_lower <- tolower(palette) - viridis_palettes <- c("viridis", "magma", "plasma", "inferno", - "cividis", "mako", "rocket", "turbo") + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) if (palette_lower %in% viridis_palettes) { viridisLite::viridis(n = n, option = palette_lower, ...) @@ -94,42 +101,31 @@ generate_colors <- function(n, palette = "viridis", ...) { } else if (palette_lower == "topo") { grDevices::topo.colors(n = n, ...) + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + } else { - # Case-insensitive RColorBrewer lookup - brewer_names <- rownames(RColorBrewer::brewer.pal.info) - brewer_match <- brewer_names[match(palette_lower, tolower(brewer_names))] - - if (!is.na(brewer_match)) { - max_n <- RColorBrewer::brewer.pal.info[brewer_match, "maxcolors"] - fetch_n <- max(min(n, max_n), 3L) - base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = brewer_match) - grDevices::colorRampPalette(base_colors)(n) - - } else { - # Case-insensitive grDevices palette.pals() lookup - pal_names <- grDevices::palette.pals() - pal_match <- pal_names[match(palette_lower, tolower(pal_names))] - - if (!is.na(pal_match)) { - grDevices::colorRampPalette(grDevices::palette.colors(palette = pal_match))(n) - - } else if (palette %in% grDevices::hcl.pals()) { - # Named HCL palettes (e.g. "Rocket", "Plasma") — distinct from viridisLite - grDevices::hcl.colors(n = n, palette = palette, ...) - - } else { - warning( - "Unknown palette: '", palette, "'. Falling back to viridis.\n", - "Available options:\n", - " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", - " grDevices : hcl, rainbow, heat, terrain, topo\n", - " grDevices HCL: use grDevices::hcl.pals() to see all options\n", - " grDevices : use grDevices::palette.pals() to see all options\n", - " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" - ) - viridisLite::viridis(n = n, option = "viridis") - } - } + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) } } @@ -170,9 +166,7 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) { ramp <- grDevices::colorRamp(colors) function(x) { - if (any(x < 0 | - x > 1, na.rm = TRUE)) - stop("Values must be in [0, 1].") + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") rgb_vals <- ramp(x) grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) } @@ -206,18 +200,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) { #' #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] #' @export -scale_fill_generate <- function(palette = "viridis", - discrete = TRUE, - ...) { +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { if (discrete) { ggplot2::discrete_scale( aesthetics = "fill", - palette = function(n) - generate_colors(n, palette), + palette = function(n) generate_colors(n, palette), ... ) } else { - ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...) + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) } } @@ -227,33 +221,17 @@ scale_fill_generate <- function(palette = "viridis", #' geom_point() + #' scale_color_generate(palette = "Set1") #' @export -scale_color_generate <- function(palette = "viridis", - discrete = TRUE, - ...) { +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { if (discrete) { ggplot2::discrete_scale( aesthetics = "colour", - palette = function(n) - generate_colors(n, palette), + palette = function(n) generate_colors(n, palette), ... ) } else { - ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...) + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) } } - - -color_choices <- function() { - c( - "Perceptual (blue-yellow)" = "viridis", - "Perceptual (fire)" = "plasma", - "Colour-blind friendly" = "Okabe-Ito", - "Diverging (red-yellow-green)"= "RdYlGn", - "Diverging (red-blue)" = "RdBu", - "Sequential (blues)" = "Blues", - "Qualitative (paired)" = "Paired", - "Qualitative (bold)" = "Dark 2", - "Rainbow" = "Spectral", - "Generic" = "Set1" - ) -} diff --git a/R/helpers.R b/R/helpers.R index bd982c47..adc12777 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -230,8 +230,8 @@ default_parsing <- function(data) { REDCapCAST::as_factor() |> REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> - REDCapCAST::as_logical() #|> - # REDCapCAST::fct_drop() + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() }) # out <- # @@ -840,54 +840,3 @@ data_types <- function() { "Any other class") ) } - -non_character_cols <- function(df) { - if (shiny::is.reactive(df)) df <- df() - df[, !sapply(df, is.character), drop = FALSE] -} - -apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()) { - # If this ever brakes, the solution will have to be to modify the original filter function - if (shiny::is.reactive(df_target)) df_target <- df_target() - - result <- if (shiny::is.reactive(filtered_reactive)) filtered_reactive() else filtered_reactive - filter_code <- attr(result, "code") - - if (is.null(filter_code)) return(df_target) - - deparsed <- paste(deparse(filter_code), collapse = "") - - if (is.symbol(filter_code) || !grepl("filter(", deparsed, fixed = TRUE)) { - return(df_target) - } - - extract_filters <- function(code) { - filters <- list() - while (!is.symbol(code) && deparse(code[[1]]) == "%>%") { - rhs <- code[[3]] - if (deparse(rhs[[1]]) == "filter") { - filters <- c(list(rhs), filters) - } - code <- code[[2]] - } - if (!is.symbol(code) && deparse(code[[1]]) == "filter") { - filters <- c(list(code), filters) - } - filters - } - - tryCatch({ - out <- df_target - for (f in extract_filters(filter_code)) { - args <- lapply(rlang::call_args(f), function(arg) { - rlang::new_quosure(arg, env = env) - }) - out <- dplyr::filter(out, !!!args) - } - out - }, - error = function(e) { - warning("Could not apply filter: ", conditionMessage(e)) - df_target - }) -} diff --git a/R/hosted_version.R b/R/hosted_version.R index 27a50899..6935edfb 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.6.1' +hosted_version <- function()'v26.3.4-260324' diff --git a/R/import-file-ext.R b/R/import-file-ext.R index 6d78e381..745bbc0f 100644 --- a/R/import-file-ext.R +++ b/R/import-file-ext.R @@ -353,7 +353,7 @@ import_file_server <- function(id, # showNotification(warn, type = "warning") # }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") }) }) @@ -370,7 +370,7 @@ import_file_server <- function(id, minBodyHeight = 250 ) }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") }) }) @@ -485,7 +485,7 @@ import_xls <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } @@ -513,7 +513,7 @@ import_ods <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - ?showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } @@ -714,7 +714,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("The data set has %s obs. in %s variables."), + i18n$t("Data has %s obs. of %s variables."), nrow(data), ncol(data) ), @@ -725,7 +725,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("The data set has %s obs. in %s variables."), + i18n$t("Data has %s obs. of %s variables."), nrow(data), ncol(data) ), diff --git a/R/landing_page_ui.R b/R/landing_page_ui.R index 8301309a..1123640e 100644 --- a/R/landing_page_ui.R +++ b/R/landing_page_ui.R @@ -37,6 +37,20 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", + # Introduction text + # div( + # class = "row mb-5", + # div( + # class = "col-12 text-center", + # p( + # class = "lead", + # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), + # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), + # style = "font-size: 1.2rem; color: #555;" + # ) + # ) + # ), + # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -54,8 +68,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("folder-simple-plus", weight = "bold") - # fa("file-import") + fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -76,8 +89,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("note-pencil", weight = "bold") - # fa("pen-to-square") + fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -98,8 +110,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("magnifying-glass", weight = "bold") - # fa("magnifying-glass-chart") + fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -124,7 +135,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -136,7 +147,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -153,7 +164,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( diff --git a/R/missings-module.R b/R/missings-module.R index eeb46edd..8b9c1f50 100644 --- a/R/missings-module.R +++ b/R/missings-module.R @@ -19,8 +19,7 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = phosphoricons::ph("gear"), - # icon = bsicons::bs_icon("gear"), + icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -37,16 +36,14 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator",weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = phosphoricons::ph("download-simple") - # icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -175,7 +172,7 @@ data_missings_server <- function(id, data, max_level = 20, ...) { out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl))) }) }, error = function(err) { - showNotification(paste0("Error: ", err), type = "error") + showNotification(paste0("Error: ", err), type = "err") }) if (is.null(input$missings_var) || diff --git a/R/plot-download-module.R b/R/plot-download-module.R index ac1d58a5..4caf94bf 100644 --- a/R/plot-download-module.R +++ b/R/plot-download-module.R @@ -39,8 +39,7 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) } diff --git a/R/plot-helpers.R b/R/plot-helpers.R deleted file mode 100644 index 5b4ae981..00000000 --- a/R/plot-helpers.R +++ /dev/null @@ -1,878 +0,0 @@ -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - fun: the plotting function -#' -#' - fun.args: default parameters for the plotting function -#' -#' - descr: Plot description -#' -#' - note: Short note/description of the function for displaying in ui and docs -#' -#' - primary.type: Primary variable data type (see [data_type]) -#' -#' - base: holds a list of parameters for plot input fields generation -#' Secondary and tertiary variable input fields are mandatory. -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' available_plots() |> str() -available_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Additional variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ), - list( - id = "reverse", - type = "select_input", - label = i18n$t("Reverse colors"), - choices = c(yes = TRUE, no = FALSE) - ) - ), - advanced = list() - ######### - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("datatime", "continuous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = TRUE, - maxItems = 4 - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_likert = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t("Plot survey results"), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = TRUE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ) - ) -} - -# Helper function to create input elements dynamically -create_input_element <- function(params, ns, input_id) { - # Add the namespaced inputId to the arguments - params$inputId <- ns(input_id) - - # Map input types to Shiny functions - input_function <- switch( - params$type, - "numeric_input" = shiny::numericInput, - "select_input" = shiny::selectInput, - "checkbox_input" = shiny::checkboxInput, - "slider_input" = shiny::sliderInput, - "text_input" = shiny::textInput, - "select_variables" = selectPlotVariables - ) - - params$type <- NULL - params$id <- NULL - - - # Call the function with all arguments - do.call(input_function, params) -} - -#' Wrapper for columnSelectInput -#' -selectPlotVariables <- function(data, - exclude = NULL, - allow_none = TRUE, - var_types, - ...) { - datar <- if (is.reactive(data)) { - data - } else { - reactive(data) - } - - cols <- all_but(colnames(subset_types(datar(), var_types)), exclude) - - if (isTRUE(allow_none)) { - cols <- c("none", cols) - } - - params <- list(...) - - params$none_label <- i18n$t("No variable") - params$col_subset <- cols - - rlang::exec(columnSelectInput, !!!append_list(datar(), params, "data")) -} - - - -#' Select all from vector but -#' -#' @param data vector -#' @param ... exclude -#' -#' @returns vector -#' @export -#' -#' @examples -#' all_but(1:10, c(2, 3), 11, 5) -all_but <- function(data, ...) { - data[!data %in% c(...)] -} - -#' Easily subset by data type function -#' -#' @param data data -#' @param types desired types -#' @param type.fun function to get type. Default is outcome_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) -#' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { - data[sapply(data, type.fun) %in% types] -} - - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - descr: Plot description -#' -#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.extra: "none" or NULL to have option to choose none. -#' -#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' supported_plots() |> str() -supported_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = "none", - tertiary.type = c("dichotomous", "categorical") - ), - # plot_ridge = list( - # descr = "Ridge plot", - # note = "An alternative option to visualise data distribution", - # primary.type = "continuous", - # secondary.type = c("dichotomous" ,"categorical"), - # tertiary.type = c("dichotomous" ,"categorical"), - # secondary.extra = NULL - # ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical") - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - secondary.type = c("datatime", "continuous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - secondary.type = c("dichotomous"), - secondary.multi = TRUE, - secondary.max = 4, - tertiary.type = c("dichotomous"), - secondary.extra = NULL - ), - plot_likert = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t("Plot survey results"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = TRUE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ) - ) -} - -#' Get possible regression models -#' -#' @param data data -#' -#' @returns character vector -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' dplyr::pull("cyl") |> -#' possible_plots() -#' -#' mtcars |> -#' default_parsing() |> -#' dplyr::select("mpg") |> -#' possible_plots() -possible_plots <- function(data, source_list = supported_plots()) { - # browser() - # data <- if (is.reactive(data)) data() else data - if (is.data.frame(data)) { - data <- data[[1]] - } - - type <- data_type(data) - - if (type == "unknown") { - out <- type - } else { - out <- source_list |> - lapply(\(.x) { - if (type %in% .x$primary.type) { - .x$descr - } - }) |> - unlist() - } - unname(out) -} - -#' Get the function options based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_plot_options() -get_plot_options <- function(data) { - descrs <- supported_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - supported_plots() |> - (\(.x) { - .x[match(data, descrs)] - })() -} - -#' Get the function parameters based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_input_params() -get_input_params <- function(data) { - descr <- available_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - available_plots() |> - (\(.x) { - .x[match(data, descr)] - })() -} - - -#' Wrapper to create plot based on provided type -#' -#' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable -#' @param type plot type (derived from possible_plots() and matches custom function) -#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. -#' @param ... ignored for now -#' -#' @name data-plots -#' -#' @returns ggplot2 object -#' @export -#' -#' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, - type, - pri, - sec, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(sec)) { - if (!any(sec %in% names(data))) { - sec <- NULL - } - } - - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } - } - - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - color.palette = color.palette, - ... - ) - - out <- do.call(type, modifyList(parameters, list(data = data))) - - code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") - - attr(out, "code") <- code - out -} - -#' Print label, and if missing print variable name for plots -#' -#' @param data vector or data frame -#' @param var variable name. Optional. -#' -#' @returns character string -#' @export -#' -#' @examples -#' mtcars |> get_label(var = "mpg") -#' mtcars |> get_label() -#' mtcars$mpg |> get_label() -#' gtsummary::trial |> get_label(var = "trt") -#' gtsummary::trial$trt |> get_label() -#' 1:10 |> get_label() -get_label <- function(data, var = NULL) { - # data <- if (is.reactive(data)) data() else data - if (!is.null(var) & is.data.frame(data)) { - data <- data[[var]] - } - out <- REDCapCAST::get_attr(data = data, attr = "label") - if (is.na(out)) { - if (is.null(var)) { - out <- deparse(substitute(data)) - } else { - if (is.symbol(var)) { - out <- gsub('\"', "", deparse(substitute(var))) - } else { - out <- var - } - } - } - out -} - - -#' Line breaking at given number of characters for nicely plotting labels -#' -#' @param data string -#' @param lineLength maximum line length -#' @param fixed flag to force split at exactly the value given in lineLength. -#' Default is FALSE, only splitting at spaces. -#' -#' @returns character string -#' @export -#' -#' @examples -#' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, - lineLength = 20, - force = FALSE) { - if (isTRUE(force)) { - ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), - "\\1\n", - data) - } else { - paste(strwrap(data, lineLength), collapse = "\n") - } - ## https://stackoverflow.com/a/29847221 -} - - -#' Wrapping -#' -#' @param data list of ggplot2 objects -#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL -#' @param title panel title -#' @param guides passed to patchwork::wrap_plots() -#' @param axes passed to patchwork::wrap_plots() -#' @param axis_titles passed to patchwork::wrap_plots() -#' @param ... passed to patchwork::wrap_plots() -#' -#' @returns list of ggplot2 objects -#' @export -#' -wrap_plot_list <- function(data, - tag_levels = NULL, - title = NULL, - axis.font.family = NULL, - guides = "collect", - axes = "collect", - axis_titles = "collect", - y.axis.percentage = FALSE, - ...) { - if (ggplot2::is_ggplot(data[[1]])) { - if (length(data) > 1) { - out <- data |> - (\(.x) { - if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i) { - .y + ggplot2::ggtitle(.i) - }) - } else { - .x - } - })() |> - align_axes(percentage = y.axis.percentage) |> - patchwork::wrap_plots(guides = guides, - axes = axes, - axis_titles = axis_titles, - ...) - if (!is.null(tag_levels)) { - out <- out + patchwork::plot_annotation(tag_levels = tag_levels) - } - if (!is.null(title)) { - out <- out + - patchwork::plot_annotation( - title = title, - theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) - ) - } - } else { - out <- data[[1]] - } - } else { - cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") - } - - if (!is.null(axis.font.family)) { - if (inherits(x = out, what = "patchwork")) { - out <- out & - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } else { - out <- out + - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } - } - - out -} - - -#' Aligns axes between plots -#' -#' @param ... ggplot2 objects or list of ggplot2 objects -#' -#' @returns list of ggplot2 objects -#' @export -#' -align_axes <- function(..., - x.axis = TRUE, - y.axis = TRUE, - percentage = FALSE) { - # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object - # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 - if (ggplot2::is_ggplot(..1)) { - ## Assumes list of ggplots - p <- list(...) - } else if (is.list(..1)) { - ## Assumes list with list of ggplots - p <- ..1 - } else { - cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") - } - - yr <- clean_common_axis(p, "y") - - xr <- clean_common_axis(p, "x") - - suppressWarnings({ - p_out <- purrr::map(p, \(.x) { - out <- .x - if (isTRUE(x.axis)) { - out <- out + ggplot2::xlim(xr) - } - if (isTRUE(y.axis)) { - out <- out + ggplot2::ylim(yr) - } - out - }) - }) - - if (isTRUE(percentage)) { - lapply(p_out, \(.x) { - .x + - ggplot2::scale_y_continuous(labels = scales::percent) - }) - } else { - p_out - } -} - -#' Extract and clean axis ranges -#' -#' @param p plot -#' @param axis axis. x or y. -#' -#' @returns vector -#' @export -#' -clean_common_axis <- function(p, axis) { - purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> - unlist() |> - (\(.x) { - if (is.numeric(.x)) { - range(.x) - } else { - as.character(.x) - } - })() |> - unique() -} diff --git a/R/plot_bar.R b/R/plot_bar.R index e9879ef3..909c9edd 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -1,29 +1,5 @@ -#' Title -#' -#' @name data-plots -#' -#' @param style barplot style passed to geom_bar position argument. -#' One of c("stack", "dodge", "fill") -#' -#' @returns ggplot list object -#' @export -#' -#' @examples -#' mtcars |> -#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar(pri = "cyl", sec = "am", style = "fill") -#' -#' mtcars |> -#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> -#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") -plot_bar <- function(data, - pri, - sec = NULL, - ter = NULL, - style = c("stack", "dodge", "fill"), - color.palette = "viridis", - max_level = 30, - ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -32,21 +8,18 @@ plot_bar <- function(data, ds <- list(data) } - out <- lapply(ds, \(.ds) { + out <- lapply(ds, \(.ds){ plot_bar_single( data = .ds, pri = pri, sec = sec, style = style, max_level = max_level, - color.palette = color.palette, - ... + color.palette = color.palette ) }) - wrap_plot_list(out, - title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE) + wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), ...) } @@ -68,11 +41,7 @@ plot_bar <- function(data, #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, - pri, - sec = NULL, - style = c("stack", "dodge", "fill"), - max_level = 30, +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -82,12 +51,35 @@ plot_bar_single <- function(data, p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data)) + p = Freq / NROW(data) + ) if (nrow(p_data) > max_level) { - p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> + # browser() + p_data <- sort_by( + p_data, + p_data[["Freq"]], + decreasing = TRUE + ) |> head(max_level) + # if (is.null(sec)){ + # p_data <- sort_by( + # p_data, + # p_data[["Freq"]], + # decreasing=TRUE) |> + # head(max_level) + # } else { + # split(p_data,p_data[[sec]]) |> + # lapply(\(.x){ + # # browser() + # sort_by( + # .x, + # .x[["Freq"]], + # decreasing=TRUE) |> + # head(max_level) + # }) |> dplyr::bind_rows() + # } } ## Shortens long level names @@ -99,31 +91,39 @@ plot_bar_single <- function(data, fill <- pri } - p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + + p <- ggplot2::ggplot( + p_data, + ggplot2::aes( + x = .data[[pri]], + y = p, + fill = .data[[fill]] + ) + ) + ggplot2::geom_bar(position = style, stat = "identity") + - scale_fill_generate(palette = color.palette) + - ggplot2::xlab(get_label(data, pri)) + - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + + ggplot2::ylab("Percentage") + + ggplot2::xlab(get_label(data,pri))+ + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | - any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme(axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, - hjust = 1 - )) + - ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) + ggplot2::theme( + axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, hjust = 1 + ))+ + ggplot2::theme( + axis.text.x = ggplot2::element_text(vjust = 0.5) + ) - if (is.null(sec)) { + if (is.null(sec)){ p <- p + ggplot2::guides(fill = "none") } } - p + - ggplot2::scale_y_continuous(labels = scales::percent) + - ggplot2::ylab("Percentage") + p } diff --git a/R/plot_box.R b/R/plot_box.R index 4acd67ab..01911aac 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -32,11 +32,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette, ... + color.palette=color.palette ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) } diff --git a/R/plot_euler.R b/R/plot_euler.R index a5a0d31f..27cdf02f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -131,7 +131,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis", ...) { +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + diff --git a/R/plot_hbar.R b/R/plot_hbar.R index fc33b20d..0a0ec320 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -10,20 +10,18 @@ #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") -#' mtcars |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis", - ...) { + color.palette = "viridis") { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette, - ... + color.palette = color.palette ) } @@ -43,7 +41,7 @@ vertical_stacked_bars <- function(data, score = "full_score", group = "pase_0_q", strata = NULL, - t.size = 8, + t.size = 10, l.color = "black", l.size = .5, draw.lines = TRUE, @@ -76,15 +74,15 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse) | reverse=="TRUE") { + if (isTRUE(reverse)) { colors <- rev(colors) } + contrast_cut <- + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) - # browser() - p |> (\(.x) { .x$plot + @@ -96,7 +94,7 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = contrast_text(colors[as.numeric(score)], threshold = .3), + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) @@ -105,7 +103,8 @@ vertical_stacked_bars <- function(data, ggplot2::labs(fill = score_label) + ggplot2::scale_fill_manual(values = colors) + ggplot2::theme(legend.position = "bottom", - axis.title = ggplot2::element_text(),) + + axis.title = ggplot2::element_text(), + ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) })() diff --git a/R/plot_likert.R b/R/plot_likert.R deleted file mode 100644 index e33256a2..00000000 --- a/R/plot_likert.R +++ /dev/null @@ -1,57 +0,0 @@ -#' Nice horizontal bar plot centred on the central category -#' -#' @returns ggplot2 object -#' @export -#' -#' @name data-plots -#' -#' @examples -#' mtcars |> plot_likert(pri = "carb", sec = "cyl") -#' mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_likert(pri = "cyl",color.palette="Blues") -#' mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") -#' mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") -plot_likert <- function(data, - pri, - sec = NULL, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(ter)) { - ds <- split(data, data[ter]) - } else { - ds <- list(data) - } - out <- lapply(ds, \(.x) { - plot_likert_single( - data = .x, - include = tidyselect::any_of(c(pri, sec)), - color.palette = color.palette - ) - }) - - wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) -} - - -plot_likert_single <- function(data, - include = dplyr::everything(), - color.palette = "viridis") { - data |> - dplyr::as_tibble() |> - ggstats::gglikert(include = include) + - scale_fill_generate(palette = color.palette) + - ggplot2::theme( - # legend.position = "none", - # panel.grid.major = element_blank(), - # panel.grid.minor = element_blank(), - # axis.text.y = ggplot2::element_blank(), - # axis.title.y = ggplot2::element_blank(), - text = ggplot2::element_text(size = 12) - # axis.text = ggplot2::element_blank(), - # plot.title = element_blank(), - # panel.background = ggplot2::element_rect(fill = "white"), - # plot.background = ggplot2::element_rect(fill = "white"), - # panel.border = ggplot2::element_blank() - ) -} diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 409a1050..23c1a13a 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -95,8 +95,7 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing", - ...) { + missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { diff --git a/R/plot_scatter.R b/R/plot_scatter.R index 8c73547e..142c30fd 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, diff --git a/R/plot_violin.R b/R/plot_violin.R index 29850d26..83d11d2a 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -23,8 +23,7 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ... group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri), - ... + ytitle = get_label(data, var = pri) )+ scale_fill_generate(palette=color.palette) }) diff --git a/R/redcap_read_shiny_module.R b/R/redcap_read_shiny_module.R index bb704325..a74c599a 100644 --- a/R/redcap_read_shiny_module.R +++ b/R/redcap_read_shiny_module.R @@ -11,7 +11,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") + title <- shiny::tags$h4( + i18n$t("Import data from REDCap"), + class = "redcap-module-title" + ) } server_ui <- shiny::tagList( @@ -22,11 +25,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText( - i18n$t( - "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" - ) - ), + shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), shiny::br(), shiny::br(), shiny::passwordInput( @@ -35,16 +34,13 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t( - "The token is a string of 32 numbers and letters." - )), + shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), shiny::br(), shiny::br(), shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = phosphoricons::ph("link",weight = "bold"), - # icon = shiny::icon("link", lib = "glyphicon"), + icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -55,10 +51,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p( - phosphoricons::ph("info", weight = "bold"), - i18n$t("Please fill in web address and API token, then press 'Connect'.") - ) + tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) ), dismissible = TRUE ), @@ -71,18 +64,14 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") - ), - uiOutput(ns("filter_feedback")) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" + )) ) params_ui <- shiny::tagList( shiny::tags$h4(i18n$t("Data import parameters")), shiny::tags$div( - #### - #### All below was deactivated to deactivate filtering - #### style = htmltools::css( display = "grid", gridTemplateColumns = "1fr 50px", @@ -100,19 +89,14 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = phosphoricons::ph("funnel",weight = "bold"), - # label = shiny::icon("filter"), + label = shiny::icon("filter"), width = "50px" ), filter_ui ) ) ), - shiny::helpText( - i18n$t( - "Select fields/variables to import and click the funnel to apply optional filters" - ) - ), + shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -120,8 +104,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = phosphoricons::ph("download-simple",weight = "bold"), - # icon = shiny::icon("download", lib = "glyphicon"), + icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -132,10 +115,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p( - phosphoricons::ph("info", weight = "bold"), - "Please specify data to download, then press 'Import'." - ) + tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") ), dismissible = TRUE ) @@ -146,7 +126,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), + shiny::conditionalPanel( + condition = "output.connect_success == true", + params_ui, + ns = ns + ), shiny::br() ) } @@ -171,19 +155,14 @@ m_redcap_readServer <- function(id) { dd_list = NULL, data = NULL, rep_fields = NULL, - code = NULL, - filter_valid = NULL + code = NULL ) shiny::observeEvent(list(input$api, input$uri), { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse( - endsWith(input$uri, "/"), - input$uri, - paste0(input$uri, "/") - ), "api/") + uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") } else { uri <- input$uri } @@ -197,68 +176,75 @@ m_redcap_readServer <- function(id) { }) - tryCatch({ - shiny::observeEvent(list(input$data_connect), { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch( + { + shiny::observeEvent( + list( + input$data_connect + ), + { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list(redcap_uri = data_rv$uri, token = input$api) - - # browser() - shiny::withProgress({ - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), - silent = TRUE) - }, message = paste("Connecting to", data_rv$uri)) - - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || - NROW(imported) < 1 || - ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), - !isTRUE(imported$success), - FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } - - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" - - data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b( - phosphoricons::ph("check", weight = "bold"), - i18n$t("Connected to server!") - ), - glue::glue( - i18n$t( - "The {data_rv$info$project_title} project is loaded." - ) - ) - ), - btn_show_data = TRUE + parameters <- list( + redcap_uri = data_rv$uri, + token = input$api ) - ) - data_rv$dd_list <- imported - } - }, ignoreInit = TRUE) - }, warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, error = function(err) { - showNotification(paste0(err), type = "error") - }) + # browser() + shiny::withProgress( + { + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) + }, + message = paste("Connecting to", data_rv$uri) + ) + + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } + + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" + + data_rv$info <- REDCapR::redcap_project_info_read( + redcap_uri = data_rv$uri, + token = input$api + )$data + + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), + glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) + ), + btn_show_data = TRUE + ) + ) + + data_rv$dd_list <- imported + } + }, + ignoreInit = TRUE + ) + }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -289,7 +275,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data + REDCapR::redcap_event_read( + redcap_uri = data_rv$uri, + token = input$api + )$data }) output$fields <- shiny::renderUI({ @@ -299,7 +288,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x) { + (\(.x){ split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -332,10 +321,14 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[ + data_rv$dd_list$data$form_name %in% repeated_instruments( + uri = data_rv$uri, + token = input$api + ) + ] - if (input$data_type == "long" && - isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -371,48 +364,12 @@ m_redcap_readServer <- function(id) { } }) - - filter_validation <- reactive({ - val <- trimws(input$filter) - if (nchar(val) == 0) - return(NULL) - validate_redcap_filter(val, purrr::pluck(data_rv$dd_list, "data")) - }) - - output$filter_feedback <- renderUI({ - result <- filter_validation() - if (is.null(result)) { - data_rv$filter_valid <- NULL - return(NULL) - } - - if (result$valid) { - data_rv$filter_valid <- TRUE - tags$span(style = "color: green;", "\u2713 Filter is valid") - } else { - data_rv$filter_valid <- FALSE - - tags$span(style = "color: red;", - "\u2717 ", - line_break(result$message, lineLength = 30)) - } - }) - shiny::observeEvent(input$data_import, { shiny::req(input$fields) # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] - if (!is.null(data_rv$filter_valid)) { - if (isTRUE(data_rv$filter_valid)) { - filter <- trimws(input$filter) - } else { - filter <- "" - } - } else { - filter <- "" - } parameters <- list( uri = data_rv$uri, @@ -420,8 +377,7 @@ m_redcap_readServer <- function(id) { fields = unique(c(record_id, input$fields)), events = input$arms, raw_or_label = "both", - filter_logic = filter, - # filter_logic = "", + filter_logic = input$filter, split_forms = ifelse( input$data_type == "long" && !is.null(input$data_type), "none", @@ -430,48 +386,31 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try({ - rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters) - # if (nrow(out)==0){ - # stop("No data was exported") - # } else { - # out - # } - }, # error = function(err) { - # showNotification(i18n$t("An error was encountered exporting data. Please review data filter."), type = "error") - # }, - silent = TRUE) + imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) }) - # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) + parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] - parameters_code <- parameters[c("uri", - "fields", - "events", - "raw_or_label", - "filter_logic")] + code <- rlang::call2( + "easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST" + ) - code <- rlang::call2("easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST") - - if (inherits(imported, "try-error") | - NROW(imported) == 0 | - (length(imported) == 1 & !is.list(imported))) { + if (inherits(imported, "try-error") || NROW(imported) < 1) { data_rv$data_status <- "error" data_rv$data_list <- NULL - data_rv$data_message <- i18n$t("An empty data set was imported. Please review data filter.") - data_rv$data <- NULL + data_rv$data_message <- imported$raw_text } else { data_rv$data_status <- "success" data_rv$data_message <- i18n$t("Requested data was retrieved!") @@ -480,11 +419,12 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { + # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() } else { - if (identical(input$fill, "yes")) { + if (input$fill == "yes") { ## Repeated fields @@ -502,102 +442,78 @@ m_redcap_readServer <- function(id) { } } - ## Ensure correct factor labels - ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way - out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) - - + # browser() in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply( - parameters$fields, \(.y) startsWith(.x, .y) - ))) + sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t( - "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." - ) + data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t( - "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." - ) + data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") } data_rv$code <- code - ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() - } }) - shiny::observeEvent(data_rv$data_status, { - if (identical(data_rv$data_status, "error")) { - ## The insert error wouldn't work. Inserted through regular. - # datamods:::insert_error(mssg = data_rv$data_message, - # selector = ns("retrieved")) - datamods:::insert_alert( - selector = ns("retrieved"), - status = "danger", - tags$p( - tags$b( - phosphoricons::ph("warning", weight = "bold"), - "Warning!" - ), - data_rv$data_message + shiny::observeEvent( + data_rv$data_status, + { + # browser() + if (identical(data_rv$data_status, "error")) { + datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) + ), + btn_show_data = TRUE + ) ) - ) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p(tags$b( - phosphoricons::ph("check", weight = "bold"), + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), data_rv$data_message - )), - btn_show_data = TRUE + ) ) - ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b( - phosphoricons::ph("warning", weight = "bold"), - "Warning!" - ), - data_rv$data_message - ) - ) + } } - }) - - return( - list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - ) ) + + return(list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + )) } - shiny::moduleServer(id = id, module = module) + shiny::moduleServer( + id = id, + module = module + ) } #' @importFrom htmltools tagList tags @@ -608,12 +524,14 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList(extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - )) + success_message <- tagList( + extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + ) + ) } return(success_message) } @@ -665,18 +583,20 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, - pattern_env = NULL, - nchar = 32) { +is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) + checkmate::assert_character(pattern_env, + any.missing = FALSE, + len = 1 + ) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">") + .open = "<", + .close = ">" + ) } if (is.na(token)) { @@ -716,15 +636,10 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c( - names(data)[1], - "redcap_event_name", - "redcap_repeat_instrument", - "redcap_repeat_instance" - ) + generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") filt <- split(data, data[[event]]) |> - lapply(\(.x) { + lapply(\(.x){ dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -734,327 +649,6 @@ drop_empty_event <- function(data, event = "redcap_event_name") { } -#' Validate a REDCap server-side filter string against a data dictionary -#' -#' Checks that a REDCap filter expression is syntactically correct and -#' consistent with the field types defined in the project data dictionary. -#' Plain text without field references is always rejected. Multi-clause -#' filters joined by \code{AND} or \code{OR} are supported. -#' -#' @param filter A single character string containing the filter expression, -#' e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}. -#' @param dictionary A data frame representing the REDCap data dictionary in -#' API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. -#' Must contain at least the columns \code{field_name} and \code{field_type}. -#' The columns \code{text_validation_type_or_show_slider_number} and -#' \code{select_choices_or_calculations} are used when present for stricter -#' type and choice validation. -#' -#' @return A named list with two elements: -#' \describe{ -#' \item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} -#' \item{\code{message}}{Character. \code{"Filter is valid."} on success, or -#' a newline-separated string of error messages describing every problem -#' found.} -#' } -#' -#' @details -#' Validation rules by field type: -#' \describe{ -#' \item{\code{calc}}{Numeric fields. Value must be an unquoted number. -#' All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, -#' \code{<=}, \code{>=}) are accepted.} -#' \item{\code{text} with date validation}{Fields with validation type -#' \code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be -#' a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All -#' comparison operators are accepted.} -#' \item{\code{text} with time validation}{Fields with validation type -#' \code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time -#' string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} -#' \item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a -#' quoted choice code (e.g. \code{'1'}) that exists in the field's choice -#' list. Only \code{=} and \code{!=} are accepted.} -#' \item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. -#' Only \code{=} and \code{!=} are accepted.} -#' } -#' -#' @examples -#' \dontrun{ -#' dict <- REDCapCAST::get_redcap_metadata( -#' uri = "https://redcap.example.com/api/", -#' token = Sys.getenv("REDCAP_TOKEN") -#' ) -#' -#' validate_redcap_filter("[age] > 18", dict) -#' #> list(valid = TRUE, message = "Filter is valid.") -#' -#' validate_redcap_filter("only plain text", dict) -#' #> list(valid = FALSE, message = "Filter must contain at least one field ...") -#' -#' validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) -#' #> list(valid = TRUE, message = "Filter is valid.") -#' } -#' -#' @export -# REDCap filter validation based on data dictionary -# -# REDCap filter format: [field_name] operator value -# Example: [age] > 18 -# [cohabitation] = '1' -# [inclusion] > '2020-01-01' -# -# Supported field types and their allowed operators/value formats: -# text (no validation) -> string values, = != operators only -# text (date_ymd/date_dmy) -> quoted date strings, all comparison operators -# text (time_hh_mm_ss) -> quoted time strings, all comparison operators -# text (datetime_*) -> quoted datetime strings, all comparison operators -# text (autocomplete) -> string values, = != operators only -# calc -> numeric values, all comparison operators -# radio/dropdown -> quoted numeric codes, = != operators only - -validate_redcap_filter <- function(filter, dictionary) { - # --- Input checks --- - if (!is.character(filter) || - length(filter) != 1 || nchar(trimws(filter)) == 0) { - return(list(valid = FALSE, message = "Filter must be a non-empty string.")) - } - - if (!grepl("\\[.+\\]", filter)) { - return( - list(valid = FALSE, message = "Filter must contain at least one field reference in [brackets]. Plain text is not accepted.") - ) - } - - # --- Column names (API export format) --- - col_field <- "field_name" - col_type <- "field_type" - col_val_type <- "text_validation_type_or_show_slider_number" - col_choices <- "select_choices_or_calculations" - - missing_cols <- setdiff(c(col_field, col_type), names(dictionary)) - if (length(missing_cols) > 0) { - stop("Dictionary is missing required columns: ", - paste(missing_cols, collapse = ", ")) - } - - # --- Build lookup index once for O(1) field access --- - field_idx <- setNames(seq_len(nrow(dictionary)), dictionary[[col_field]]) - has_val_type <- col_val_type %in% names(dictionary) - has_choices <- col_choices %in% names(dictionary) - - # --- Classify field types --- - numeric_types <- c("calc") - date_validations <- c( - "date_ymd", - "date_dmy", - "datetime_ymd", - "datetime_dmy", - "datetime_seconds_ymd", - "datetime_seconds_dmy" - ) - time_validations <- c("time_hh_mm_ss", "time_mm_ss") - categorical_types <- c("radio", "dropdown", "checkbox") - text_types <- c("text", "autocomplete") - - num_ops <- c("=", "!=", "<", ">", "<=", ">=") - cat_ops <- c("=", "!=") - text_ops <- c("=", "!=") - - # --- Parse filter into clauses --- - # Split on AND/OR (REDCap uses 'and'/'or' or 'AND'/'OR') - clauses <- trimws(strsplit(filter, "(?i)\\s+(and|or)\\s+", perl = TRUE)[[1]]) - - clause_pattern <- "^\\[([^\\]]+)\\]\\s*(=|!=|<=|>=|<|>)\\s*(.+)$" - - errors <- character(0) - - for (clause in clauses) { - if (!grepl(clause_pattern, clause, perl = TRUE)) { - errors <- c( - errors, - sprintf( - "Clause '%s' does not match expected format: [field] operator value", - clause - ) - ) - next - } - - parts <- regmatches(clause, regexec(clause_pattern, clause, perl = TRUE))[[1]] - field <- parts[2] - operator <- parts[3] - value <- trimws(parts[4]) - - # --- Check field exists using pre-built index --- - row_i <- field_idx[field] - if (is.na(row_i)) { - errors <- c(errors, sprintf("Unknown field: [%s]", field)) - next - } - - field_type <- dictionary[[col_type]][row_i] - val_type <- if (has_val_type) - dictionary[[col_val_type]][row_i] - else - "" - if (is.na(val_type)) - val_type <- "" - - # --- Determine expected value format and allowed operators --- - if (field_type %in% numeric_types || - grepl("^integer$|^number", val_type)) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is numeric — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl("^-?[0-9]+(\\.[0-9]+)?$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is numeric — value '%s' should be an unquoted number (e.g. 18 or 3.5)", - field, - value - ) - ) - } - - } else if (val_type %in% date_validations) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a date — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl( - "^'[0-9]{4}-[0-9]{2}-[0-9]{2}(\\s[0-9]{2}:[0-9]{2}(:[0-9]{2})?)?'$", - value - )) { - errors <- c( - errors, - sprintf( - "[%s] is a date — value '%s' should be a quoted date string, e.g. '2020-01-31'", - field, - value - ) - ) - } - - } else if (val_type %in% time_validations) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a time — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl("^'[0-9]{2}:[0-9]{2}(:[0-9]{2})?'$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is a time — value '%s' should be a quoted time string, e.g. '14:30:00'", - field, - value - ) - ) - } - - } else if (field_type %in% categorical_types) { - if (!operator %in% cat_ops) { - errors <- c( - errors, - sprintf( - "[%s] is categorical — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(cat_ops, collapse = ", ") - ) - ) - } - - # Validate value is a known choice code - choices_raw <- if (has_choices) - dictionary[[col_choices]][row_i] - else - NA - if (!is.na(choices_raw) && nchar(trimws(choices_raw)) > 0) { - choice_codes <- trimws(gsub(",.+?(\\||$)", "", gsub( - "^\\s*", "", strsplit(choices_raw, "\\|")[[1]] - ))) - value_unquoted <- gsub("^'|'$", "", value) - if (!value_unquoted %in% choice_codes) { - errors <- c( - errors, - sprintf( - "[%s] is categorical — '%s' is not a valid choice code. Valid codes: %s", - field, - value_unquoted, - paste(choice_codes, collapse = ", ") - ) - ) - } - } - - if (!grepl("^'.*'$", value)) { - errors <- c(errors, - sprintf( - "[%s] is categorical — value should be quoted, e.g. '1'", - field - )) - } - - } else { - # Plain text field - if (!operator %in% text_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a text field — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(text_ops, collapse = ", ") - ) - ) - } - if (!grepl("^'.*'$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is a text field — value should be quoted, e.g. 'some text'", - field - ) - ) - } - } - } - - if (length(errors) > 0) { - return(list( - valid = FALSE, - message = paste(errors, collapse = "\n") - )) - } - - list(valid = TRUE, message = "Filter is valid.") -} - - - #' Test app for the redcap_read_shiny_module #' #' @rdname redcap_read_shiny_module @@ -1073,10 +667,16 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable({ - shiny::req(data_val$data) - data_val$data() - }, options = list(scrollX = TRUE, pageLength = 5), ) + output$data <- DT::renderDataTable( + { + shiny::req(data_val$data) + data_val$data() + }, + options = list( + scrollX = TRUE, + pageLength = 5 + ), + ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code() diff --git a/R/regression-module.R b/R/regression-module.R index c8a0f20d..e1bd364f 100644 --- a/R/regression-module.R +++ b/R/regression-module.R @@ -57,8 +57,7 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = phosphoricons::ph("calculator"), - # icon = bsicons::bs_icon("calculator"), + icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -92,8 +91,7 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = phosphoricons::ph("math-operations"), - # icon = bsicons::bs_icon("pencil"), + icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -138,8 +136,7 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = phosphoricons::ph("chart-bar-horizontal"), - # icon = bsicons::bs_icon("bar-chart-steps"), + icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -182,8 +179,7 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ) @@ -204,8 +200,7 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = phosphoricons::ph("checks"), - # icon = bsicons::bs_icon("clipboard-check"), + icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -421,7 +416,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") } ) } @@ -486,7 +481,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") } ) } @@ -564,7 +559,7 @@ regression_server <- function(id, gg_theme_shiny() }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") } ) }) @@ -624,7 +619,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") } ) } @@ -695,7 +690,7 @@ regression_server <- function(id, out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") } ) diff --git a/R/separate_string.R b/R/separate_string.R index 61063b53..0aa64e6c 100644 --- a/R/separate_string.R +++ b/R/separate_string.R @@ -50,7 +50,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") diff --git a/R/sysdata.rda b/R/sysdata.rda index 1829eab4..4e2466e6 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/table-download-module.R b/R/table-download-module.R index aebbb98d..baa566fa 100644 --- a/R/table-download-module.R +++ b/R/table-download-module.R @@ -37,8 +37,7 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) } else { # Return NULL to show nothing diff --git a/R/ui_elements.R b/R/ui_elements.R index b08d5152..96175376 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -15,8 +15,7 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = phosphoricons::ph("house", weight = "bold"), - # icon = shiny::icon("house"), + icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -46,8 +45,7 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = phosphoricons::ph("play", weight = "bold"), - # icon = shiny::icon("play"), + icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -124,8 +122,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars",weight = "bold"), - # icon = shiny::icon("binoculars"), + icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -169,8 +166,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play",weight = "bold"), - # icon = shiny::icon("play"), + icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -189,13 +185,11 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = phosphoricons::ph("note-pencil", weight = "bold"), - # icon = shiny::icon("pen-to-square"), + icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = phosphoricons::ph("eye"), - # icon = shiny::icon("eye"), + icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -247,7 +241,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", + href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -270,8 +264,7 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = phosphoricons::ph("pencil-line"), - # icon = shiny::icon("file-pen"), + icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -300,13 +293,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor"), + label = i18n$t("Modify factor levels"), width = "100%" ), shiny::tags$br(), - shiny::helpText(i18n$t( - "Modify the levels of factor/categorical variables." - )), + shiny::helpText( + i18n$t("Reorder or rename the levels of factor/categorical variables.") + ), shiny::tags$br(), shiny::tags$br() ), @@ -319,7 +312,9 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t("Create factor/categorical variable from other variables.") + i18n$t( + "Create factor/categorical variable from a continous variable (number/date/time)." + ) ), shiny::tags$br(), shiny::tags$br() @@ -396,16 +391,14 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = phosphoricons::ph("magnifying-glass", weight = "bold"), - # icon = shiny::icon("magnifying-glass-chart"), + icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = phosphoricons::ph("table"), - # icon = bsicons::bs_icon("table"), + icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -417,8 +410,7 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = phosphoricons::ph("table"), - # icon = bsicons::bs_icon("table"), + icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -460,8 +452,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator",weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -475,8 +466,7 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = phosphoricons::ph("graph"), - # icon = bsicons::bs_icon("bounding-box"), + icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -517,8 +507,7 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = phosphoricons::ph("placeholder") - # icon = bsicons::bs_icon("x-circle") + icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -533,8 +522,7 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = phosphoricons::ph("chart-line", weight = "bold"), - # icon = shiny::icon("chart-line"), + icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -555,8 +543,7 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = phosphoricons::ph("calculator", weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -568,8 +555,7 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = phosphoricons::ph("download-simple", weight = "bold"), - # icon = shiny::icon("download"), + icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -605,8 +591,7 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -636,8 +621,7 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ), @@ -694,7 +678,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://freesearchr.github.io/FreesearchR-knowledge/", + href = "https://agdamsbo.github.io/FreesearchR/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index 98d24dae..ad1b263c 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -29,33 +29,22 @@ update_factor_ui <- function(id) { ), fluidRow( column( - width = 3, + width = 6, shinyWidgets::virtualSelectInput( inputId = ns("variable"), - label = i18n$t("Choose variable:"), + label = i18n$t("Factor variable to reorder:"), choices = NULL, width = "100%", zIndex = 50 ) ), - column( - width = 3, - class = "d-flex align-items-end", - actionButton( - disabled = TRUE, - inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), - class = "btn-outline-primary mb-3", - width = "100%" - ) - ), column( width = 3, class = "d-flex align-items-end", actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending",weight = "bold"), + phosphoricons::ph("sort-ascending"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -68,7 +57,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending",weight = "bold"), + phosphoricons::ph("sort-ascending"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -81,9 +70,7 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t( - "Create a new variable; otherwise replaces (Updating labels always creates new variable)" - ), + label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), value = FALSE, status = "primary", outline = TRUE, @@ -92,7 +79,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise",weight = "bold"), + phosphoricons::ph("arrow-clockwise"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -138,20 +125,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- grid }) - observeEvent(rv$data_grid, { - variable <- req(input$variable) - if (isTRUE(has_empty_levels(rv$data[[variable]]))) { - # browser() - updateActionButton(inputId = "drop_levels", disabled = FALSE) - } else { - updateActionButton(inputId = "drop_levels", disabled = TRUE) - } - }) - - observeEvent(input$drop_levels, { - rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,] - }) - observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -235,7 +208,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { ) data <- tryCatch({ - with_labels(data, { + with_labels(data,{ rlang::exec(factor_new_levels_labels, !!!modifyList(parameters, val = list(data = data))) }) @@ -245,7 +218,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { "We encountered the following error creating the new factor:", err ), - type = "error") + type = "err") }) # browser() @@ -397,12 +370,3 @@ unique_names <- function(new, existing = character()) { new_names[-seq_along(existing)] } - - -has_empty_levels <- function(x) { - if (is.factor(x)) { - any(!levels(x) %in% x) - } else { - return(FALSE) - } -} diff --git a/R/update-variables-ext.R b/R/update-variables-ext.R index b5dc5ab0..17542646 100644 --- a/R/update-variables-ext.R +++ b/R/update-variables-ext.R @@ -30,7 +30,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear",weight = "bold"), + label = phosphoricons::ph("gear"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -75,7 +75,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), i18n$t("Apply changes") ), width = "100%" diff --git a/SESSION.md b/SESSION.md index 55c29962..0f0edad0 100644 --- a/SESSION.md +++ b/SESSION.md @@ -1,21 +1,21 @@ -------------------------------------------------------------------------------- -------------------------------- R environment --------------------------------- -------------------------------------------------------------------------------- -|setting |value | -|:-----------|:--------------------------------------------------------------------------------------------------| -|version |R version 4.5.2 (2025-10-31) | -|os |macOS Tahoe 26.5 | -|system |aarch64, darwin20 | -|ui |RStudio | -|language |(EN) | -|collate |en_US.UTF-8 | -|ctype |en_US.UTF-8 | -|tz |Europe/Copenhagen | -|date |2026-06-01 | -|rstudio |2026.04.0+526 Globemaster Allium (desktop) | -|pandoc |3.8.3 @ /Applications/RStudio.app/Contents/Resources/app/quarto/bin/tools/aarch64/ (via rmarkdown) | -|quarto |1.9.37 @ /usr/local/bin/quarto | -|FreesearchR |26.6.1.260601 | +|setting |value | +|:-----------|:------------------------------------------| +|version |R version 4.5.2 (2025-10-31) | +|os |macOS Tahoe 26.3 | +|system |aarch64, darwin20 | +|ui |RStudio | +|language |(EN) | +|collate |en_US.UTF-8 | +|ctype |en_US.UTF-8 | +|tz |Europe/Copenhagen | +|date |2026-03-24 | +|rstudio |2026.01.1+403 Apple Blossom (desktop) | +|pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | +|quarto |1.7.30 @ /usr/local/bin/quarto | +|FreesearchR |26.3.4.260324 | -------------------------------------------------------------------------------- @@ -26,8 +26,6 @@ |apexcharter |0.4.5 |2026-01-07 |CRAN (R 4.5.2) | |askpass |1.2.1 |2024-10-04 |CRAN (R 4.5.0) | |assertthat |0.2.1 |2019-03-21 |CRAN (R 4.5.0) | -|attachment |0.4.5 |2025-03-14 |CRAN (R 4.5.0) | -|attempt |0.3.1 |2020-05-03 |CRAN (R 4.5.0) | |backports |1.5.0 |2024-05-23 |CRAN (R 4.5.0) | |base64enc |0.1-6 |2026-02-02 |CRAN (R 4.5.2) | |bayestestR |0.17.0 |2025-08-29 |CRAN (R 4.5.0) | @@ -46,7 +44,6 @@ |cardx |0.3.2 |2026-02-05 |CRAN (R 4.5.2) | |caTools |1.18.3 |2024-09-04 |CRAN (R 4.5.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.5.0) | -|cffr |1.2.1 |2026-01-12 |CRAN (R 4.5.2) | |checkmate |2.3.4 |2026-02-03 |CRAN (R 4.5.2) | |class |7.3-23 |2025-01-01 |CRAN (R 4.5.0) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.5.0) | @@ -64,7 +61,6 @@ |devtools |2.4.6 |2025-10-03 |CRAN (R 4.5.0) | |DHARMa |0.4.7 |2024-10-18 |CRAN (R 4.5.0) | |digest |0.6.39 |2025-11-19 |CRAN (R 4.5.2) | -|dockerfiler |0.2.5 |2025-05-07 |CRAN (R 4.5.0) | |doParallel |1.0.17 |2022-02-07 |CRAN (R 4.5.0) | |dplyr |1.2.0 |2026-02-03 |CRAN (R 4.5.2) | |DT |0.34.0 |2025-09-02 |CRAN (R 4.5.0) | @@ -87,7 +83,7 @@ |foreach |1.5.2 |2022-02-02 |CRAN (R 4.5.0) | |foreign |0.8-91 |2026-01-29 |CRAN (R 4.5.2) | |Formula |1.2-5 |2023-02-24 |CRAN (R 4.5.0) | -|FreesearchR |26.6.1 |NA |NA | +|FreesearchR |26.3.4 |NA |NA | |fs |1.6.7 |2026-03-06 |CRAN (R 4.5.2) | |gdtools |0.5.0 |2026-02-09 |CRAN (R 4.5.2) | |generics |0.1.4 |2025-05-09 |CRAN (R 4.5.0) | @@ -97,7 +93,7 @@ |ggplot2 |4.0.2 |2026-02-03 |CRAN (R 4.5.2) | |ggridges |0.5.7 |2025-08-27 |CRAN (R 4.5.0) | |ggstats |0.13.0 |2026-03-06 |CRAN (R 4.5.2) | -|glue |1.8.0 |2024-09-30 |CRAN (R 4.5.2) | +|glue |1.8.0 |2024-09-30 |CRAN (R 4.5.0) | |gridExtra |2.3 |2017-09-09 |CRAN (R 4.5.0) | |gt |1.3.0 |2026-01-22 |CRAN (R 4.5.2) | |gtable |0.3.6 |2024-10-25 |CRAN (R 4.5.0) | @@ -141,7 +137,6 @@ |openssl |2.3.5 |2026-02-26 |CRAN (R 4.5.2) | |openxlsx2 |1.25 |2026-03-07 |CRAN (R 4.5.2) | |otel |0.2.0 |2025-08-29 |CRAN (R 4.5.0) | -|pak |0.9.2 |2025-12-22 |CRAN (R 4.5.2) | |parameters |0.28.3 |2025-11-25 |CRAN (R 4.5.2) | |patchwork |1.3.2 |2025-08-25 |CRAN (R 4.5.0) | |pbmcapply |1.5.1 |2022-04-28 |CRAN (R 4.5.0) | @@ -198,7 +193,6 @@ |sessioninfo |1.2.3 |2025-02-05 |CRAN (R 4.5.0) | |shiny |1.13.0 |2026-02-20 |CRAN (R 4.5.2) | |shiny.i18n |0.3.0 |2023-01-16 |CRAN (R 4.5.0) | -|shiny2docker |0.0.3 |2025-06-28 |CRAN (R 4.5.0) | |shinybusy |0.3.3 |2024-03-09 |CRAN (R 4.5.0) | |shinyjs |2.1.1 |2026-01-15 |CRAN (R 4.5.2) | |shinyTime |1.0.3 |2022-08-19 |CRAN (R 4.5.0) | @@ -231,5 +225,4 @@ |xml2 |1.5.2 |2026-01-17 |CRAN (R 4.5.2) | |xtable |1.8-8 |2026-02-22 |CRAN (R 4.5.2) | |yaml |2.3.12 |2025-12-10 |CRAN (R 4.5.2) | -|yesno |0.1.3 |2024-07-26 |CRAN (R 4.5.0) | |zip |2.3.3 |2025-05-13 |CRAN (R 4.5.0) | diff --git a/app_docker/app.R b/app_docker/app.R index 9eb30b87..c63e5dbc 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpAe8F1F/file150d92b07c28b.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b70a52556.R ######## i18n_path <- here::here("translations") @@ -64,7 +64,7 @@ i18n$set_translation_language("en") #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'26.6.1' +app_version <- function()'26.3.4' ######## @@ -84,10 +84,7 @@ app_version <- function()'26.6.1' #' @examples #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) -baseline_table <- function(data, - fun.args = NULL, - fun = gtsummary::tbl_summary, - vars = NULL) { +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) } @@ -113,15 +110,7 @@ baseline_table <- function(data, #' 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.diff = FALSE, - add.overall = FALSE, - theme = c("jama", "lancet", "nejm", "qjecon"), - detail_level = c("minimal", "extended"), - drop_empty = FALSE) { +create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=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) @@ -148,28 +137,31 @@ create_baseline <- function(data, 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}") + 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}")) ) - )) + ) } } - if (isTRUE(drop_empty)) { - ## Drops empty levels if minimal - data <- data |> REDCapCAST::fct_drop() - } - - parameters <- list(data = data, fun.args = purrr::list_flatten(list(by = by.var, args))) + parameters <- list( + data = data, + fun.args = purrr::list_flatten(list(by = by.var, args)) + ) # browser() - out <- do.call(baseline_table, parameters) + out <- do.call( + baseline_table, + parameters + ) if (!is.null(by.var)) { @@ -512,7 +504,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") + phosphoricons::ph("pencil"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -520,7 +512,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle",weight = "bold"), + phosphoricons::ph("x-circle"), i18n$t("Cancel") ), class = "btn-outline-danger", @@ -1129,7 +1121,7 @@ vectorSelectInput <- function(inputId, colorSelectInput <- function(inputId, label, choices, - selected = NULL, + selected = "", previews = 4, ..., placeholder = "") { @@ -1165,43 +1157,31 @@ colorSelectInput <- function(inputId, choices_new <- stats::setNames(vals, labels) - if (is.null(selected) || selected == "") { - selected <- vals[[1]] - } - shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., - options = list( + options = list( render = I( "{ - option: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '
' + escape(item.data.name) + '
' + - (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + - '
' + item.data.swatch + '
' + - '
'; - }, - item: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '' + escape(item.data.name) + '' + - item.data.swatch + - '
'; - } - }" - ), - onInitialize = I( - "function() { - var self = this; - self.$control_input.prop('readonly', true); - self.$control_input.css('cursor', 'default'); - self.$control.css('cursor', 'pointer'); - }" + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" ) ) ) @@ -1568,7 +1548,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -1882,7 +1862,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { rlang::exec(cut_var, !!!parameters) }, error = function(err) { - showNotification(paste("We encountered the following error creating the new factor:", err), type = "error") + showNotification(paste("We encountered the following error creating the new factor:", err), type = "err") } ) @@ -2151,25 +2131,13 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { list( bslib::layout_sidebar( sidebar = bslib::sidebar( - shiny::actionButton( - inputId = ns("act_plot"), - label = i18n$t("Plot"), - width = "100%", - icon = phosphoricons::ph("paint-brush", weight = "bold"), - # icon = shiny::icon("palette"), - disabled = FALSE - ), - shiny::helpText( - i18n$t('Adjust plot input and settings below, then press "Plot".') - ), bslib::accordion( id = "acc_plot", multiple = FALSE, bslib::accordion_panel( value = "acc_pan_plot", - title = i18n$t("Define plot"), - icon = phosphoricons::ph("chart-line"), - # icon = bsicons::bs_icon("graph-up"), + title = "Create plot", + icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -2178,22 +2146,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")) - ), - bslib::accordion_panel( - value = "acc_pan_params", - title = i18n$t("Settings"), - icon = phosphoricons::ph("gear"), + shiny::uiOutput(outputId = ns("tertiary")), shiny::uiOutput(outputId = ns("color_palette")), - shiny::uiOutput(outputId = ns("basic_parameters")), + shiny::br(), + shiny::actionButton( + inputId = ns("act_plot"), + label = i18n$t("Plot"), + width = "100%", + icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) ), bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = phosphoricons::ph("download-simple"), - # icon = bsicons::bs_icon("download"), + icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -2232,22 +2201,21 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ), shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "65vh"), + shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -2264,7 +2232,21 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, data, palettes = color_choices(), ...) { +data_visuals_server <- function(id, + data, + palettes = c( + "Perceptual (blue-yellow)" = "viridis", + "Perceptual (fire)" = "plasma", + "Colour-blind friendly" = "Okabe-Ito", + "Qualitative (bold)" = "Dark 2", + "Qualitative (paired)" = "Paired", + "Sequential (blues)" = "Blues", + "Diverging (red-blue)" = "RdBu", + "Tableau style" = "Tableau 10", + "Pastel" = "Pastel 1", + "Rainbow" = "rainbow" + ), + ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -2285,6 +2267,100 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { title = i18n$t("Download")) }) + # ## --- New attempt + # + # rv$plot.params <- shiny::reactive({ + # get_plot_options(input$type) |> purrr::pluck(1) + # }) + # + # c(output, + # list(shiny::renderUI({ + # columnSelectInput( + # inputId = ns("primary"), + # data = data, + # placeholder = "Select variable", + # label = "Response variable", + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$primary) + # # browser() + # + # if (!input$primary %in% names(data())) { + # plot_data <- data()[1] + # } else { + # plot_data <- data()[input$primary] + # } + # + # plots <- possible_plots( + # data = plot_data + # ) + # + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x){ + # stats::setNames(.x$descr, .x$note) + # }) + # + # vectorSelectInput( + # inputId = ns("type"), + # selected = NULL, + # label = shiny::h4("Plot type"), + # choices = Reduce(c, plots_named), + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # + # cols <- c( + # rv$plot.params()[["secondary.extra"]], + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["secondary.type"]] + # )), + # input$primary + # ) + # ) + # + # columnSelectInput( + # inputId = ns("secondary"), + # data = data, + # selected = cols[1], + # placeholder = "Please select", + # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable", + # multiple = rv$plot.params()[["secondary.multi"]], + # maxItems = rv$plot.params()[["secondary.max"]], + # col_subset = cols, + # none_label = "No variable" + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # columnSelectInput( + # inputId = ns("tertiary"), + # data = data, + # placeholder = "Please select", + # label = "Grouping variable", + # multiple = FALSE, + # col_subset = c( + # "none", + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["tertiary.type"]] + # )), + # input$primary, + # input$secondary + # ) + # ), + # none_label = "No stratification" + # ) + # }) + # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE) + + output$primary <- shiny::renderUI({ shiny::req(data()) columnSelectInput( @@ -2299,12 +2375,13 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { # shiny::observeEvent(data, { # if (is.null(data()) | NROW(data()) == 0) { - # shiny::updateActionButton(inputId = "act_plot", disabled = TRUE) + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE) # } else { - # shiny::updateActionButton(inputId = "act_plot", disabled = FALSE) + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE) # } # }) + output$type <- shiny::renderUI({ shiny::req(input$primary) shiny::req(data()) @@ -2316,155 +2393,94 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data, source_list = available_plots()) + plots <- possible_plots(data = plot_data) - plots_named <- get_input_params(plots) |> + plots_named <- get_plot_options(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) - # plots_named <- get_plot_options(plots) |> - # lapply(\(.x) { - # stats::setNames(.x$descr, .x$note) - # }) - vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h5(i18n$t("Plot type")), + label = shiny::h4(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_input_params(input$type) |> purrr::pluck(1) - # get_plot_options(input$type) |> purrr::pluck(1) + get_plot_options(input$type) |> purrr::pluck(1) }) - - ### Include two additional variable inputs output$secondary <- shiny::renderUI({ shiny::req(input$type) - # Get the plot function name - base_params <- rv$plot.params()[["base"]] + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) - filtered_params <- base_params[sapply(base_params, function(params) { - params$id %in% "secondary" - })][[1]] - - filtered_params$exclude <- input$primary - - create_input_element( - input_id = "secondary", - ns = ns, - params = append_list(data(), filtered_params, "data") + columnSelectInput( + inputId = ns("secondary"), + data = data, + selected = cols[1], + placeholder = i18n$t("Please select"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), + multiple = rv$plot.params()[["secondary.multi"]], + maxItems = rv$plot.params()[["secondary.max"]], + col_subset = cols, + none_label = i18n$t("No variable") ) - }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - # Get the plot function name - base_params <- rv$plot.params()[["base"]] - - filtered_params <- base_params[sapply(base_params, function(params) { - params$id %in% "tertiary" - })][[1]] - - filtered_params$exclude <- c(input$primary, input$secondary) - - create_input_element( - input_id = "tertiary", - ns = ns, - params = append_list(data(), filtered_params, "data") + columnSelectInput( + inputId = ns("tertiary"), + data = data, + placeholder = i18n$t("Please select"), + label = i18n$t("Grouping variable"), + multiple = FALSE, + col_subset = c( + "none", + all_but( + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), + input$primary, + input$secondary + ) + ), + none_label = i18n$t("No stratification") ) }) - - ### Generating additional parameter inputs if any specified - output$basic_parameters <- renderUI({ - req(input$type, rv$plot.params) - - # Get the plot function name - base_params <- rv$plot.params()[["base"]] - - filtered_params <- base_params[sapply(base_params, function(params) { - !params$id %in% c("secondary", "tertiary") - })] - - - # Create UI elements for base parameters - base_inputs <- lapply(filtered_params, function(params) { - input_id <- paste0("base_", params$id) - params$id <- NULL - if (params$type %in% "select_variables") { - params$data <- data() - } - - create_input_element(params, ns, input_id) - }) - tagList(base_inputs) - - }) - ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes, - previews = 5 + choices = palettes ) }) shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { tryCatch({ - # Get all input values with prefixes - base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] - # advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] - - # Remove the prefix from names - names(base_inputs) <- gsub("^base_", "", names(base_inputs)) - # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) - - base_inputs <- c(base_inputs, - list(color.palette = input$color_palette)) - - # If any of the specified parameters are NULL/missing, the settings - # accordion/panel was never opened, and they can be ignored, as - # default settings will the be used. - if (any(sapply(base_inputs, is.null))) { - dynamic_params <- list() - } else { - dynamic_params <- base_inputs - } - - # Build parameters for plotting function parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, sec = input$secondary, - ter = input$tertiary + ter = input$tertiary, + color.palette = input$color_palette ) - parameters <- modifyList(parameters, dynamic_params) - ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included if (!is.null(rv$plot.params()[["fun.args"]])) { - default_params <- rv$plot.params()[["fun.args"]] - - ## Ensure not to overwrite user defined parameters are overwritten - ## This allows to define default parameters. - ## - ## This will create a strange edge case, where the plot looks in - ## one way, when plotted initially, but may change, when the settings - ## accordion is opened. Problem for future me. Really mostly an edge case. - parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)]) + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -2478,7 +2494,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } }, ignoreInit = TRUE) @@ -2500,25 +2516,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { if (!is.null(rv$plot)) { rv$plot } else { - # Create a placeholder plot with instructions using ggplot2 - ggplot2::ggplot() + - ggplot2::annotate( - "text", - x = 0.5, - y = 0.5, - label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), - size = 5, - color = "gray50", - lineheight = 0.8 - ) + - ggplot2::xlim(0, 1) + - ggplot2::ylim(0, 1) + - ggplot2::theme_void() + - ggplot2::theme( - panel.background = ggplot2::element_rect(fill = "white"), - plot.background = ggplot2::element_rect(fill = "white") - ) - # return(NULL) + return(NULL) } }) @@ -2563,6 +2561,482 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { ) } +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + secondary.type = c("dichotomous"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- supported_plots() |> + lapply(\(.x) { + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x) { + .x[match(data, descrs)] + })() +} + + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + color.palette = color.palette, + ... + ) + + out <- do.call(type, modifyList(parameters, list(data = data))) + + code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") + + attr(out, "code") <- code + out +} + +#' Print label, and if missing print variable name for plots +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, + lineLength = 20, + force = FALSE) { + if (isTRUE(force)) { + ## This eats some letters when splitting a sentence... ?? + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' @param title panel title +#' @param guides passed to patchwork::wrap_plots() +#' @param axes passed to patchwork::wrap_plots() +#' @param axis_titles passed to patchwork::wrap_plots() +#' @param ... passed to patchwork::wrap_plots() +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, + tag_levels = NULL, + title = NULL, + axis.font.family = NULL, + guides = "collect", + axes = "collect", + axis_titles = "collect", + ...) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x) { + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i) { + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes() |> + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + if (!is.null(title)) { + out <- out + + patchwork::plot_annotation( + title = title, + theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) + ) + } + } else { + out <- data[[1]] + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + + if (!is.null(axis.font.family)) { + if (inherits(x = out, what = "patchwork")) { + out <- out & + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } else { + out <- out + + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } + } + + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + purrr::map(p, \(.x) { + out <- .x + if (isTRUE(x.axis)) { + out <- out + ggplot2::xlim(xr) + } + if (isTRUE(y.axis)) { + out <- out + ggplot2::ylim(yr) + } + out + }) + }) +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x) { + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} + ######## #### Current file: /Users/au301842/FreesearchR/R//data-summary.R @@ -2879,29 +3353,21 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - phosphoricons::ph("calculator") - # shiny::icon("calculator") + shiny::icon("calculator") } else if (identical(x, "factor")) { - phosphoricons::ph("chart-bar") - # shiny::icon("chart-simple") + shiny::icon("chart-simple") } else if (identical(x, "integer")) { - phosphoricons::ph("list-numbers") - # shiny::icon("arrow-down-1-9") + shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - phosphoricons::ph("text-aa") - # shiny::icon("arrow-down-a-z") + shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - phosphoricons::ph("toggle-left") - # shiny::icon("toggle-off") + shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - phosphoricons::ph("calendar") - # shiny::icon("calendar-days") + shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - phosphoricons::ph("clock") - # shiny::icon("clock") + shiny::icon("clock") } else { - phosphoricons::ph("calendar") - # shiny::icon("table") + shiny::icon("table") }} } @@ -2920,29 +3386,21 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - phosphoricons::ph("calculator") - # shiny::icon("calculator") + shiny::icon("calculator") } else if (identical(x, "categorical")) { - phosphoricons::ph("chart-bar") - # shiny::icon("chart-simple") + shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - phosphoricons::ph("list-numbers") - # shiny::icon("arrow-down-1-9") + shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - phosphoricons::ph("text-aa") - # shiny::icon("arrow-down-a-z") + shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - phosphoricons::ph("toggle-left") - # shiny::icon("toggle-off") + shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - phosphoricons::ph("calendar") - # shiny::icon("calendar-days") + shiny::icon("calendar-days") } else if (identical(x,"id")) { - phosphoricons::ph("identification-badge") - # shiny::icon("id-card") + shiny::icon("id-card") } else { - phosphoricons::ph("table") - # shiny::icon("table") + shiny::icon("table") } } } @@ -3428,25 +3886,32 @@ footer_ui <- function(i18n) { #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - - # --- Input validation ------------------------------------------------------- - if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { stop("`n` must be a single positive integer.") } - if (!is.function(palette) && (!is.character(palette) || length(palette) != 1)) { - stop("`palette` must be a single character string or a function.") - } - # --- Function passthrough --------------------------------------------------- + # Function passthrough — call directly with n and ... if (is.function(palette)) { return(palette(n, ...)) } - # --- Named palette dispatch ------------------------------------------------- + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + palette_lower <- tolower(palette) - viridis_palettes <- c("viridis", "magma", "plasma", "inferno", - "cividis", "mako", "rocket", "turbo") + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) if (palette_lower %in% viridis_palettes) { viridisLite::viridis(n = n, option = palette_lower, ...) @@ -3466,42 +3931,31 @@ generate_colors <- function(n, palette = "viridis", ...) { } else if (palette_lower == "topo") { grDevices::topo.colors(n = n, ...) + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + } else { - # Case-insensitive RColorBrewer lookup - brewer_names <- rownames(RColorBrewer::brewer.pal.info) - brewer_match <- brewer_names[match(palette_lower, tolower(brewer_names))] - - if (!is.na(brewer_match)) { - max_n <- RColorBrewer::brewer.pal.info[brewer_match, "maxcolors"] - fetch_n <- max(min(n, max_n), 3L) - base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = brewer_match) - grDevices::colorRampPalette(base_colors)(n) - - } else { - # Case-insensitive grDevices palette.pals() lookup - pal_names <- grDevices::palette.pals() - pal_match <- pal_names[match(palette_lower, tolower(pal_names))] - - if (!is.na(pal_match)) { - grDevices::colorRampPalette(grDevices::palette.colors(palette = pal_match))(n) - - } else if (palette %in% grDevices::hcl.pals()) { - # Named HCL palettes (e.g. "Rocket", "Plasma") — distinct from viridisLite - grDevices::hcl.colors(n = n, palette = palette, ...) - - } else { - warning( - "Unknown palette: '", palette, "'. Falling back to viridis.\n", - "Available options:\n", - " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", - " grDevices : hcl, rainbow, heat, terrain, topo\n", - " grDevices HCL: use grDevices::hcl.pals() to see all options\n", - " grDevices : use grDevices::palette.pals() to see all options\n", - " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" - ) - viridisLite::viridis(n = n, option = "viridis") - } - } + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) } } @@ -3542,9 +3996,7 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) { ramp <- grDevices::colorRamp(colors) function(x) { - if (any(x < 0 | - x > 1, na.rm = TRUE)) - stop("Values must be in [0, 1].") + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") rgb_vals <- ramp(x) grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) } @@ -3578,18 +4030,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) { #' #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] #' @export -scale_fill_generate <- function(palette = "viridis", - discrete = TRUE, - ...) { +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { if (discrete) { ggplot2::discrete_scale( aesthetics = "fill", - palette = function(n) - generate_colors(n, palette), + palette = function(n) generate_colors(n, palette), ... ) } else { - ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...) + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) } } @@ -3599,38 +4051,22 @@ scale_fill_generate <- function(palette = "viridis", #' geom_point() + #' scale_color_generate(palette = "Set1") #' @export -scale_color_generate <- function(palette = "viridis", - discrete = TRUE, - ...) { +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { if (discrete) { ggplot2::discrete_scale( aesthetics = "colour", - palette = function(n) - generate_colors(n, palette), + palette = function(n) generate_colors(n, palette), ... ) } else { - ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...) + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) } } -color_choices <- function() { - c( - "Perceptual (blue-yellow)" = "viridis", - "Perceptual (fire)" = "plasma", - "Colour-blind friendly" = "Okabe-Ito", - "Diverging (red-yellow-green)"= "RdYlGn", - "Diverging (red-blue)" = "RdBu", - "Sequential (blues)" = "Blues", - "Qualitative (paired)" = "Paired", - "Qualitative (bold)" = "Dark 2", - "Rainbow" = "Spectral", - "Generic" = "Set1" - ) -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## @@ -3867,8 +4303,8 @@ default_parsing <- function(data) { REDCapCAST::as_factor() |> REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> - REDCapCAST::as_logical() #|> - # REDCapCAST::fct_drop() + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() }) # out <- # @@ -4478,63 +4914,12 @@ data_types <- function() { ) } -non_character_cols <- function(df) { - if (shiny::is.reactive(df)) df <- df() - df[, !sapply(df, is.character), drop = FALSE] -} - -apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()) { - # If this ever brakes, the solution will have to be to modify the original filter function - if (shiny::is.reactive(df_target)) df_target <- df_target() - - result <- if (shiny::is.reactive(filtered_reactive)) filtered_reactive() else filtered_reactive - filter_code <- attr(result, "code") - - if (is.null(filter_code)) return(df_target) - - deparsed <- paste(deparse(filter_code), collapse = "") - - if (is.symbol(filter_code) || !grepl("filter(", deparsed, fixed = TRUE)) { - return(df_target) - } - - extract_filters <- function(code) { - filters <- list() - while (!is.symbol(code) && deparse(code[[1]]) == "%>%") { - rhs <- code[[3]] - if (deparse(rhs[[1]]) == "filter") { - filters <- c(list(rhs), filters) - } - code <- code[[2]] - } - if (!is.symbol(code) && deparse(code[[1]]) == "filter") { - filters <- c(list(code), filters) - } - filters - } - - tryCatch({ - out <- df_target - for (f in extract_filters(filter_code)) { - args <- lapply(rlang::call_args(f), function(arg) { - rlang::new_quosure(arg, env = env) - }) - out <- dplyr::filter(out, !!!args) - } - out - }, - error = function(e) { - warning("Could not apply filter: ", conditionMessage(e)) - df_target - }) -} - ######## #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.6.1' +hosted_version <- function()'v26.3.4-260324' ######## @@ -5313,7 +5698,7 @@ import_file_server <- function(id, # showNotification(warn, type = "warning") # }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") }) }) @@ -5330,7 +5715,7 @@ import_file_server <- function(id, minBodyHeight = 250 ) }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") }) }) @@ -5445,7 +5830,7 @@ import_xls <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } @@ -5473,7 +5858,7 @@ import_ods <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - ?showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } @@ -5674,7 +6059,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("The data set has %s obs. in %s variables."), + i18n$t("Data has %s obs. of %s variables."), nrow(data), ncol(data) ), @@ -5685,7 +6070,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("The data set has %s obs. in %s variables."), + i18n$t("Data has %s obs. of %s variables."), nrow(data), ncol(data) ), @@ -5746,6 +6131,20 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", + # Introduction text + # div( + # class = "row mb-5", + # div( + # class = "col-12 text-center", + # p( + # class = "lead", + # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), + # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), + # style = "font-size: 1.2rem; color: #555;" + # ) + # ) + # ), + # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -5763,8 +6162,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("folder-simple-plus", weight = "bold") - # fa("file-import") + fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -5785,8 +6183,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("note-pencil", weight = "bold") - # fa("pen-to-square") + fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -5807,8 +6204,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("magnifying-glass", weight = "bold") - # fa("magnifying-glass-chart") + fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -5833,7 +6229,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -5845,7 +6241,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -5862,7 +6258,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( @@ -6152,8 +6548,7 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = phosphoricons::ph("gear"), - # icon = bsicons::bs_icon("gear"), + icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -6170,16 +6565,14 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator",weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = phosphoricons::ph("download-simple") - # icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -6308,7 +6701,7 @@ data_missings_server <- function(id, data, max_level = 20, ...) { out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl))) }) }, error = function(err) { - showNotification(paste0("Error: ", err), type = "error") + showNotification(paste0("Error: ", err), type = "err") }) if (is.null(input$missings_var) || @@ -6507,32 +6900,8 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -#' Title -#' -#' @name data-plots -#' -#' @param style barplot style passed to geom_bar position argument. -#' One of c("stack", "dodge", "fill") -#' -#' @returns ggplot list object -#' @export -#' -#' @examples -#' mtcars |> -#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar(pri = "cyl", sec = "am", style = "fill") -#' -#' mtcars |> -#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> -#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") -plot_bar <- function(data, - pri, - sec = NULL, - ter = NULL, - style = c("stack", "dodge", "fill"), - color.palette = "viridis", - max_level = 30, - ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6541,21 +6910,18 @@ plot_bar <- function(data, ds <- list(data) } - out <- lapply(ds, \(.ds) { + out <- lapply(ds, \(.ds){ plot_bar_single( data = .ds, pri = pri, sec = sec, style = style, max_level = max_level, - color.palette = color.palette, - ... + color.palette = color.palette ) }) - wrap_plot_list(out, - title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE) + wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), ...) } @@ -6577,11 +6943,7 @@ plot_bar <- function(data, #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, - pri, - sec = NULL, - style = c("stack", "dodge", "fill"), - max_level = 30, +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -6591,12 +6953,35 @@ plot_bar_single <- function(data, p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data)) + p = Freq / NROW(data) + ) if (nrow(p_data) > max_level) { - p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> + # browser() + p_data <- sort_by( + p_data, + p_data[["Freq"]], + decreasing = TRUE + ) |> head(max_level) + # if (is.null(sec)){ + # p_data <- sort_by( + # p_data, + # p_data[["Freq"]], + # decreasing=TRUE) |> + # head(max_level) + # } else { + # split(p_data,p_data[[sec]]) |> + # lapply(\(.x){ + # # browser() + # sort_by( + # .x, + # .x[["Freq"]], + # decreasing=TRUE) |> + # head(max_level) + # }) |> dplyr::bind_rows() + # } } ## Shortens long level names @@ -6608,33 +6993,41 @@ plot_bar_single <- function(data, fill <- pri } - p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + + p <- ggplot2::ggplot( + p_data, + ggplot2::aes( + x = .data[[pri]], + y = p, + fill = .data[[fill]] + ) + ) + ggplot2::geom_bar(position = style, stat = "identity") + - scale_fill_generate(palette = color.palette) + - ggplot2::xlab(get_label(data, pri)) + - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + + ggplot2::ylab("Percentage") + + ggplot2::xlab(get_label(data,pri))+ + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | - any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme(axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, - hjust = 1 - )) + - ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) + ggplot2::theme( + axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, hjust = 1 + ))+ + ggplot2::theme( + axis.text.x = ggplot2::element_text(vjust = 0.5) + ) - if (is.null(sec)) { + if (is.null(sec)){ p <- p + ggplot2::guides(fill = "none") } } - p + - ggplot2::scale_y_continuous(labels = scales::percent) + - ggplot2::ylab("Percentage") + p } @@ -6676,11 +7069,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette, ... + color.palette=color.palette ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) } @@ -6874,7 +7267,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis", ...) { +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + @@ -6912,20 +7305,18 @@ plot_euler_single <- function(data,color.palette="viridis", ...) { #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") -#' mtcars |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis", - ...) { + color.palette = "viridis") { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette, - ... + color.palette = color.palette ) } @@ -6945,7 +7336,7 @@ vertical_stacked_bars <- function(data, score = "full_score", group = "pase_0_q", strata = NULL, - t.size = 8, + t.size = 10, l.color = "black", l.size = .5, draw.lines = TRUE, @@ -6978,15 +7369,15 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse) | reverse=="TRUE") { + if (isTRUE(reverse)) { colors <- rev(colors) } + contrast_cut <- + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) - # browser() - p |> (\(.x) { .x$plot + @@ -6998,7 +7389,7 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = contrast_text(colors[as.numeric(score)], threshold = .3), + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) @@ -7007,76 +7398,14 @@ vertical_stacked_bars <- function(data, ggplot2::labs(fill = score_label) + ggplot2::scale_fill_manual(values = colors) + ggplot2::theme(legend.position = "bottom", - axis.title = ggplot2::element_text(),) + + axis.title = ggplot2::element_text(), + ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) })() } -######## -#### Current file: /Users/au301842/FreesearchR/R//plot_likert.R -######## - -#' Nice horizontal bar plot centred on the central category -#' -#' @returns ggplot2 object -#' @export -#' -#' @name data-plots -#' -#' @examples -#' mtcars |> plot_likert(pri = "carb", sec = "cyl") -#' mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_likert(pri = "cyl",color.palette="Blues") -#' mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") -#' mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") -plot_likert <- function(data, - pri, - sec = NULL, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(ter)) { - ds <- split(data, data[ter]) - } else { - ds <- list(data) - } - out <- lapply(ds, \(.x) { - plot_likert_single( - data = .x, - include = tidyselect::any_of(c(pri, sec)), - color.palette = color.palette - ) - }) - - wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) -} - - -plot_likert_single <- function(data, - include = dplyr::everything(), - color.palette = "viridis") { - data |> - dplyr::as_tibble() |> - ggstats::gglikert(include = include) + - scale_fill_generate(palette = color.palette) + - ggplot2::theme( - # legend.position = "none", - # panel.grid.major = element_blank(), - # panel.grid.minor = element_blank(), - # axis.text.y = ggplot2::element_blank(), - # axis.title.y = ggplot2::element_blank(), - text = ggplot2::element_text(size = 12) - # axis.text = ggplot2::element_blank(), - # plot.title = element_blank(), - # panel.background = ggplot2::element_rect(fill = "white"), - # plot.background = ggplot2::element_rect(fill = "white"), - # panel.border = ggplot2::element_blank() - ) -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//plot_ridge.R ######## @@ -7213,8 +7542,7 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing", - ...) { + missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7448,7 +7776,7 @@ color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -7485,7 +7813,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", .. #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7500,8 +7828,7 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ... group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri), - ... + ytitle = get_label(data, var = pri) )+ scale_fill_generate(palette=color.palette) }) @@ -7557,8 +7884,7 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) } @@ -7647,890 +7973,6 @@ plot_download_demo_app <- function() { # plot_download_demo_app() -######## -#### Current file: /Users/au301842/FreesearchR/R//plot-helpers.R -######## - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - fun: the plotting function -#' -#' - fun.args: default parameters for the plotting function -#' -#' - descr: Plot description -#' -#' - note: Short note/description of the function for displaying in ui and docs -#' -#' - primary.type: Primary variable data type (see [data_type]) -#' -#' - base: holds a list of parameters for plot input fields generation -#' Secondary and tertiary variable input fields are mandatory. -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' available_plots() |> str() -available_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Additional variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ), - list( - id = "reverse", - type = "select_input", - label = i18n$t("Reverse colors"), - choices = c(yes = TRUE, no = FALSE) - ) - ), - advanced = list() - ######### - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("datatime", "continuous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = TRUE, - maxItems = 4 - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_likert = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t("Plot survey results"), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = TRUE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ) - ) -} - -# Helper function to create input elements dynamically -create_input_element <- function(params, ns, input_id) { - # Add the namespaced inputId to the arguments - params$inputId <- ns(input_id) - - # Map input types to Shiny functions - input_function <- switch( - params$type, - "numeric_input" = shiny::numericInput, - "select_input" = shiny::selectInput, - "checkbox_input" = shiny::checkboxInput, - "slider_input" = shiny::sliderInput, - "text_input" = shiny::textInput, - "select_variables" = selectPlotVariables - ) - - params$type <- NULL - params$id <- NULL - - - # Call the function with all arguments - do.call(input_function, params) -} - -#' Wrapper for columnSelectInput -#' -selectPlotVariables <- function(data, - exclude = NULL, - allow_none = TRUE, - var_types, - ...) { - datar <- if (is.reactive(data)) { - data - } else { - reactive(data) - } - - cols <- all_but(colnames(subset_types(datar(), var_types)), exclude) - - if (isTRUE(allow_none)) { - cols <- c("none", cols) - } - - params <- list(...) - - params$none_label <- i18n$t("No variable") - params$col_subset <- cols - - rlang::exec(columnSelectInput, !!!append_list(datar(), params, "data")) -} - - - -#' Select all from vector but -#' -#' @param data vector -#' @param ... exclude -#' -#' @returns vector -#' @export -#' -#' @examples -#' all_but(1:10, c(2, 3), 11, 5) -all_but <- function(data, ...) { - data[!data %in% c(...)] -} - -#' Easily subset by data type function -#' -#' @param data data -#' @param types desired types -#' @param type.fun function to get type. Default is outcome_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) -#' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { - data[sapply(data, type.fun) %in% types] -} - - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - descr: Plot description -#' -#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.extra: "none" or NULL to have option to choose none. -#' -#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' supported_plots() |> str() -supported_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = "none", - tertiary.type = c("dichotomous", "categorical") - ), - # plot_ridge = list( - # descr = "Ridge plot", - # note = "An alternative option to visualise data distribution", - # primary.type = "continuous", - # secondary.type = c("dichotomous" ,"categorical"), - # tertiary.type = c("dichotomous" ,"categorical"), - # secondary.extra = NULL - # ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical") - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - secondary.type = c("datatime", "continuous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - secondary.type = c("dichotomous"), - secondary.multi = TRUE, - secondary.max = 4, - tertiary.type = c("dichotomous"), - secondary.extra = NULL - ), - plot_likert = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t("Plot survey results"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = TRUE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ) - ) -} - -#' Get possible regression models -#' -#' @param data data -#' -#' @returns character vector -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' dplyr::pull("cyl") |> -#' possible_plots() -#' -#' mtcars |> -#' default_parsing() |> -#' dplyr::select("mpg") |> -#' possible_plots() -possible_plots <- function(data, source_list = supported_plots()) { - # browser() - # data <- if (is.reactive(data)) data() else data - if (is.data.frame(data)) { - data <- data[[1]] - } - - type <- data_type(data) - - if (type == "unknown") { - out <- type - } else { - out <- source_list |> - lapply(\(.x) { - if (type %in% .x$primary.type) { - .x$descr - } - }) |> - unlist() - } - unname(out) -} - -#' Get the function options based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_plot_options() -get_plot_options <- function(data) { - descrs <- supported_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - supported_plots() |> - (\(.x) { - .x[match(data, descrs)] - })() -} - -#' Get the function parameters based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_input_params() -get_input_params <- function(data) { - descr <- available_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - available_plots() |> - (\(.x) { - .x[match(data, descr)] - })() -} - - -#' Wrapper to create plot based on provided type -#' -#' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable -#' @param type plot type (derived from possible_plots() and matches custom function) -#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. -#' @param ... ignored for now -#' -#' @name data-plots -#' -#' @returns ggplot2 object -#' @export -#' -#' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, - type, - pri, - sec, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(sec)) { - if (!any(sec %in% names(data))) { - sec <- NULL - } - } - - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } - } - - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - color.palette = color.palette, - ... - ) - - out <- do.call(type, modifyList(parameters, list(data = data))) - - code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") - - attr(out, "code") <- code - out -} - -#' Print label, and if missing print variable name for plots -#' -#' @param data vector or data frame -#' @param var variable name. Optional. -#' -#' @returns character string -#' @export -#' -#' @examples -#' mtcars |> get_label(var = "mpg") -#' mtcars |> get_label() -#' mtcars$mpg |> get_label() -#' gtsummary::trial |> get_label(var = "trt") -#' gtsummary::trial$trt |> get_label() -#' 1:10 |> get_label() -get_label <- function(data, var = NULL) { - # data <- if (is.reactive(data)) data() else data - if (!is.null(var) & is.data.frame(data)) { - data <- data[[var]] - } - out <- REDCapCAST::get_attr(data = data, attr = "label") - if (is.na(out)) { - if (is.null(var)) { - out <- deparse(substitute(data)) - } else { - if (is.symbol(var)) { - out <- gsub('\"', "", deparse(substitute(var))) - } else { - out <- var - } - } - } - out -} - - -#' Line breaking at given number of characters for nicely plotting labels -#' -#' @param data string -#' @param lineLength maximum line length -#' @param fixed flag to force split at exactly the value given in lineLength. -#' Default is FALSE, only splitting at spaces. -#' -#' @returns character string -#' @export -#' -#' @examples -#' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, - lineLength = 20, - force = FALSE) { - if (isTRUE(force)) { - ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), - "\\1\n", - data) - } else { - paste(strwrap(data, lineLength), collapse = "\n") - } - ## https://stackoverflow.com/a/29847221 -} - - -#' Wrapping -#' -#' @param data list of ggplot2 objects -#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL -#' @param title panel title -#' @param guides passed to patchwork::wrap_plots() -#' @param axes passed to patchwork::wrap_plots() -#' @param axis_titles passed to patchwork::wrap_plots() -#' @param ... passed to patchwork::wrap_plots() -#' -#' @returns list of ggplot2 objects -#' @export -#' -wrap_plot_list <- function(data, - tag_levels = NULL, - title = NULL, - axis.font.family = NULL, - guides = "collect", - axes = "collect", - axis_titles = "collect", - y.axis.percentage = FALSE, - ...) { - if (ggplot2::is_ggplot(data[[1]])) { - if (length(data) > 1) { - out <- data |> - (\(.x) { - if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i) { - .y + ggplot2::ggtitle(.i) - }) - } else { - .x - } - })() |> - align_axes(percentage = y.axis.percentage) |> - patchwork::wrap_plots(guides = guides, - axes = axes, - axis_titles = axis_titles, - ...) - if (!is.null(tag_levels)) { - out <- out + patchwork::plot_annotation(tag_levels = tag_levels) - } - if (!is.null(title)) { - out <- out + - patchwork::plot_annotation( - title = title, - theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) - ) - } - } else { - out <- data[[1]] - } - } else { - cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") - } - - if (!is.null(axis.font.family)) { - if (inherits(x = out, what = "patchwork")) { - out <- out & - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } else { - out <- out + - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } - } - - out -} - - -#' Aligns axes between plots -#' -#' @param ... ggplot2 objects or list of ggplot2 objects -#' -#' @returns list of ggplot2 objects -#' @export -#' -align_axes <- function(..., - x.axis = TRUE, - y.axis = TRUE, - percentage = FALSE) { - # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object - # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 - if (ggplot2::is_ggplot(..1)) { - ## Assumes list of ggplots - p <- list(...) - } else if (is.list(..1)) { - ## Assumes list with list of ggplots - p <- ..1 - } else { - cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") - } - - yr <- clean_common_axis(p, "y") - - xr <- clean_common_axis(p, "x") - - suppressWarnings({ - p_out <- purrr::map(p, \(.x) { - out <- .x - if (isTRUE(x.axis)) { - out <- out + ggplot2::xlim(xr) - } - if (isTRUE(y.axis)) { - out <- out + ggplot2::ylim(yr) - } - out - }) - }) - - if (isTRUE(percentage)) { - lapply(p_out, \(.x) { - .x + - ggplot2::scale_y_continuous(labels = scales::percent) - }) - } else { - p_out - } -} - -#' Extract and clean axis ranges -#' -#' @param p plot -#' @param axis axis. x or y. -#' -#' @returns vector -#' @export -#' -clean_common_axis <- function(p, axis) { - purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> - unlist() |> - (\(.x) { - if (is.numeric(.x)) { - range(.x) - } else { - as.character(.x) - } - })() |> - unique() -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//redcap_read_shiny_module.R ######## @@ -8548,7 +7990,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") + title <- shiny::tags$h4( + i18n$t("Import data from REDCap"), + class = "redcap-module-title" + ) } server_ui <- shiny::tagList( @@ -8559,11 +8004,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText( - i18n$t( - "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" - ) - ), + shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), shiny::br(), shiny::br(), shiny::passwordInput( @@ -8572,16 +8013,13 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t( - "The token is a string of 32 numbers and letters." - )), + shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), shiny::br(), shiny::br(), shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = phosphoricons::ph("link",weight = "bold"), - # icon = shiny::icon("link", lib = "glyphicon"), + icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8592,10 +8030,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p( - phosphoricons::ph("info", weight = "bold"), - i18n$t("Please fill in web address and API token, then press 'Connect'.") - ) + tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) ), dismissible = TRUE ), @@ -8608,18 +8043,14 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") - ), - uiOutput(ns("filter_feedback")) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" + )) ) params_ui <- shiny::tagList( shiny::tags$h4(i18n$t("Data import parameters")), shiny::tags$div( - #### - #### All below was deactivated to deactivate filtering - #### style = htmltools::css( display = "grid", gridTemplateColumns = "1fr 50px", @@ -8637,19 +8068,14 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = phosphoricons::ph("funnel",weight = "bold"), - # label = shiny::icon("filter"), + label = shiny::icon("filter"), width = "50px" ), filter_ui ) ) ), - shiny::helpText( - i18n$t( - "Select fields/variables to import and click the funnel to apply optional filters" - ) - ), + shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -8657,8 +8083,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = phosphoricons::ph("download-simple",weight = "bold"), - # icon = shiny::icon("download", lib = "glyphicon"), + icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8669,10 +8094,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p( - phosphoricons::ph("info", weight = "bold"), - "Please specify data to download, then press 'Import'." - ) + tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") ), dismissible = TRUE ) @@ -8683,7 +8105,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), + shiny::conditionalPanel( + condition = "output.connect_success == true", + params_ui, + ns = ns + ), shiny::br() ) } @@ -8708,19 +8134,14 @@ m_redcap_readServer <- function(id) { dd_list = NULL, data = NULL, rep_fields = NULL, - code = NULL, - filter_valid = NULL + code = NULL ) shiny::observeEvent(list(input$api, input$uri), { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse( - endsWith(input$uri, "/"), - input$uri, - paste0(input$uri, "/") - ), "api/") + uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") } else { uri <- input$uri } @@ -8734,68 +8155,75 @@ m_redcap_readServer <- function(id) { }) - tryCatch({ - shiny::observeEvent(list(input$data_connect), { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch( + { + shiny::observeEvent( + list( + input$data_connect + ), + { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list(redcap_uri = data_rv$uri, token = input$api) - - # browser() - shiny::withProgress({ - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), - silent = TRUE) - }, message = paste("Connecting to", data_rv$uri)) - - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || - NROW(imported) < 1 || - ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), - !isTRUE(imported$success), - FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } - - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" - - data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b( - phosphoricons::ph("check", weight = "bold"), - i18n$t("Connected to server!") - ), - glue::glue( - i18n$t( - "The {data_rv$info$project_title} project is loaded." - ) - ) - ), - btn_show_data = TRUE + parameters <- list( + redcap_uri = data_rv$uri, + token = input$api ) - ) - data_rv$dd_list <- imported - } - }, ignoreInit = TRUE) - }, warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, error = function(err) { - showNotification(paste0(err), type = "error") - }) + # browser() + shiny::withProgress( + { + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) + }, + message = paste("Connecting to", data_rv$uri) + ) + + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } + + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" + + data_rv$info <- REDCapR::redcap_project_info_read( + redcap_uri = data_rv$uri, + token = input$api + )$data + + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), + glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) + ), + btn_show_data = TRUE + ) + ) + + data_rv$dd_list <- imported + } + }, + ignoreInit = TRUE + ) + }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -8826,7 +8254,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data + REDCapR::redcap_event_read( + redcap_uri = data_rv$uri, + token = input$api + )$data }) output$fields <- shiny::renderUI({ @@ -8836,7 +8267,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x) { + (\(.x){ split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -8869,10 +8300,14 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[ + data_rv$dd_list$data$form_name %in% repeated_instruments( + uri = data_rv$uri, + token = input$api + ) + ] - if (input$data_type == "long" && - isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -8908,48 +8343,12 @@ m_redcap_readServer <- function(id) { } }) - - filter_validation <- reactive({ - val <- trimws(input$filter) - if (nchar(val) == 0) - return(NULL) - validate_redcap_filter(val, purrr::pluck(data_rv$dd_list, "data")) - }) - - output$filter_feedback <- renderUI({ - result <- filter_validation() - if (is.null(result)) { - data_rv$filter_valid <- NULL - return(NULL) - } - - if (result$valid) { - data_rv$filter_valid <- TRUE - tags$span(style = "color: green;", "\u2713 Filter is valid") - } else { - data_rv$filter_valid <- FALSE - - tags$span(style = "color: red;", - "\u2717 ", - line_break(result$message, lineLength = 30)) - } - }) - shiny::observeEvent(input$data_import, { shiny::req(input$fields) # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] - if (!is.null(data_rv$filter_valid)) { - if (isTRUE(data_rv$filter_valid)) { - filter <- trimws(input$filter) - } else { - filter <- "" - } - } else { - filter <- "" - } parameters <- list( uri = data_rv$uri, @@ -8957,8 +8356,7 @@ m_redcap_readServer <- function(id) { fields = unique(c(record_id, input$fields)), events = input$arms, raw_or_label = "both", - filter_logic = filter, - # filter_logic = "", + filter_logic = input$filter, split_forms = ifelse( input$data_type == "long" && !is.null(input$data_type), "none", @@ -8967,48 +8365,31 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try({ - rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters) - # if (nrow(out)==0){ - # stop("No data was exported") - # } else { - # out - # } - }, # error = function(err) { - # showNotification(i18n$t("An error was encountered exporting data. Please review data filter."), type = "error") - # }, - silent = TRUE) + imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) }) - # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) + parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] - parameters_code <- parameters[c("uri", - "fields", - "events", - "raw_or_label", - "filter_logic")] + code <- rlang::call2( + "easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST" + ) - code <- rlang::call2("easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST") - - if (inherits(imported, "try-error") | - NROW(imported) == 0 | - (length(imported) == 1 & !is.list(imported))) { + if (inherits(imported, "try-error") || NROW(imported) < 1) { data_rv$data_status <- "error" data_rv$data_list <- NULL - data_rv$data_message <- i18n$t("An empty data set was imported. Please review data filter.") - data_rv$data <- NULL + data_rv$data_message <- imported$raw_text } else { data_rv$data_status <- "success" data_rv$data_message <- i18n$t("Requested data was retrieved!") @@ -9017,11 +8398,12 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { + # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() } else { - if (identical(input$fill, "yes")) { + if (input$fill == "yes") { ## Repeated fields @@ -9039,102 +8421,78 @@ m_redcap_readServer <- function(id) { } } - ## Ensure correct factor labels - ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way - out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) - - + # browser() in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply( - parameters$fields, \(.y) startsWith(.x, .y) - ))) + sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t( - "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." - ) + data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t( - "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." - ) + data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") } data_rv$code <- code - ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() - } }) - shiny::observeEvent(data_rv$data_status, { - if (identical(data_rv$data_status, "error")) { - ## The insert error wouldn't work. Inserted through regular. - # datamods:::insert_error(mssg = data_rv$data_message, - # selector = ns("retrieved")) - datamods:::insert_alert( - selector = ns("retrieved"), - status = "danger", - tags$p( - tags$b( - phosphoricons::ph("warning", weight = "bold"), - "Warning!" - ), - data_rv$data_message + shiny::observeEvent( + data_rv$data_status, + { + # browser() + if (identical(data_rv$data_status, "error")) { + datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) + ), + btn_show_data = TRUE + ) ) - ) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p(tags$b( - phosphoricons::ph("check", weight = "bold"), + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), data_rv$data_message - )), - btn_show_data = TRUE + ) ) - ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b( - phosphoricons::ph("warning", weight = "bold"), - "Warning!" - ), - data_rv$data_message - ) - ) + } } - }) - - return( - list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - ) ) + + return(list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + )) } - shiny::moduleServer(id = id, module = module) + shiny::moduleServer( + id = id, + module = module + ) } #' @importFrom htmltools tagList tags @@ -9145,12 +8503,14 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList(extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - )) + success_message <- tagList( + extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + ) + ) } return(success_message) } @@ -9202,18 +8562,20 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, - pattern_env = NULL, - nchar = 32) { +is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) + checkmate::assert_character(pattern_env, + any.missing = FALSE, + len = 1 + ) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">") + .open = "<", + .close = ">" + ) } if (is.na(token)) { @@ -9253,15 +8615,10 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c( - names(data)[1], - "redcap_event_name", - "redcap_repeat_instrument", - "redcap_repeat_instance" - ) + generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") filt <- split(data, data[[event]]) |> - lapply(\(.x) { + lapply(\(.x){ dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -9271,327 +8628,6 @@ drop_empty_event <- function(data, event = "redcap_event_name") { } -#' Validate a REDCap server-side filter string against a data dictionary -#' -#' Checks that a REDCap filter expression is syntactically correct and -#' consistent with the field types defined in the project data dictionary. -#' Plain text without field references is always rejected. Multi-clause -#' filters joined by \code{AND} or \code{OR} are supported. -#' -#' @param filter A single character string containing the filter expression, -#' e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}. -#' @param dictionary A data frame representing the REDCap data dictionary in -#' API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. -#' Must contain at least the columns \code{field_name} and \code{field_type}. -#' The columns \code{text_validation_type_or_show_slider_number} and -#' \code{select_choices_or_calculations} are used when present for stricter -#' type and choice validation. -#' -#' @return A named list with two elements: -#' \describe{ -#' \item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} -#' \item{\code{message}}{Character. \code{"Filter is valid."} on success, or -#' a newline-separated string of error messages describing every problem -#' found.} -#' } -#' -#' @details -#' Validation rules by field type: -#' \describe{ -#' \item{\code{calc}}{Numeric fields. Value must be an unquoted number. -#' All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, -#' \code{<=}, \code{>=}) are accepted.} -#' \item{\code{text} with date validation}{Fields with validation type -#' \code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be -#' a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All -#' comparison operators are accepted.} -#' \item{\code{text} with time validation}{Fields with validation type -#' \code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time -#' string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} -#' \item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a -#' quoted choice code (e.g. \code{'1'}) that exists in the field's choice -#' list. Only \code{=} and \code{!=} are accepted.} -#' \item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. -#' Only \code{=} and \code{!=} are accepted.} -#' } -#' -#' @examples -#' \dontrun{ -#' dict <- REDCapCAST::get_redcap_metadata( -#' uri = "https://redcap.example.com/api/", -#' token = Sys.getenv("REDCAP_TOKEN") -#' ) -#' -#' validate_redcap_filter("[age] > 18", dict) -#' #> list(valid = TRUE, message = "Filter is valid.") -#' -#' validate_redcap_filter("only plain text", dict) -#' #> list(valid = FALSE, message = "Filter must contain at least one field ...") -#' -#' validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) -#' #> list(valid = TRUE, message = "Filter is valid.") -#' } -#' -#' @export -# REDCap filter validation based on data dictionary -# -# REDCap filter format: [field_name] operator value -# Example: [age] > 18 -# [cohabitation] = '1' -# [inclusion] > '2020-01-01' -# -# Supported field types and their allowed operators/value formats: -# text (no validation) -> string values, = != operators only -# text (date_ymd/date_dmy) -> quoted date strings, all comparison operators -# text (time_hh_mm_ss) -> quoted time strings, all comparison operators -# text (datetime_*) -> quoted datetime strings, all comparison operators -# text (autocomplete) -> string values, = != operators only -# calc -> numeric values, all comparison operators -# radio/dropdown -> quoted numeric codes, = != operators only - -validate_redcap_filter <- function(filter, dictionary) { - # --- Input checks --- - if (!is.character(filter) || - length(filter) != 1 || nchar(trimws(filter)) == 0) { - return(list(valid = FALSE, message = "Filter must be a non-empty string.")) - } - - if (!grepl("\\[.+\\]", filter)) { - return( - list(valid = FALSE, message = "Filter must contain at least one field reference in [brackets]. Plain text is not accepted.") - ) - } - - # --- Column names (API export format) --- - col_field <- "field_name" - col_type <- "field_type" - col_val_type <- "text_validation_type_or_show_slider_number" - col_choices <- "select_choices_or_calculations" - - missing_cols <- setdiff(c(col_field, col_type), names(dictionary)) - if (length(missing_cols) > 0) { - stop("Dictionary is missing required columns: ", - paste(missing_cols, collapse = ", ")) - } - - # --- Build lookup index once for O(1) field access --- - field_idx <- setNames(seq_len(nrow(dictionary)), dictionary[[col_field]]) - has_val_type <- col_val_type %in% names(dictionary) - has_choices <- col_choices %in% names(dictionary) - - # --- Classify field types --- - numeric_types <- c("calc") - date_validations <- c( - "date_ymd", - "date_dmy", - "datetime_ymd", - "datetime_dmy", - "datetime_seconds_ymd", - "datetime_seconds_dmy" - ) - time_validations <- c("time_hh_mm_ss", "time_mm_ss") - categorical_types <- c("radio", "dropdown", "checkbox") - text_types <- c("text", "autocomplete") - - num_ops <- c("=", "!=", "<", ">", "<=", ">=") - cat_ops <- c("=", "!=") - text_ops <- c("=", "!=") - - # --- Parse filter into clauses --- - # Split on AND/OR (REDCap uses 'and'/'or' or 'AND'/'OR') - clauses <- trimws(strsplit(filter, "(?i)\\s+(and|or)\\s+", perl = TRUE)[[1]]) - - clause_pattern <- "^\\[([^\\]]+)\\]\\s*(=|!=|<=|>=|<|>)\\s*(.+)$" - - errors <- character(0) - - for (clause in clauses) { - if (!grepl(clause_pattern, clause, perl = TRUE)) { - errors <- c( - errors, - sprintf( - "Clause '%s' does not match expected format: [field] operator value", - clause - ) - ) - next - } - - parts <- regmatches(clause, regexec(clause_pattern, clause, perl = TRUE))[[1]] - field <- parts[2] - operator <- parts[3] - value <- trimws(parts[4]) - - # --- Check field exists using pre-built index --- - row_i <- field_idx[field] - if (is.na(row_i)) { - errors <- c(errors, sprintf("Unknown field: [%s]", field)) - next - } - - field_type <- dictionary[[col_type]][row_i] - val_type <- if (has_val_type) - dictionary[[col_val_type]][row_i] - else - "" - if (is.na(val_type)) - val_type <- "" - - # --- Determine expected value format and allowed operators --- - if (field_type %in% numeric_types || - grepl("^integer$|^number", val_type)) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is numeric — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl("^-?[0-9]+(\\.[0-9]+)?$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is numeric — value '%s' should be an unquoted number (e.g. 18 or 3.5)", - field, - value - ) - ) - } - - } else if (val_type %in% date_validations) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a date — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl( - "^'[0-9]{4}-[0-9]{2}-[0-9]{2}(\\s[0-9]{2}:[0-9]{2}(:[0-9]{2})?)?'$", - value - )) { - errors <- c( - errors, - sprintf( - "[%s] is a date — value '%s' should be a quoted date string, e.g. '2020-01-31'", - field, - value - ) - ) - } - - } else if (val_type %in% time_validations) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a time — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl("^'[0-9]{2}:[0-9]{2}(:[0-9]{2})?'$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is a time — value '%s' should be a quoted time string, e.g. '14:30:00'", - field, - value - ) - ) - } - - } else if (field_type %in% categorical_types) { - if (!operator %in% cat_ops) { - errors <- c( - errors, - sprintf( - "[%s] is categorical — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(cat_ops, collapse = ", ") - ) - ) - } - - # Validate value is a known choice code - choices_raw <- if (has_choices) - dictionary[[col_choices]][row_i] - else - NA - if (!is.na(choices_raw) && nchar(trimws(choices_raw)) > 0) { - choice_codes <- trimws(gsub(",.+?(\\||$)", "", gsub( - "^\\s*", "", strsplit(choices_raw, "\\|")[[1]] - ))) - value_unquoted <- gsub("^'|'$", "", value) - if (!value_unquoted %in% choice_codes) { - errors <- c( - errors, - sprintf( - "[%s] is categorical — '%s' is not a valid choice code. Valid codes: %s", - field, - value_unquoted, - paste(choice_codes, collapse = ", ") - ) - ) - } - } - - if (!grepl("^'.*'$", value)) { - errors <- c(errors, - sprintf( - "[%s] is categorical — value should be quoted, e.g. '1'", - field - )) - } - - } else { - # Plain text field - if (!operator %in% text_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a text field — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(text_ops, collapse = ", ") - ) - ) - } - if (!grepl("^'.*'$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is a text field — value should be quoted, e.g. 'some text'", - field - ) - ) - } - } - } - - if (length(errors) > 0) { - return(list( - valid = FALSE, - message = paste(errors, collapse = "\n") - )) - } - - list(valid = TRUE, message = "Filter is valid.") -} - - - #' Test app for the redcap_read_shiny_module #' #' @rdname redcap_read_shiny_module @@ -9610,10 +8646,16 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable({ - shiny::req(data_val$data) - data_val$data() - }, options = list(scrollX = TRUE, pageLength = 5), ) + output$data <- DT::renderDataTable( + { + shiny::req(data_val$data) + data_val$data() + }, + options = list( + scrollX = TRUE, + pageLength = 5 + ), + ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code() @@ -10653,8 +9695,7 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = phosphoricons::ph("calculator"), - # icon = bsicons::bs_icon("calculator"), + icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -10688,8 +9729,7 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = phosphoricons::ph("math-operations"), - # icon = bsicons::bs_icon("pencil"), + icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -10734,8 +9774,7 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = phosphoricons::ph("chart-bar-horizontal"), - # icon = bsicons::bs_icon("bar-chart-steps"), + icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -10778,8 +9817,7 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ) @@ -10800,8 +9838,7 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = phosphoricons::ph("checks"), - # icon = bsicons::bs_icon("clipboard-check"), + icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -11017,7 +10054,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") } ) } @@ -11082,7 +10119,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") } ) } @@ -11160,7 +10197,7 @@ regression_server <- function(id, gg_theme_shiny() }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") } ) }) @@ -11220,7 +10257,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") } ) } @@ -11291,7 +10328,7 @@ regression_server <- function(id, out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") } ) @@ -11461,7 +10498,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -11945,8 +10982,7 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) } else { # Return NULL to show nothing @@ -12237,8 +11273,7 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = phosphoricons::ph("house", weight = "bold"), - # icon = shiny::icon("house"), + icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -12268,8 +11303,7 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = phosphoricons::ph("play", weight = "bold"), - # icon = shiny::icon("play"), + icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -12346,8 +11380,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars",weight = "bold"), - # icon = shiny::icon("binoculars"), + icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -12391,8 +11424,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play",weight = "bold"), - # icon = shiny::icon("play"), + icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -12411,13 +11443,11 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = phosphoricons::ph("note-pencil", weight = "bold"), - # icon = shiny::icon("pen-to-square"), + icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = phosphoricons::ph("eye"), - # icon = shiny::icon("eye"), + icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -12469,7 +11499,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", + href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -12492,8 +11522,7 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = phosphoricons::ph("pencil-line"), - # icon = shiny::icon("file-pen"), + icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -12522,13 +11551,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor"), + label = i18n$t("Modify factor levels"), width = "100%" ), shiny::tags$br(), - shiny::helpText(i18n$t( - "Modify the levels of factor/categorical variables." - )), + shiny::helpText( + i18n$t("Reorder or rename the levels of factor/categorical variables.") + ), shiny::tags$br(), shiny::tags$br() ), @@ -12541,7 +11570,9 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t("Create factor/categorical variable from other variables.") + i18n$t( + "Create factor/categorical variable from a continous variable (number/date/time)." + ) ), shiny::tags$br(), shiny::tags$br() @@ -12618,16 +11649,14 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = phosphoricons::ph("magnifying-glass", weight = "bold"), - # icon = shiny::icon("magnifying-glass-chart"), + icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = phosphoricons::ph("table"), - # icon = bsicons::bs_icon("table"), + icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12639,8 +11668,7 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = phosphoricons::ph("table"), - # icon = bsicons::bs_icon("table"), + icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -12682,8 +11710,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator",weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -12697,8 +11724,7 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = phosphoricons::ph("graph"), - # icon = bsicons::bs_icon("bounding-box"), + icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12739,8 +11765,7 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = phosphoricons::ph("placeholder") - # icon = bsicons::bs_icon("x-circle") + icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -12755,8 +11780,7 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = phosphoricons::ph("chart-line", weight = "bold"), - # icon = shiny::icon("chart-line"), + icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -12777,8 +11801,7 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = phosphoricons::ph("calculator", weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -12790,8 +11813,7 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = phosphoricons::ph("download-simple", weight = "bold"), - # icon = shiny::icon("download"), + icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -12827,8 +11849,7 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -12858,8 +11879,7 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ), @@ -12916,7 +11936,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://freesearchr.github.io/FreesearchR-knowledge/", + href = "https://agdamsbo.github.io/FreesearchR/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", @@ -12978,33 +11998,22 @@ update_factor_ui <- function(id) { ), fluidRow( column( - width = 3, + width = 6, shinyWidgets::virtualSelectInput( inputId = ns("variable"), - label = i18n$t("Choose variable:"), + label = i18n$t("Factor variable to reorder:"), choices = NULL, width = "100%", zIndex = 50 ) ), - column( - width = 3, - class = "d-flex align-items-end", - actionButton( - disabled = TRUE, - inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), - class = "btn-outline-primary mb-3", - width = "100%" - ) - ), column( width = 3, class = "d-flex align-items-end", actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending",weight = "bold"), + phosphoricons::ph("sort-ascending"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -13017,7 +12026,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending",weight = "bold"), + phosphoricons::ph("sort-ascending"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -13030,9 +12039,7 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t( - "Create a new variable; otherwise replaces (Updating labels always creates new variable)" - ), + label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), value = FALSE, status = "primary", outline = TRUE, @@ -13041,7 +12048,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise",weight = "bold"), + phosphoricons::ph("arrow-clockwise"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -13087,20 +12094,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- grid }) - observeEvent(rv$data_grid, { - variable <- req(input$variable) - if (isTRUE(has_empty_levels(rv$data[[variable]]))) { - # browser() - updateActionButton(inputId = "drop_levels", disabled = FALSE) - } else { - updateActionButton(inputId = "drop_levels", disabled = TRUE) - } - }) - - observeEvent(input$drop_levels, { - rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,] - }) - observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -13184,7 +12177,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { ) data <- tryCatch({ - with_labels(data, { + with_labels(data,{ rlang::exec(factor_new_levels_labels, !!!modifyList(parameters, val = list(data = data))) }) @@ -13194,7 +12187,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { "We encountered the following error creating the new factor:", err ), - type = "error") + type = "err") }) # browser() @@ -13348,15 +12341,6 @@ unique_names <- function(new, existing = character()) { } -has_empty_levels <- function(x) { - if (is.factor(x)) { - any(!levels(x) %in% x) - } else { - return(FALSE) - } -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R ######## @@ -13393,7 +12377,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear",weight = "bold"), + label = phosphoricons::ph("gear"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -13438,7 +12422,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), i18n$t("Apply changes") ), width = "100%" @@ -15887,7 +14871,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "error") + ), type = "err") }) }) @@ -16144,7 +15128,6 @@ server <- function(input, output, session) { inputId = "column_filter", label = i18n$t("Select data types to include"), selected = unique(data_type(rv$data)), - #[unique(data_type(rv$data))!="text"], choices = unique(data_type(rv$data)), updateOn = "change", multiple = TRUE, @@ -16237,58 +15220,48 @@ server <- function(input, output, session) { ######### Data filter # IDEAFilter has the least cluttered UI, but might have a License issue # Consider using shinyDataFilter, though not on CRAN - data_filter_raw <- IDEAFilter::IDEAFilter( + data_filter <- IDEAFilter::IDEAFilter( "data_filter", - data = shiny::reactive(non_character_cols(rv$data_variables)), + data = shiny::reactive(rv$data_variables), verbose = TRUE ) - data_filter <- reactive({ - apply_idea_filter(data_filter_raw, rv$data_variables) + shiny::observeEvent(list( + shiny::reactive(rv$data_variables), + shiny::reactive(rv$data_original), + data_filter(), + # regression_vars(), + input$complete_cutoff + ), + { + ### Save filtered data + rv$data_filtered <- data_filter() + + ### Save filtered data + ### without empty factor levels + rv$list$data <- data_filter() |> + REDCapCAST::fct_drop() |> + (\(.x) { + .x[!sapply(.x, is.character)] + })() + + ## This looks messy!! But it works as intended for now + + out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( + attr(rv$data_filtered, "code") + ), collapse = " "))) + + out <- strsplit(out, "%>%") |> + unlist() |> + (\(.x) { + paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"), collapse = "|> \n ") + })() + + rv$code <- append_list(data = out, + list = rv$code, + index = "filter") }) - shiny::observeEvent( - list( - shiny::reactive(rv$data_variables), - shiny::reactive(rv$data_original), - data_filter_raw(), - # regression_vars(), - input$complete_cutoff - ), - { - ### Save filtered data - # browser() - # rv$data_filtered <- apply_idea_filter(data_filter_raw, rv$data_variables)() - rv$data_filtered <- data_filter() - - ### Save filtered data - ### ~~without empty factor levels~~ - ### All factor levels are kept, but can be manually removed - # browser() - rv$list$data <- rv$data_filtered #|> - # # REDCapCAST::fct_drop() |> - # (\(.x) { - # .x[!sapply(.x, is.character)] - # })() - - ## This looks messy!! But it works as intended for now - # browser() - out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( - attr(data_filter_raw(), "code") - ), collapse = " "))) - - out <- strsplit(out, "%>%") |> - unlist() |> - (\(.x) { - paste(c("df <- df", .x[-1]), collapse = "|> \n ") - })() - - rv$code <- append_list(data = out, - list = rv$code, - index = "filter") - } - ) - ######### Data preview ### Overview @@ -16306,7 +15279,7 @@ server <- function(input, output, session) { observeEvent(input$modal_browse, { tryCatch({ show_data( - rv$data_filtered, + REDCapCAST::fct_drop(rv$data_filtered), title = i18n$t("Uploaded data overview"), type = "modal" ) @@ -16314,7 +15287,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error browsing your data:"), err - ), type = "error") + ), type = "err") }) }) @@ -16340,7 +15313,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "error") + ), type = "err") }) }) @@ -16547,7 +15520,7 @@ server <- function(input, output, session) { # } # }, # error = function(err) { - # showNotification(err, type = "error") + # showNotification(err, type = "err") # } # ) @@ -16608,9 +15581,7 @@ server <- function(input, output, session) { ######### ############################################################################## - pl <- data_visuals_server("visuals", - data = shiny::reactive(rv$list$data), - palettes = color_choices()) + pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data)) ############################################################################## ######### @@ -16708,7 +15679,7 @@ server <- function(input, output, session) { "We encountered the following error creating your report: " ), err - ), type = "error") + ), type = "err") }) }) file.rename(paste0("www/report.", type), file) diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 517df60d..ce9abc8e 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -55,6 +55,7 @@ "Imported data","Importeret data" "www/intro.md","www/intro.md" "Choose your data","Vælg dine data" +"Factor variable to reorder:","Kategoriske variabel der skal ændres:" "Sort by levels","Sorter efter niveauer" "Sort by count","Sorter efter antal" "Update factor variable","Updater faktor-variabel" @@ -89,6 +90,7 @@ "and","og" "from each pair","fra hvert par" "Plot","Tegn" +"Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" "Plot width (mm)","Bredde af grafik (mm)" "File format","File format" @@ -96,7 +98,12 @@ "Select variable","Vælg variabel" "Response variable","Svarvariable" "Plot type","Type af grafik" +"Please select","Vælg" +"Additional variables","Yderligere variabler" +"Secondary variable","Sekundær variabel" "No variable","Ingen variabel" +"Grouping variable","Variabel til gruppering" +"No stratification","Ingen stratificering" "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" @@ -141,12 +148,16 @@ "Import data from REDCap","Importér data fra REDCap" "REDCap server","REDCap-server" "Web address","Serveradresse" +"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Adressen skal være som 'https://redcap.your.institution/' eller 'https://your.institution/redcap/'" "API token","API-nøgle" +"The token is a string of 32 numbers and letters.","En API-nøgle består af ialt 32 tal og bogstaver." "Connect","Forbind" "Data import parameters","Data import parameters" +"Select fields/variables to import and click the funnel to apply optional filters","Vælg variabler, der skal importeres og tryk på tragten for at anvende valgfrie filtre" "Import","Import" "Click to see data dictionary","Tryk for at se metadata (Data Dictionary)" "Connected to server!","Forbindelse til serveren oprettet!" +"The {data_rv$info$project_title} project is loaded.","{data_rv$info$project_title}-projektet er forbundet." "Data dictionary","Data dictionary" "Preview:","Forsmag:" "Imported data set","Importeret datasæt" @@ -154,6 +165,8 @@ "Specify the data format","Specificér dataformatet" "Fill missing values?","Skal manglende observationer udfyldes?" "Requested data was retrieved!","Det udvalgte data blev hentet!" +"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde ID-variablen. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." +"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde nogle af de udvalgte variabler. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." "Click to see the imported data","Tryk for at se de importerede data" "Regression table","Regressionstabel" "Import a dataset from an environment","Importer et datasæt fra et kodemiljø" @@ -254,6 +267,7 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR er tilgængelig på flere sprog. For at få hjælp med oversættelser, kontakt os venligst på info@freesearchr.org" "Home","Hjem" "Start with FreesearchR for basic data evaluation and analysis.","Start med FreesearchR til grundlæggende dataevaluering og -analyse." +"When you need more advanced tools, you'll be better prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være bedre forberedt på at bruge R direkte." "(Read more)","(Læs mere)" "Run the FreesearchR app locally when working with sensitive data.","Kør FreesearchR-appen lokalt, når du arbejder med følsomme data." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Indlæs data fra regneark, REDCap-servere, eller prøv med eksempeldata. Flere kilder understøttes for maksimal fleksibilitet." @@ -264,16 +278,20 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være forberedt på at bruge R direkte." "The app contains a selelct number of features and will guide you through key analyses.","Appen indeholder udvalgte funktioner, og guider dig gennem de vigtigste analyser." "Sort by Levels","Sorter efter niveauer" +"Modify factor levels","Ændr kategoriske niveauer" +"Reorder or rename the levels of factor/categorical variables.","Ændr navn eller rækkefølge på kategorisk variabel." "Maximum number of observations:","Maximale antal observationer:" "setting to 0 includes all","angiv 0 for at inkludere alle" "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." "Select a sample dataset from a package.","Vælg et træningsdatasæt." "Data ready to be imported!","Data er klar til at blive importeret!" +"Data has %s obs. of %s variables.","Data har %s obs. på %s variabler." "Data successfully imported!","Data successfully imported!" "Click to see data","Klik for at se data" "No data present.","Ingen data tilstede." "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -304,23 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" -"Drop empty","Drop empty" -"Choose variable:","Choose variable:" -"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." -"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." -"Likert diagram","Likert diagram" -"Modify factor","Modify factor" -"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." -"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." -"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." -"Define plot","Define plot" "Choose color palette","Choose color palette" -"Additional variable","Additional variable" -"Grouping variable","Grouping variable" -"Secondary variable","Secondary variable" -"Reverse colors","Reverse colors" -"Plot survey results","Plot survey results" -"Additional variables","Additional variables" -"Other variables","Other variables" -"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index c56e9549..96a7a109 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -55,6 +55,7 @@ "Imported data","Data iliyoingizwa" "www/intro.md","www/intro.md" "Choose your data","Chagua data yako" +"Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:" "Sort by levels","Panga kwa viwango" "Sort by count","Panga kwa hesabu" "Update factor variable","Sasisha kigezo cha kipengele" @@ -89,6 +90,7 @@ "and","na" "from each pair","kutoka kwa kila jozi" "Plot","Kipande cha habari" +"Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" "Plot width (mm)","Upana wa kiwanja (mm)" "File format","Umbizo la faili" @@ -96,7 +98,12 @@ "Select variable","Chagua kigezo" "Response variable","Kigezo cha majibu" "Plot type","Aina ya kiwanja" +"Please select","Tafadhali chagua" +"Additional variables","Vigezo vya ziada" +"Secondary variable","Kigezo cha pili" "No variable","Hakuna kigezo" +"Grouping variable","Kigezo cha kuweka katika makundi" +"No stratification","Hakuna matabaka" "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" @@ -141,12 +148,16 @@ "Import data from REDCap","Ingiza data kutoka REDCap" "REDCap server","Seva ya REDCap" "Web address","Anwani ya wavuti" +"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Muundo unapaswa kuwa 'https://redcap.your.institution/' au 'https://your.institution/redcap/'" "API token","Tokeni ya API" +"The token is a string of 32 numbers and letters.","Tokeni ni mfuatano wa nambari na herufi 32." "Connect","Unganisha" "Data import parameters","Vigezo vya kuingiza data" +"Select fields/variables to import and click the funnel to apply optional filters","Chagua sehemu/vigezo vya kuingiza na ubofye faneli ili kutumia vichujio vya hiari" "Import","Ingiza" "Click to see data dictionary","Bofya ili kuona kamusi ya data" "Connected to server!","Imeunganishwa na seva!" +"The {data_rv$info$project_title} project is loaded.","Mradi wa {data_rv$info$project_title} umepakiwa." "Data dictionary","Kamusi ya data" "Preview:","Hakikisho:" "Imported data set","Seti ya data iliyoingizwa" @@ -154,6 +165,8 @@ "Specify the data format","Bainisha umbizo la data" "Fill missing values?","Jaza thamani zinazokosekana?" "Requested data was retrieved!","Data iliyoombwa ilipatikana!" +"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana ni kitambulisho pekee kilichorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." +"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana kama si sehemu zote zilizoombwa zilizorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." "Click to see the imported data","Bofya ili kuona data iliyoingizwa" "Regression table","Jedwali la urejeshaji" "Import a dataset from an environment","Ingiza seti ya data kutoka kwa mazingira" @@ -254,6 +267,7 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR inapatikana katika lugha nyingi. Ili kukusaidia na tafsiri, tafadhali wasiliana nasi kwa info@freesearchr.org." "Home","Nyumbani" "Start with FreesearchR for basic data evaluation and analysis.","Anza na FreesearchR kwa tathmini na uchambuzi wa data ya msingi." +"When you need more advanced tools, you'll be better prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari zaidi kutumia R moja kwa moja." "(Read more)","(Soma zaidi)" "Run the FreesearchR app locally when working with sensitive data.","Endesha programu ya FreesearchR ndani ya eneo lako unapofanya kazi na data nyeti." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Pakia data kutoka kwa lahajedwali, seva za REDCap, au jaribu na data ya sampuli. Vyanzo vingi vinaungwa mkono kwa unyumbufu wa hali ya juu." @@ -264,16 +278,20 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari kutumia R moja kwa moja." "The app contains a selelct number of features and will guide you through key analyses.","The app contains a selelct number of features and will guide you through key analyses." "Sort by Levels","Sort by Levels" +"Modify factor levels","Modify factor levels" +"Reorder or rename the levels of factor/categorical variables.","Reorder or rename the levels of factor/categorical variables." "Maximum number of observations:","Maximum number of observations:" "setting to 0 includes all","setting to 0 includes all" "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." "Select a sample dataset from a package.","Select a sample dataset from a package." "Data ready to be imported!","Data ready to be imported!" +"Data has %s obs. of %s variables.","Data has %s obs. of %s variables." "Data successfully imported!","Data successfully imported!" "Click to see data","Click to see data" "No data present.","No data present." "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -304,23 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" -"Drop empty","Drop empty" -"Choose variable:","Choose variable:" -"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." -"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." -"Likert diagram","Likert diagram" -"Modify factor","Modify factor" -"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." -"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." -"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." -"Define plot","Define plot" "Choose color palette","Choose color palette" -"Additional variable","Additional variable" -"Grouping variable","Grouping variable" -"Secondary variable","Secondary variable" -"Reverse colors","Reverse colors" -"Plot survey results","Plot survey results" -"Additional variables","Additional variables" -"Other variables","Other variables" -"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/examples/visuals_module_demo.R b/examples/visuals_module_demo.R index e4883d6c..00a8c020 100644 --- a/examples/visuals_module_demo.R +++ b/examples/visuals_module_demo.R @@ -22,7 +22,7 @@ visuals_demo_app <- function() { ) ) server <- function(input, output, session) { - pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars)),palettes = color_choices()) + pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars))) } shiny::shinyApp(ui, server) } diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 7baeb26b..1b6bf0c1 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//RtmpAe8F1F/file150d9fbea069.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpoawSeD/fileab3b7554cf72.R ######## i18n_path <- system.file("translations", package = "FreesearchR") @@ -64,7 +64,7 @@ i18n$set_translation_language("en") #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'26.6.1' +app_version <- function()'26.3.4' ######## @@ -84,10 +84,7 @@ app_version <- function()'26.6.1' #' @examples #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) -baseline_table <- function(data, - fun.args = NULL, - fun = gtsummary::tbl_summary, - vars = NULL) { +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) } @@ -113,15 +110,7 @@ baseline_table <- function(data, #' 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.diff = FALSE, - add.overall = FALSE, - theme = c("jama", "lancet", "nejm", "qjecon"), - detail_level = c("minimal", "extended"), - drop_empty = FALSE) { +create_baseline <- function(data, ..., by.var, add.p = FALSE, add.diff=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) @@ -148,28 +137,31 @@ create_baseline <- function(data, 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}") + 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}")) ) - )) + ) } } - if (isTRUE(drop_empty)) { - ## Drops empty levels if minimal - data <- data |> REDCapCAST::fct_drop() - } - - parameters <- list(data = data, fun.args = purrr::list_flatten(list(by = by.var, args))) + parameters <- list( + data = data, + fun.args = purrr::list_flatten(list(by = by.var, args)) + ) # browser() - out <- do.call(baseline_table, parameters) + out <- do.call( + baseline_table, + parameters + ) if (!is.null(by.var)) { @@ -512,7 +504,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") + phosphoricons::ph("pencil"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -520,7 +512,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle",weight = "bold"), + phosphoricons::ph("x-circle"), i18n$t("Cancel") ), class = "btn-outline-danger", @@ -1129,7 +1121,7 @@ vectorSelectInput <- function(inputId, colorSelectInput <- function(inputId, label, choices, - selected = NULL, + selected = "", previews = 4, ..., placeholder = "") { @@ -1165,43 +1157,31 @@ colorSelectInput <- function(inputId, choices_new <- stats::setNames(vals, labels) - if (is.null(selected) || selected == "") { - selected <- vals[[1]] - } - shiny::selectizeInput( inputId = inputId, label = label, choices = choices_new, selected = selected, ..., - options = list( + options = list( render = I( "{ - option: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '
' + escape(item.data.name) + '
' + - (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + - '
' + item.data.swatch + '
' + - '
'; - }, - item: function(item, escape) { - item.data = JSON.parse(item.label); - return '
' + - '' + escape(item.data.name) + '' + - item.data.swatch + - '
'; - } - }" - ), - onInitialize = I( - "function() { - var self = this; - self.$control_input.prop('readonly', true); - self.$control_input.css('cursor', 'default'); - self.$control.css('cursor', 'pointer'); - }" + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + escape(item.data.name) + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
' + item.data.swatch + '
' + + '
'; + }, + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '' + escape(item.data.name) + '' + + item.data.swatch + + '
'; + } + }" ) ) ) @@ -1568,7 +1548,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -1882,7 +1862,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { rlang::exec(cut_var, !!!parameters) }, error = function(err) { - showNotification(paste("We encountered the following error creating the new factor:", err), type = "error") + showNotification(paste("We encountered the following error creating the new factor:", err), type = "err") } ) @@ -2151,25 +2131,13 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { list( bslib::layout_sidebar( sidebar = bslib::sidebar( - shiny::actionButton( - inputId = ns("act_plot"), - label = i18n$t("Plot"), - width = "100%", - icon = phosphoricons::ph("paint-brush", weight = "bold"), - # icon = shiny::icon("palette"), - disabled = FALSE - ), - shiny::helpText( - i18n$t('Adjust plot input and settings below, then press "Plot".') - ), bslib::accordion( id = "acc_plot", multiple = FALSE, bslib::accordion_panel( value = "acc_pan_plot", - title = i18n$t("Define plot"), - icon = phosphoricons::ph("chart-line"), - # icon = bsicons::bs_icon("graph-up"), + title = "Create plot", + icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -2178,22 +2146,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")) - ), - bslib::accordion_panel( - value = "acc_pan_params", - title = i18n$t("Settings"), - icon = phosphoricons::ph("gear"), + shiny::uiOutput(outputId = ns("tertiary")), shiny::uiOutput(outputId = ns("color_palette")), - shiny::uiOutput(outputId = ns("basic_parameters")), + shiny::br(), + shiny::actionButton( + inputId = ns("act_plot"), + label = i18n$t("Plot"), + width = "100%", + icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) ), bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = phosphoricons::ph("download-simple"), - # icon = bsicons::bs_icon("download"), + icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -2232,22 +2201,21 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ), shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "65vh"), + shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -2264,7 +2232,21 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, data, palettes = color_choices(), ...) { +data_visuals_server <- function(id, + data, + palettes = c( + "Perceptual (blue-yellow)" = "viridis", + "Perceptual (fire)" = "plasma", + "Colour-blind friendly" = "Okabe-Ito", + "Qualitative (bold)" = "Dark 2", + "Qualitative (paired)" = "Paired", + "Sequential (blues)" = "Blues", + "Diverging (red-blue)" = "RdBu", + "Tableau style" = "Tableau 10", + "Pastel" = "Pastel 1", + "Rainbow" = "rainbow" + ), + ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -2285,6 +2267,100 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { title = i18n$t("Download")) }) + # ## --- New attempt + # + # rv$plot.params <- shiny::reactive({ + # get_plot_options(input$type) |> purrr::pluck(1) + # }) + # + # c(output, + # list(shiny::renderUI({ + # columnSelectInput( + # inputId = ns("primary"), + # data = data, + # placeholder = "Select variable", + # label = "Response variable", + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$primary) + # # browser() + # + # if (!input$primary %in% names(data())) { + # plot_data <- data()[1] + # } else { + # plot_data <- data()[input$primary] + # } + # + # plots <- possible_plots( + # data = plot_data + # ) + # + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x){ + # stats::setNames(.x$descr, .x$note) + # }) + # + # vectorSelectInput( + # inputId = ns("type"), + # selected = NULL, + # label = shiny::h4("Plot type"), + # choices = Reduce(c, plots_named), + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # + # cols <- c( + # rv$plot.params()[["secondary.extra"]], + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["secondary.type"]] + # )), + # input$primary + # ) + # ) + # + # columnSelectInput( + # inputId = ns("secondary"), + # data = data, + # selected = cols[1], + # placeholder = "Please select", + # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable", + # multiple = rv$plot.params()[["secondary.multi"]], + # maxItems = rv$plot.params()[["secondary.max"]], + # col_subset = cols, + # none_label = "No variable" + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # columnSelectInput( + # inputId = ns("tertiary"), + # data = data, + # placeholder = "Please select", + # label = "Grouping variable", + # multiple = FALSE, + # col_subset = c( + # "none", + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["tertiary.type"]] + # )), + # input$primary, + # input$secondary + # ) + # ), + # none_label = "No stratification" + # ) + # }) + # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE) + + output$primary <- shiny::renderUI({ shiny::req(data()) columnSelectInput( @@ -2299,12 +2375,13 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { # shiny::observeEvent(data, { # if (is.null(data()) | NROW(data()) == 0) { - # shiny::updateActionButton(inputId = "act_plot", disabled = TRUE) + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE) # } else { - # shiny::updateActionButton(inputId = "act_plot", disabled = FALSE) + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE) # } # }) + output$type <- shiny::renderUI({ shiny::req(input$primary) shiny::req(data()) @@ -2316,155 +2393,94 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data, source_list = available_plots()) + plots <- possible_plots(data = plot_data) - plots_named <- get_input_params(plots) |> + plots_named <- get_plot_options(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) - # plots_named <- get_plot_options(plots) |> - # lapply(\(.x) { - # stats::setNames(.x$descr, .x$note) - # }) - vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h5(i18n$t("Plot type")), + label = shiny::h4(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_input_params(input$type) |> purrr::pluck(1) - # get_plot_options(input$type) |> purrr::pluck(1) + get_plot_options(input$type) |> purrr::pluck(1) }) - - ### Include two additional variable inputs output$secondary <- shiny::renderUI({ shiny::req(input$type) - # Get the plot function name - base_params <- rv$plot.params()[["base"]] + cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + subset_types(data(), rv$plot.params()[["secondary.type"]]) + ), input$primary)) - filtered_params <- base_params[sapply(base_params, function(params) { - params$id %in% "secondary" - })][[1]] - - filtered_params$exclude <- input$primary - - create_input_element( - input_id = "secondary", - ns = ns, - params = append_list(data(), filtered_params, "data") + columnSelectInput( + inputId = ns("secondary"), + data = data, + selected = cols[1], + placeholder = i18n$t("Please select"), + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + i18n$t("Additional variables") + else + i18n$t("Secondary variable"), + multiple = rv$plot.params()[["secondary.multi"]], + maxItems = rv$plot.params()[["secondary.max"]], + col_subset = cols, + none_label = i18n$t("No variable") ) - }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - # Get the plot function name - base_params <- rv$plot.params()[["base"]] - - filtered_params <- base_params[sapply(base_params, function(params) { - params$id %in% "tertiary" - })][[1]] - - filtered_params$exclude <- c(input$primary, input$secondary) - - create_input_element( - input_id = "tertiary", - ns = ns, - params = append_list(data(), filtered_params, "data") + columnSelectInput( + inputId = ns("tertiary"), + data = data, + placeholder = i18n$t("Please select"), + label = i18n$t("Grouping variable"), + multiple = FALSE, + col_subset = c( + "none", + all_but( + colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])), + input$primary, + input$secondary + ) + ), + none_label = i18n$t("No stratification") ) }) - - ### Generating additional parameter inputs if any specified - output$basic_parameters <- renderUI({ - req(input$type, rv$plot.params) - - # Get the plot function name - base_params <- rv$plot.params()[["base"]] - - filtered_params <- base_params[sapply(base_params, function(params) { - !params$id %in% c("secondary", "tertiary") - })] - - - # Create UI elements for base parameters - base_inputs <- lapply(filtered_params, function(params) { - input_id <- paste0("base_", params$id) - params$id <- NULL - if (params$type %in% "select_variables") { - params$data <- data() - } - - create_input_element(params, ns, input_id) - }) - tagList(base_inputs) - - }) - ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes, - previews = 5 + choices = palettes ) }) shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { tryCatch({ - # Get all input values with prefixes - base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] - # advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] - - # Remove the prefix from names - names(base_inputs) <- gsub("^base_", "", names(base_inputs)) - # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) - - base_inputs <- c(base_inputs, - list(color.palette = input$color_palette)) - - # If any of the specified parameters are NULL/missing, the settings - # accordion/panel was never opened, and they can be ignored, as - # default settings will the be used. - if (any(sapply(base_inputs, is.null))) { - dynamic_params <- list() - } else { - dynamic_params <- base_inputs - } - - # Build parameters for plotting function parameters <- list( type = rv$plot.params()[["fun"]], pri = input$primary, sec = input$secondary, - ter = input$tertiary + ter = input$tertiary, + color.palette = input$color_palette ) - parameters <- modifyList(parameters, dynamic_params) - ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included if (!is.null(rv$plot.params()[["fun.args"]])) { - default_params <- rv$plot.params()[["fun.args"]] - - ## Ensure not to overwrite user defined parameters are overwritten - ## This allows to define default parameters. - ## - ## This will create a strange edge case, where the plot looks in - ## one way, when plotted initially, but may change, when the settings - ## accordion is opened. Problem for future me. Really mostly an edge case. - parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)]) + parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -2478,7 +2494,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } }, ignoreInit = TRUE) @@ -2500,25 +2516,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { if (!is.null(rv$plot)) { rv$plot } else { - # Create a placeholder plot with instructions using ggplot2 - ggplot2::ggplot() + - ggplot2::annotate( - "text", - x = 0.5, - y = 0.5, - label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), - size = 5, - color = "gray50", - lineheight = 0.8 - ) + - ggplot2::xlim(0, 1) + - ggplot2::ylim(0, 1) + - ggplot2::theme_void() + - ggplot2::theme( - panel.background = ggplot2::element_rect(fill = "white"), - plot.background = ggplot2::element_rect(fill = "white") - ) - # return(NULL) + return(NULL) } }) @@ -2563,6 +2561,482 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { ) } +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_bar_rel = list( + fun = "plot_bar", + fun.args = list(style = "fill"), + descr = i18n$t("Stacked relative barplot"), + note = i18n$t( + "Create relative stacked barplots to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_bar_abs = list( + fun = "plot_bar", + fun.args = list(style = "dodge"), + descr = i18n$t("Side-by-side barplot"), + note = i18n$t( + "Create side-by-side barplot to show the distribution of categorical levels" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_hbars = list( + fun = "plot_hbars", + descr = i18n$t("Stacked horizontal bars"), + note = i18n$t( + "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" + ), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = i18n$t("Violin plot"), + note = i18n$t( + "A modern alternative to the classic boxplot to visualise data distribution" + ), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = i18n$t("Sankey plot"), + note = i18n$t("A way of visualising change between groups"), + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = i18n$t("Scatter plot"), + note = i18n$t("A classic way of showing the association between to variables"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = i18n$t("Box plot"), + note = i18n$t("A classic way to plot data distribution by groups"), + primary.type = c("datatime", "continuous"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = i18n$t("Euler diagram"), + note = i18n$t( + "Generate area-proportional Euler diagrams to display set relationships" + ), + primary.type = c("dichotomous"), + secondary.type = c("dichotomous"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- supported_plots() |> + lapply(\(.x) { + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x) { + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x) { + .x[match(data, descrs)] + })() +} + + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, + type, + pri, + sec, + ter = NULL, + color.palette = "viridis", + ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + color.palette = color.palette, + ... + ) + + out <- do.call(type, modifyList(parameters, list(data = data))) + + code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") + + attr(out, "code") <- code + out +} + +#' Print label, and if missing print variable name for plots +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, + lineLength = 20, + force = FALSE) { + if (isTRUE(force)) { + ## This eats some letters when splitting a sentence... ?? + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), + "\\1\n", + data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' @param title panel title +#' @param guides passed to patchwork::wrap_plots() +#' @param axes passed to patchwork::wrap_plots() +#' @param axis_titles passed to patchwork::wrap_plots() +#' @param ... passed to patchwork::wrap_plots() +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, + tag_levels = NULL, + title = NULL, + axis.font.family = NULL, + guides = "collect", + axes = "collect", + axis_titles = "collect", + ...) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x) { + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i) { + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes() |> + patchwork::wrap_plots(guides = guides, + axes = axes, + axis_titles = axis_titles, + ...) + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + if (!is.null(title)) { + out <- out + + patchwork::plot_annotation( + title = title, + theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) + ) + } + } else { + out <- data[[1]] + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + + if (!is.null(axis.font.family)) { + if (inherits(x = out, what = "patchwork")) { + out <- out & + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } else { + out <- out + + ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) + } + } + + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(..., + x.axis = TRUE, + y.axis = TRUE) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + purrr::map(p, \(.x) { + out <- .x + if (isTRUE(x.axis)) { + out <- out + ggplot2::xlim(xr) + } + if (isTRUE(y.axis)) { + out <- out + ggplot2::ylim(yr) + } + out + }) + }) +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x) { + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} + ######## #### Current file: /Users/au301842/FreesearchR/R//data-summary.R @@ -2879,29 +3353,21 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - phosphoricons::ph("calculator") - # shiny::icon("calculator") + shiny::icon("calculator") } else if (identical(x, "factor")) { - phosphoricons::ph("chart-bar") - # shiny::icon("chart-simple") + shiny::icon("chart-simple") } else if (identical(x, "integer")) { - phosphoricons::ph("list-numbers") - # shiny::icon("arrow-down-1-9") + shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - phosphoricons::ph("text-aa") - # shiny::icon("arrow-down-a-z") + shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - phosphoricons::ph("toggle-left") - # shiny::icon("toggle-off") + shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - phosphoricons::ph("calendar") - # shiny::icon("calendar-days") + shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - phosphoricons::ph("clock") - # shiny::icon("clock") + shiny::icon("clock") } else { - phosphoricons::ph("calendar") - # shiny::icon("table") + shiny::icon("table") }} } @@ -2920,29 +3386,21 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - phosphoricons::ph("calculator") - # shiny::icon("calculator") + shiny::icon("calculator") } else if (identical(x, "categorical")) { - phosphoricons::ph("chart-bar") - # shiny::icon("chart-simple") + shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - phosphoricons::ph("list-numbers") - # shiny::icon("arrow-down-1-9") + shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - phosphoricons::ph("text-aa") - # shiny::icon("arrow-down-a-z") + shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - phosphoricons::ph("toggle-left") - # shiny::icon("toggle-off") + shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - phosphoricons::ph("calendar") - # shiny::icon("calendar-days") + shiny::icon("calendar-days") } else if (identical(x,"id")) { - phosphoricons::ph("identification-badge") - # shiny::icon("id-card") + shiny::icon("id-card") } else { - phosphoricons::ph("table") - # shiny::icon("table") + shiny::icon("table") } } } @@ -3428,25 +3886,32 @@ footer_ui <- function(i18n) { #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - - # --- Input validation ------------------------------------------------------- - if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { stop("`n` must be a single positive integer.") } - if (!is.function(palette) && (!is.character(palette) || length(palette) != 1)) { - stop("`palette` must be a single character string or a function.") - } - # --- Function passthrough --------------------------------------------------- + # Function passthrough — call directly with n and ... if (is.function(palette)) { return(palette(n, ...)) } - # --- Named palette dispatch ------------------------------------------------- + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string or a function.") + } + + if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { + stop("`n` must be a single positive integer.") + } + if (!is.character(palette) || length(palette) != 1) { + stop("`palette` must be a single character string.") + } + palette_lower <- tolower(palette) - viridis_palettes <- c("viridis", "magma", "plasma", "inferno", - "cividis", "mako", "rocket", "turbo") + viridis_palettes <- c( + "viridis", "magma", "plasma", "inferno", + "cividis", "mako", "rocket", "turbo" + ) if (palette_lower %in% viridis_palettes) { viridisLite::viridis(n = n, option = palette_lower, ...) @@ -3466,42 +3931,31 @@ generate_colors <- function(n, palette = "viridis", ...) { } else if (palette_lower == "topo") { grDevices::topo.colors(n = n, ...) + } else if (palette %in% rownames(RColorBrewer::brewer.pal.info)) { + max_n <- RColorBrewer::brewer.pal.info[palette, "maxcolors"] + fetch_n <- max(min(n, max_n), 3L) # clamp to [3, max_n] for brewer.pal() + base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = palette) + grDevices::colorRampPalette(base_colors)(n) + + } else if (palette %in% grDevices::palette.pals()) { + grDevices::colorRampPalette(palette.colors(palette = palette))(n) + + } else if (palette %in% grDevices::hcl.pals()) { + grDevices::hcl.colors(n = n, palette = palette, ...) + } else { - # Case-insensitive RColorBrewer lookup - brewer_names <- rownames(RColorBrewer::brewer.pal.info) - brewer_match <- brewer_names[match(palette_lower, tolower(brewer_names))] - - if (!is.na(brewer_match)) { - max_n <- RColorBrewer::brewer.pal.info[brewer_match, "maxcolors"] - fetch_n <- max(min(n, max_n), 3L) - base_colors <- RColorBrewer::brewer.pal(n = fetch_n, name = brewer_match) - grDevices::colorRampPalette(base_colors)(n) - - } else { - # Case-insensitive grDevices palette.pals() lookup - pal_names <- grDevices::palette.pals() - pal_match <- pal_names[match(palette_lower, tolower(pal_names))] - - if (!is.na(pal_match)) { - grDevices::colorRampPalette(grDevices::palette.colors(palette = pal_match))(n) - - } else if (palette %in% grDevices::hcl.pals()) { - # Named HCL palettes (e.g. "Rocket", "Plasma") — distinct from viridisLite - grDevices::hcl.colors(n = n, palette = palette, ...) - - } else { - warning( - "Unknown palette: '", palette, "'. Falling back to viridis.\n", - "Available options:\n", - " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", - " grDevices : hcl, rainbow, heat, terrain, topo\n", - " grDevices HCL: use grDevices::hcl.pals() to see all options\n", - " grDevices : use grDevices::palette.pals() to see all options\n", - " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" - ) - viridisLite::viridis(n = n, option = "viridis") - } - } + message(paste0( + "Unknown palette: '", palette, "'. ", + "Falling back to default R colors.\n", + "Available options:\n", + " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", + " grDevices : hcl, rainbow, heat, terrain, topo\n", + " grDevices HCL: use grDevices::hcl.pals() to see all options\n", + " grDevices : use grDevices::palette.pals() to see all options\n", + " RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" + )) + viridisLite::viridis(n = n, option = "viridis") + # grDevices::hcl.colors(n = n) } } @@ -3542,9 +3996,7 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) { ramp <- grDevices::colorRamp(colors) function(x) { - if (any(x < 0 | - x > 1, na.rm = TRUE)) - stop("Values must be in [0, 1].") + if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") rgb_vals <- ramp(x) grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) } @@ -3578,18 +4030,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) { #' #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] #' @export -scale_fill_generate <- function(palette = "viridis", - discrete = TRUE, - ...) { +scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { if (discrete) { ggplot2::discrete_scale( aesthetics = "fill", - palette = function(n) - generate_colors(n, palette), + palette = function(n) generate_colors(n, palette), ... ) } else { - ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...) + ggplot2::scale_fill_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) } } @@ -3599,38 +4051,22 @@ scale_fill_generate <- function(palette = "viridis", #' geom_point() + #' scale_color_generate(palette = "Set1") #' @export -scale_color_generate <- function(palette = "viridis", - discrete = TRUE, - ...) { +scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { if (discrete) { ggplot2::discrete_scale( aesthetics = "colour", - palette = function(n) - generate_colors(n, palette), + palette = function(n) generate_colors(n, palette), ... ) } else { - ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...) + ggplot2::scale_color_gradientn( + colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), + ... + ) } } -color_choices <- function() { - c( - "Perceptual (blue-yellow)" = "viridis", - "Perceptual (fire)" = "plasma", - "Colour-blind friendly" = "Okabe-Ito", - "Diverging (red-yellow-green)"= "RdYlGn", - "Diverging (red-blue)" = "RdBu", - "Sequential (blues)" = "Blues", - "Qualitative (paired)" = "Paired", - "Qualitative (bold)" = "Dark 2", - "Rainbow" = "Spectral", - "Generic" = "Set1" - ) -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## @@ -3867,8 +4303,8 @@ default_parsing <- function(data) { REDCapCAST::as_factor() |> REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> - REDCapCAST::as_logical() #|> - # REDCapCAST::fct_drop() + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() }) # out <- # @@ -4478,63 +4914,12 @@ data_types <- function() { ) } -non_character_cols <- function(df) { - if (shiny::is.reactive(df)) df <- df() - df[, !sapply(df, is.character), drop = FALSE] -} - -apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame()) { - # If this ever brakes, the solution will have to be to modify the original filter function - if (shiny::is.reactive(df_target)) df_target <- df_target() - - result <- if (shiny::is.reactive(filtered_reactive)) filtered_reactive() else filtered_reactive - filter_code <- attr(result, "code") - - if (is.null(filter_code)) return(df_target) - - deparsed <- paste(deparse(filter_code), collapse = "") - - if (is.symbol(filter_code) || !grepl("filter(", deparsed, fixed = TRUE)) { - return(df_target) - } - - extract_filters <- function(code) { - filters <- list() - while (!is.symbol(code) && deparse(code[[1]]) == "%>%") { - rhs <- code[[3]] - if (deparse(rhs[[1]]) == "filter") { - filters <- c(list(rhs), filters) - } - code <- code[[2]] - } - if (!is.symbol(code) && deparse(code[[1]]) == "filter") { - filters <- c(list(code), filters) - } - filters - } - - tryCatch({ - out <- df_target - for (f in extract_filters(filter_code)) { - args <- lapply(rlang::call_args(f), function(arg) { - rlang::new_quosure(arg, env = env) - }) - out <- dplyr::filter(out, !!!args) - } - out - }, - error = function(e) { - warning("Could not apply filter: ", conditionMessage(e)) - df_target - }) -} - ######## #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.6.1' +hosted_version <- function()'v26.3.4-260324' ######## @@ -5313,7 +5698,7 @@ import_file_server <- function(id, # showNotification(warn, type = "warning") # }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") }) }) @@ -5330,7 +5715,7 @@ import_file_server <- function(id, minBodyHeight = 250 ) }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") }) }) @@ -5445,7 +5830,7 @@ import_xls <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } @@ -5473,7 +5858,7 @@ import_ods <- function(file, sheet, skip, na.strings) { # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - ?showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") }) } @@ -5674,7 +6059,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("The data set has %s obs. in %s variables."), + i18n$t("Data has %s obs. of %s variables."), nrow(data), ncol(data) ), @@ -5685,7 +6070,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("The data set has %s obs. in %s variables."), + i18n$t("Data has %s obs. of %s variables."), nrow(data), ncol(data) ), @@ -5746,6 +6131,20 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", + # Introduction text + # div( + # class = "row mb-5", + # div( + # class = "col-12 text-center", + # p( + # class = "lead", + # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), + # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), + # style = "font-size: 1.2rem; color: #555;" + # ) + # ) + # ), + # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -5763,8 +6162,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("folder-simple-plus", weight = "bold") - # fa("file-import") + fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -5785,8 +6183,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("note-pencil", weight = "bold") - # fa("pen-to-square") + fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -5807,8 +6204,7 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - phosphoricons::ph("magnifying-glass", weight = "bold") - # fa("magnifying-glass-chart") + fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -5833,7 +6229,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -5845,7 +6241,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -5862,7 +6258,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( @@ -6152,8 +6548,7 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = phosphoricons::ph("gear"), - # icon = bsicons::bs_icon("gear"), + icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -6170,16 +6565,14 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator",weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = phosphoricons::ph("download-simple") - # icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -6308,7 +6701,7 @@ data_missings_server <- function(id, data, max_level = 20, ...) { out <- do.call(compare_missings, modifyList(parameters, list(data = df_tbl))) }) }, error = function(err) { - showNotification(paste0("Error: ", err), type = "error") + showNotification(paste0("Error: ", err), type = "err") }) if (is.null(input$missings_var) || @@ -6507,32 +6900,8 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -#' Title -#' -#' @name data-plots -#' -#' @param style barplot style passed to geom_bar position argument. -#' One of c("stack", "dodge", "fill") -#' -#' @returns ggplot list object -#' @export -#' -#' @examples -#' mtcars |> -#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> -#' plot_bar(pri = "cyl", sec = "am", style = "fill") -#' -#' mtcars |> -#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> -#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") -plot_bar <- function(data, - pri, - sec = NULL, - ter = NULL, - style = c("stack", "dodge", "fill"), - color.palette = "viridis", - max_level = 30, - ...) { +plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), + color.palette = "viridis", max_level = 30, ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6541,21 +6910,18 @@ plot_bar <- function(data, ds <- list(data) } - out <- lapply(ds, \(.ds) { + out <- lapply(ds, \(.ds){ plot_bar_single( data = .ds, pri = pri, sec = sec, style = style, max_level = max_level, - color.palette = color.palette, - ... + color.palette = color.palette ) }) - wrap_plot_list(out, - title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE) + wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), ...) } @@ -6577,11 +6943,7 @@ plot_bar <- function(data, #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, - pri, - sec = NULL, - style = c("stack", "dodge", "fill"), - max_level = 30, +plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -6591,12 +6953,35 @@ plot_bar_single <- function(data, p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data)) + p = Freq / NROW(data) + ) if (nrow(p_data) > max_level) { - p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> + # browser() + p_data <- sort_by( + p_data, + p_data[["Freq"]], + decreasing = TRUE + ) |> head(max_level) + # if (is.null(sec)){ + # p_data <- sort_by( + # p_data, + # p_data[["Freq"]], + # decreasing=TRUE) |> + # head(max_level) + # } else { + # split(p_data,p_data[[sec]]) |> + # lapply(\(.x){ + # # browser() + # sort_by( + # .x, + # .x[["Freq"]], + # decreasing=TRUE) |> + # head(max_level) + # }) |> dplyr::bind_rows() + # } } ## Shortens long level names @@ -6608,33 +6993,41 @@ plot_bar_single <- function(data, fill <- pri } - p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + + p <- ggplot2::ggplot( + p_data, + ggplot2::aes( + x = .data[[pri]], + y = p, + fill = .data[[fill]] + ) + ) + ggplot2::geom_bar(position = style, stat = "identity") + - scale_fill_generate(palette = color.palette) + - ggplot2::xlab(get_label(data, pri)) + - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) + ggplot2::scale_y_continuous(labels = scales::percent) + + scale_fill_generate(palette=color.palette) + + ggplot2::ylab("Percentage") + + ggplot2::xlab(get_label(data,pri))+ + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | - any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme(axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, - hjust = 1 - )) + - ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) + ggplot2::theme( + axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, hjust = 1 + ))+ + ggplot2::theme( + axis.text.x = ggplot2::element_text(vjust = 0.5) + ) - if (is.null(sec)) { + if (is.null(sec)){ p <- p + ggplot2::guides(fill = "none") } } - p + - ggplot2::scale_y_continuous(labels = scales::percent) + - ggplot2::ylab("Percentage") + p } @@ -6676,11 +7069,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette, ... + color.palette=color.palette ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) } @@ -6874,7 +7267,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis", ...) { +plot_euler_single <- function(data,color.palette="viridis") { data |> ggeulerr(shape = "circle") + @@ -6912,20 +7305,18 @@ plot_euler_single <- function(data,color.palette="viridis", ...) { #' mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") #' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") -#' mtcars |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis", - ...) { + color.palette = "viridis") { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette, - ... + color.palette = color.palette ) } @@ -6945,7 +7336,7 @@ vertical_stacked_bars <- function(data, score = "full_score", group = "pase_0_q", strata = NULL, - t.size = 8, + t.size = 10, l.color = "black", l.size = .5, draw.lines = TRUE, @@ -6978,15 +7369,15 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse) | reverse=="TRUE") { + if (isTRUE(reverse)) { colors <- rev(colors) } + contrast_cut <- + contrast_text(colors, threshold = .3) == "white" score_label <- data |> get_label(var = score) group_label <- data |> get_label(var = group) - # browser() - p |> (\(.x) { .x$plot + @@ -6998,7 +7389,7 @@ vertical_stacked_bars <- function(data, ggplot2::aes( x = group, y = p_prev + 0.49 * p, - color = contrast_text(colors[as.numeric(score)], threshold = .3), + color = contrast_cut, # label = paste0(sprintf("%2.0f", 100 * p),"%"), # label = sprintf("%2.0f", 100 * p) label = glue::glue(label.str) @@ -7007,76 +7398,14 @@ vertical_stacked_bars <- function(data, ggplot2::labs(fill = score_label) + ggplot2::scale_fill_manual(values = colors) + ggplot2::theme(legend.position = "bottom", - axis.title = ggplot2::element_text(),) + + axis.title = ggplot2::element_text(), + ) + ggplot2::xlab(group_label) + ggplot2::ylab(NULL) })() } -######## -#### Current file: /Users/au301842/FreesearchR/R//plot_likert.R -######## - -#' Nice horizontal bar plot centred on the central category -#' -#' @returns ggplot2 object -#' @export -#' -#' @name data-plots -#' -#' @examples -#' mtcars |> plot_likert(pri = "carb", sec = "cyl") -#' mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") -#' mtcars |> plot_likert(pri = "cyl",color.palette="Blues") -#' mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") -#' mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") -plot_likert <- function(data, - pri, - sec = NULL, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(ter)) { - ds <- split(data, data[ter]) - } else { - ds <- list(data) - } - out <- lapply(ds, \(.x) { - plot_likert_single( - data = .x, - include = tidyselect::any_of(c(pri, sec)), - color.palette = color.palette - ) - }) - - wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) -} - - -plot_likert_single <- function(data, - include = dplyr::everything(), - color.palette = "viridis") { - data |> - dplyr::as_tibble() |> - ggstats::gglikert(include = include) + - scale_fill_generate(palette = color.palette) + - ggplot2::theme( - # legend.position = "none", - # panel.grid.major = element_blank(), - # panel.grid.minor = element_blank(), - # axis.text.y = ggplot2::element_blank(), - # axis.title.y = ggplot2::element_blank(), - text = ggplot2::element_text(size = 12) - # axis.text = ggplot2::element_blank(), - # plot.title = element_blank(), - # panel.background = ggplot2::element_rect(fill = "white"), - # plot.background = ggplot2::element_rect(fill = "white"), - # panel.border = ggplot2::element_blank() - ) -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//plot_ridge.R ######## @@ -7213,8 +7542,7 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing", - ...) { + missing.level = "Missing") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7448,7 +7776,7 @@ color_levels_gen <- function(data,na.color="grey80",palette="viridis"){ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (is.null(ter)) { rempsyc::nice_scatter( data = data, @@ -7485,7 +7813,7 @@ plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", .. #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7500,8 +7828,7 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ... group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri), - ... + ytitle = get_label(data, var = pri) )+ scale_fill_generate(palette=color.palette) }) @@ -7557,8 +7884,7 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) } @@ -7647,890 +7973,6 @@ plot_download_demo_app <- function() { # plot_download_demo_app() -######## -#### Current file: /Users/au301842/FreesearchR/R//plot-helpers.R -######## - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - fun: the plotting function -#' -#' - fun.args: default parameters for the plotting function -#' -#' - descr: Plot description -#' -#' - note: Short note/description of the function for displaying in ui and docs -#' -#' - primary.type: Primary variable data type (see [data_type]) -#' -#' - base: holds a list of parameters for plot input fields generation -#' Secondary and tertiary variable input fields are mandatory. -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' available_plots() |> str() -available_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Additional variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ), - list( - id = "reverse", - type = "select_input", - label = i18n$t("Reverse colors"), - choices = c(yes = TRUE, no = FALSE) - ) - ), - advanced = list() - ######### - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("datatime", "continuous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = FALSE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Secondary variable"), - multiple = TRUE, - maxItems = 4 - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ), - plot_likert = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t("Plot survey results"), - primary.type = c("dichotomous", "categorical"), - ### Input definitions ### - base = list( - list( - id = "secondary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = TRUE - ), - list( - id = "tertiary", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = FALSE - ) - ), - advanced = list() - ######### - ) - ) -} - -# Helper function to create input elements dynamically -create_input_element <- function(params, ns, input_id) { - # Add the namespaced inputId to the arguments - params$inputId <- ns(input_id) - - # Map input types to Shiny functions - input_function <- switch( - params$type, - "numeric_input" = shiny::numericInput, - "select_input" = shiny::selectInput, - "checkbox_input" = shiny::checkboxInput, - "slider_input" = shiny::sliderInput, - "text_input" = shiny::textInput, - "select_variables" = selectPlotVariables - ) - - params$type <- NULL - params$id <- NULL - - - # Call the function with all arguments - do.call(input_function, params) -} - -#' Wrapper for columnSelectInput -#' -selectPlotVariables <- function(data, - exclude = NULL, - allow_none = TRUE, - var_types, - ...) { - datar <- if (is.reactive(data)) { - data - } else { - reactive(data) - } - - cols <- all_but(colnames(subset_types(datar(), var_types)), exclude) - - if (isTRUE(allow_none)) { - cols <- c("none", cols) - } - - params <- list(...) - - params$none_label <- i18n$t("No variable") - params$col_subset <- cols - - rlang::exec(columnSelectInput, !!!append_list(datar(), params, "data")) -} - - - -#' Select all from vector but -#' -#' @param data vector -#' @param ... exclude -#' -#' @returns vector -#' @export -#' -#' @examples -#' all_but(1:10, c(2, 3), 11, 5) -all_but <- function(data, ...) { - data[!data %in% c(...)] -} - -#' Easily subset by data type function -#' -#' @param data data -#' @param types desired types -#' @param type.fun function to get type. Default is outcome_type -#' -#' @returns vector -#' @export -#' -#' @examples -#' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) -#' #' default_parsing(mtcars) |> subset_types("factor",class) -subset_types <- function(data, types, type.fun = data_type) { - data[sapply(data, type.fun) %in% types] -} - - -#' Implemented functions -#' -#' @description -#' Library of supported functions. The list name and "descr" element should be -#' unique for each element on list. -#' -#' - descr: Plot description -#' -#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) -#' -#' - secondary.extra: "none" or NULL to have option to choose none. -#' -#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) -#' -#' -#' @returns list -#' @export -#' -#' @examples -#' supported_plots() |> str() -supported_plots <- function() { - list( - plot_bar_rel = list( - fun = "plot_bar", - fun.args = list(style = "fill"), - descr = i18n$t("Stacked relative barplot"), - note = i18n$t( - "Create relative stacked barplots to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_bar_abs = list( - fun = "plot_bar", - fun.args = list(style = "dodge"), - descr = i18n$t("Side-by-side barplot"), - note = i18n$t( - "Create side-by-side barplot to show the distribution of categorical levels" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_hbars = list( - fun = "plot_hbars", - descr = i18n$t("Stacked horizontal bars"), - note = i18n$t( - "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars" - ), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_violin = list( - fun = "plot_violin", - descr = i18n$t("Violin plot"), - note = i18n$t( - "A modern alternative to the classic boxplot to visualise data distribution" - ), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = "none", - tertiary.type = c("dichotomous", "categorical") - ), - # plot_ridge = list( - # descr = "Ridge plot", - # note = "An alternative option to visualise data distribution", - # primary.type = "continuous", - # secondary.type = c("dichotomous" ,"categorical"), - # tertiary.type = c("dichotomous" ,"categorical"), - # secondary.extra = NULL - # ), - plot_sankey = list( - fun = "plot_sankey", - descr = i18n$t("Sankey plot"), - note = i18n$t("A way of visualising change between groups"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical") - ), - plot_scatter = list( - fun = "plot_scatter", - descr = i18n$t("Scatter plot"), - note = i18n$t("A classic way of showing the association between to variables"), - primary.type = c("datatime", "continuous"), - secondary.type = c("datatime", "continuous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ), - plot_box = list( - fun = "plot_box", - descr = i18n$t("Box plot"), - note = i18n$t("A classic way to plot data distribution by groups"), - primary.type = c("datatime", "continuous"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = FALSE, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = "none" - ), - plot_euler = list( - fun = "plot_euler", - descr = i18n$t("Euler diagram"), - note = i18n$t( - "Generate area-proportional Euler diagrams to display set relationships" - ), - primary.type = c("dichotomous"), - secondary.type = c("dichotomous"), - secondary.multi = TRUE, - secondary.max = 4, - tertiary.type = c("dichotomous"), - secondary.extra = NULL - ), - plot_likert = list( - fun = "plot_likert", - descr = i18n$t("Likert diagram"), - note = i18n$t("Plot survey results"), - primary.type = c("dichotomous", "categorical"), - secondary.type = c("dichotomous", "categorical"), - secondary.multi = TRUE, - secondary.extra = NULL, - tertiary.type = c("dichotomous", "categorical"), - secondary.extra = NULL - ) - ) -} - -#' Get possible regression models -#' -#' @param data data -#' -#' @returns character vector -#' @export -#' -#' @examples -#' mtcars |> -#' default_parsing() |> -#' dplyr::pull("cyl") |> -#' possible_plots() -#' -#' mtcars |> -#' default_parsing() |> -#' dplyr::select("mpg") |> -#' possible_plots() -possible_plots <- function(data, source_list = supported_plots()) { - # browser() - # data <- if (is.reactive(data)) data() else data - if (is.data.frame(data)) { - data <- data[[1]] - } - - type <- data_type(data) - - if (type == "unknown") { - out <- type - } else { - out <- source_list |> - lapply(\(.x) { - if (type %in% .x$primary.type) { - .x$descr - } - }) |> - unlist() - } - unname(out) -} - -#' Get the function options based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_plot_options() -get_plot_options <- function(data) { - descrs <- supported_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - supported_plots() |> - (\(.x) { - .x[match(data, descrs)] - })() -} - -#' Get the function parameters based on the selected function description -#' -#' @param data vector -#' -#' @returns list -#' @export -#' -#' @examples -#' ls <- mtcars |> -#' default_parsing() |> -#' dplyr::pull(mpg) |> -#' possible_plots() |> -#' (\(.x){ -#' .x[[1]] -#' })() |> -#' get_input_params() -get_input_params <- function(data) { - descr <- available_plots() |> - lapply(\(.x) { - .x$descr - }) |> - unlist() - available_plots() |> - (\(.x) { - .x[match(data, descr)] - })() -} - - -#' Wrapper to create plot based on provided type -#' -#' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable -#' @param type plot type (derived from possible_plots() and matches custom function) -#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support. -#' @param ... ignored for now -#' -#' @name data-plots -#' -#' @returns ggplot2 object -#' @export -#' -#' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -create_plot <- function(data, - type, - pri, - sec, - ter = NULL, - color.palette = "viridis", - ...) { - if (!is.null(sec)) { - if (!any(sec %in% names(data))) { - sec <- NULL - } - } - - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } - } - - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - color.palette = color.palette, - ... - ) - - out <- do.call(type, modifyList(parameters, list(data = data))) - - code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR") - - attr(out, "code") <- code - out -} - -#' Print label, and if missing print variable name for plots -#' -#' @param data vector or data frame -#' @param var variable name. Optional. -#' -#' @returns character string -#' @export -#' -#' @examples -#' mtcars |> get_label(var = "mpg") -#' mtcars |> get_label() -#' mtcars$mpg |> get_label() -#' gtsummary::trial |> get_label(var = "trt") -#' gtsummary::trial$trt |> get_label() -#' 1:10 |> get_label() -get_label <- function(data, var = NULL) { - # data <- if (is.reactive(data)) data() else data - if (!is.null(var) & is.data.frame(data)) { - data <- data[[var]] - } - out <- REDCapCAST::get_attr(data = data, attr = "label") - if (is.na(out)) { - if (is.null(var)) { - out <- deparse(substitute(data)) - } else { - if (is.symbol(var)) { - out <- gsub('\"', "", deparse(substitute(var))) - } else { - out <- var - } - } - } - out -} - - -#' Line breaking at given number of characters for nicely plotting labels -#' -#' @param data string -#' @param lineLength maximum line length -#' @param fixed flag to force split at exactly the value given in lineLength. -#' Default is FALSE, only splitting at spaces. -#' -#' @returns character string -#' @export -#' -#' @examples -#' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) -line_break <- function(data, - lineLength = 20, - force = FALSE) { - if (isTRUE(force)) { - ## This eats some letters when splitting a sentence... ?? - gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), - "\\1\n", - data) - } else { - paste(strwrap(data, lineLength), collapse = "\n") - } - ## https://stackoverflow.com/a/29847221 -} - - -#' Wrapping -#' -#' @param data list of ggplot2 objects -#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL -#' @param title panel title -#' @param guides passed to patchwork::wrap_plots() -#' @param axes passed to patchwork::wrap_plots() -#' @param axis_titles passed to patchwork::wrap_plots() -#' @param ... passed to patchwork::wrap_plots() -#' -#' @returns list of ggplot2 objects -#' @export -#' -wrap_plot_list <- function(data, - tag_levels = NULL, - title = NULL, - axis.font.family = NULL, - guides = "collect", - axes = "collect", - axis_titles = "collect", - y.axis.percentage = FALSE, - ...) { - if (ggplot2::is_ggplot(data[[1]])) { - if (length(data) > 1) { - out <- data |> - (\(.x) { - if (rlang::is_named(.x)) { - purrr::imap(.x, \(.y, .i) { - .y + ggplot2::ggtitle(.i) - }) - } else { - .x - } - })() |> - align_axes(percentage = y.axis.percentage) |> - patchwork::wrap_plots(guides = guides, - axes = axes, - axis_titles = axis_titles, - ...) - if (!is.null(tag_levels)) { - out <- out + patchwork::plot_annotation(tag_levels = tag_levels) - } - if (!is.null(title)) { - out <- out + - patchwork::plot_annotation( - title = title, - theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25)) - ) - } - } else { - out <- data[[1]] - } - } else { - cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") - } - - if (!is.null(axis.font.family)) { - if (inherits(x = out, what = "patchwork")) { - out <- out & - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } else { - out <- out + - ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family)) - } - } - - out -} - - -#' Aligns axes between plots -#' -#' @param ... ggplot2 objects or list of ggplot2 objects -#' -#' @returns list of ggplot2 objects -#' @export -#' -align_axes <- function(..., - x.axis = TRUE, - y.axis = TRUE, - percentage = FALSE) { - # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object - # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 - if (ggplot2::is_ggplot(..1)) { - ## Assumes list of ggplots - p <- list(...) - } else if (is.list(..1)) { - ## Assumes list with list of ggplots - p <- ..1 - } else { - cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") - } - - yr <- clean_common_axis(p, "y") - - xr <- clean_common_axis(p, "x") - - suppressWarnings({ - p_out <- purrr::map(p, \(.x) { - out <- .x - if (isTRUE(x.axis)) { - out <- out + ggplot2::xlim(xr) - } - if (isTRUE(y.axis)) { - out <- out + ggplot2::ylim(yr) - } - out - }) - }) - - if (isTRUE(percentage)) { - lapply(p_out, \(.x) { - .x + - ggplot2::scale_y_continuous(labels = scales::percent) - }) - } else { - p_out - } -} - -#' Extract and clean axis ranges -#' -#' @param p plot -#' @param axis axis. x or y. -#' -#' @returns vector -#' @export -#' -clean_common_axis <- function(p, axis) { - purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> - unlist() |> - (\(.x) { - if (is.numeric(.x)) { - range(.x) - } else { - as.character(.x) - } - })() |> - unique() -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//redcap_read_shiny_module.R ######## @@ -8548,7 +7990,10 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { ns <- shiny::NS(id) if (isTRUE(title)) { - title <- shiny::tags$h4(i18n$t("Import data from REDCap"), class = "redcap-module-title") + title <- shiny::tags$h4( + i18n$t("Import data from REDCap"), + class = "redcap-module-title" + ) } server_ui <- shiny::tagList( @@ -8559,11 +8004,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = if_not_missing(url, "https://redcap.your.institution/"), width = "100%" ), - shiny::helpText( - i18n$t( - "Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'" - ) - ), + shiny::helpText(i18n$t("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'")), shiny::br(), shiny::br(), shiny::passwordInput( @@ -8572,16 +8013,13 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { value = "", width = "100%" ), - shiny::helpText(i18n$t( - "The token is a string of 32 numbers and letters." - )), + shiny::helpText(i18n$t("The token is a string of 32 numbers and letters.")), shiny::br(), shiny::br(), shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = phosphoricons::ph("link",weight = "bold"), - # icon = shiny::icon("link", lib = "glyphicon"), + icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8592,10 +8030,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("connect-result"), status = "info", - tags$p( - phosphoricons::ph("info", weight = "bold"), - i18n$t("Please fill in web address and API token, then press 'Connect'.") - ) + tags$p(phosphoricons::ph("info", weight = "bold"), i18n$t("Please fill in web address and API token, then press 'Connect'.")) ), dismissible = TRUE ), @@ -8608,18 +8043,14 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::uiOutput(outputId = ns("arms")), shiny::textInput( inputId = ns("filter"), - label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')") - ), - uiOutput(ns("filter_feedback")) + label = i18n$t("Optional filter logic (e.g., ⁠[gender] = 'female')" + )) ) params_ui <- shiny::tagList( shiny::tags$h4(i18n$t("Data import parameters")), shiny::tags$div( - #### - #### All below was deactivated to deactivate filtering - #### style = htmltools::css( display = "grid", gridTemplateColumns = "1fr 50px", @@ -8637,19 +8068,14 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = phosphoricons::ph("funnel",weight = "bold"), - # label = shiny::icon("filter"), + label = shiny::icon("filter"), width = "50px" ), filter_ui ) ) ), - shiny::helpText( - i18n$t( - "Select fields/variables to import and click the funnel to apply optional filters" - ) - ), + shiny::helpText(i18n$t("Select fields/variables to import and click the funnel to apply optional filters")), shiny::tags$br(), shiny::tags$br(), shiny::uiOutput(outputId = ns("data_type")), @@ -8657,8 +8083,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = phosphoricons::ph("download-simple",weight = "bold"), - # icon = shiny::icon("download", lib = "glyphicon"), + icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8669,10 +8094,7 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::alert( id = ns("retrieved-result"), status = "info", - tags$p( - phosphoricons::ph("info", weight = "bold"), - "Please specify data to download, then press 'Import'." - ) + tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") ), dismissible = TRUE ) @@ -8683,7 +8105,11 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { title = title, server_ui, # shiny::uiOutput(ns("params_ui")), - shiny::conditionalPanel(condition = "output.connect_success == true", params_ui, ns = ns), + shiny::conditionalPanel( + condition = "output.connect_success == true", + params_ui, + ns = ns + ), shiny::br() ) } @@ -8708,19 +8134,14 @@ m_redcap_readServer <- function(id) { dd_list = NULL, data = NULL, rep_fields = NULL, - code = NULL, - filter_valid = NULL + code = NULL ) shiny::observeEvent(list(input$api, input$uri), { shiny::req(input$api) shiny::req(input$uri) if (!is.null(input$uri)) { - uri <- paste0(ifelse( - endsWith(input$uri, "/"), - input$uri, - paste0(input$uri, "/") - ), "api/") + uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") } else { uri <- input$uri } @@ -8734,68 +8155,75 @@ m_redcap_readServer <- function(id) { }) - tryCatch({ - shiny::observeEvent(list(input$data_connect), { - shiny::req(input$api) - shiny::req(data_rv$uri) + tryCatch( + { + shiny::observeEvent( + list( + input$data_connect + ), + { + shiny::req(input$api) + shiny::req(data_rv$uri) - parameters <- list(redcap_uri = data_rv$uri, token = input$api) - - # browser() - shiny::withProgress({ - imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), - silent = TRUE) - }, message = paste("Connecting to", data_rv$uri)) - - ## TODO: Simplify error messages - if (inherits(imported, "try-error") || - NROW(imported) < 1 || - ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { - if (ifelse(is.list(imported), - !isTRUE(imported$success), - FALSE)) { - mssg <- imported$raw_text - } else { - mssg <- attr(imported, "condition")$message - } - - datamods:::insert_error(mssg = mssg, selector = "connect") - data_rv$dd_status <- "error" - data_rv$dd_list <- NULL - } else if (isTRUE(imported$success)) { - data_rv$dd_status <- "success" - - data_rv$info <- REDCapR::redcap_project_info_read(redcap_uri = data_rv$uri, token = input$api)$data - - datamods:::insert_alert( - selector = ns("connect"), - status = "success", - include_data_alert( - see_data_text = i18n$t("Click to see data dictionary"), - dataIdName = "see_dd", - extra = tags$p( - tags$b( - phosphoricons::ph("check", weight = "bold"), - i18n$t("Connected to server!") - ), - glue::glue( - i18n$t( - "The {data_rv$info$project_title} project is loaded." - ) - ) - ), - btn_show_data = TRUE + parameters <- list( + redcap_uri = data_rv$uri, + token = input$api ) - ) - data_rv$dd_list <- imported - } - }, ignoreInit = TRUE) - }, warning = function(warn) { - showNotification(paste0(warn), type = "warning") - }, error = function(err) { - showNotification(paste0(err), type = "error") - }) + # browser() + shiny::withProgress( + { + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) + }, + message = paste("Connecting to", data_rv$uri) + ) + + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } + + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" + + data_rv$info <- REDCapR::redcap_project_info_read( + redcap_uri = data_rv$uri, + token = input$api + )$data + + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = i18n$t("Click to see data dictionary"), + dataIdName = "see_dd", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), i18n$t("Connected to server!")), + glue::glue(i18n$t("The {data_rv$info$project_title} project is loaded.")) + ), + btn_show_data = TRUE + ) + ) + + data_rv$dd_list <- imported + } + }, + ignoreInit = TRUE + ) + }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) @@ -8826,7 +8254,10 @@ m_redcap_readServer <- function(id) { shiny::req(input$api) shiny::req(data_rv$uri) - REDCapR::redcap_event_read(redcap_uri = data_rv$uri, token = input$api)$data + REDCapR::redcap_event_read( + redcap_uri = data_rv$uri, + token = input$api + )$data }) output$fields <- shiny::renderUI({ @@ -8836,7 +8267,7 @@ m_redcap_readServer <- function(id) { label = i18n$t("Select fields/variables to import:"), choices = purrr::pluck(data_rv$dd_list, "data") |> dplyr::select(field_name, form_name) |> - (\(.x) { + (\(.x){ split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) })(), updateOn = "change", @@ -8869,10 +8300,14 @@ m_redcap_readServer <- function(id) { shiny::req(input$data_type) ## Get repeated field - data_rv$rep_fields <- data_rv$dd_list$data$field_name[data_rv$dd_list$data$form_name %in% repeated_instruments(uri = data_rv$uri, token = input$api)] + data_rv$rep_fields <- data_rv$dd_list$data$field_name[ + data_rv$dd_list$data$form_name %in% repeated_instruments( + uri = data_rv$uri, + token = input$api + ) + ] - if (input$data_type == "long" && - isTRUE(any(input$fields %in% data_rv$rep_fields))) { + if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { vectorSelectInput( inputId = ns("fill"), label = i18n$t("Fill missing values?"), @@ -8908,48 +8343,12 @@ m_redcap_readServer <- function(id) { } }) - - filter_validation <- reactive({ - val <- trimws(input$filter) - if (nchar(val) == 0) - return(NULL) - validate_redcap_filter(val, purrr::pluck(data_rv$dd_list, "data")) - }) - - output$filter_feedback <- renderUI({ - result <- filter_validation() - if (is.null(result)) { - data_rv$filter_valid <- NULL - return(NULL) - } - - if (result$valid) { - data_rv$filter_valid <- TRUE - tags$span(style = "color: green;", "\u2713 Filter is valid") - } else { - data_rv$filter_valid <- FALSE - - tags$span(style = "color: red;", - "\u2717 ", - line_break(result$message, lineLength = 30)) - } - }) - shiny::observeEvent(input$data_import, { shiny::req(input$fields) # browser() record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] - if (!is.null(data_rv$filter_valid)) { - if (isTRUE(data_rv$filter_valid)) { - filter <- trimws(input$filter) - } else { - filter <- "" - } - } else { - filter <- "" - } parameters <- list( uri = data_rv$uri, @@ -8957,8 +8356,7 @@ m_redcap_readServer <- function(id) { fields = unique(c(record_id, input$fields)), events = input$arms, raw_or_label = "both", - filter_logic = filter, - # filter_logic = "", + filter_logic = input$filter, split_forms = ifelse( input$data_type == "long" && !is.null(input$data_type), "none", @@ -8967,48 +8365,31 @@ m_redcap_readServer <- function(id) { ) shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { - imported <- try({ - rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters) - # if (nrow(out)==0){ - # stop("No data was exported") - # } else { - # out - # } - }, # error = function(err) { - # showNotification(i18n$t("An error was encountered exporting data. Please review data filter."), type = "error") - # }, - silent = TRUE) + imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) }) - # d <- REDCapCAST::apply_factor_labels(data = imported$survey, meta = data_rv$dd_list$data) + parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] - parameters_code <- parameters[c("uri", - "fields", - "events", - "raw_or_label", - "filter_logic")] + code <- rlang::call2( + "easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST" + ) - code <- rlang::call2("easy_redcap", - !!!utils::modifyList( - parameters_code, - list( - data_format = ifelse( - input$data_type == "long" && !is.null(input$data_type), - "long", - "wide" - ), - project.name = simple_snake(data_rv$info$project_title) - ) - ), - .ns = "REDCapCAST") - - if (inherits(imported, "try-error") | - NROW(imported) == 0 | - (length(imported) == 1 & !is.list(imported))) { + if (inherits(imported, "try-error") || NROW(imported) < 1) { data_rv$data_status <- "error" data_rv$data_list <- NULL - data_rv$data_message <- i18n$t("An empty data set was imported. Please review data filter.") - data_rv$data <- NULL + data_rv$data_message <- imported$raw_text } else { data_rv$data_status <- "success" data_rv$data_message <- i18n$t("Requested data was retrieved!") @@ -9017,11 +8398,12 @@ m_redcap_readServer <- function(id) { ## "wide"/"long" without re-importing data if (parameters$split_form == "all") { + # browser() out <- imported |> # redcap_wider() REDCapCAST::redcap_wider() } else { - if (identical(input$fill, "yes")) { + if (input$fill == "yes") { ## Repeated fields @@ -9039,102 +8421,78 @@ m_redcap_readServer <- function(id) { } } - ## Ensure correct factor labels - ## It is a little hacky and should be included in the read_redcap_tables, but is lost along the way - out <- REDCapCAST::apply_factor_labels(data = out, meta = data_rv$dd_list$data) - - + # browser() in_data_check <- parameters$fields %in% names(out) | - sapply(names(out), \(.x) any(sapply( - parameters$fields, \(.y) startsWith(.x, .y) - ))) + sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) if (!any(in_data_check[-1])) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t( - "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." - ) + data_rv$data_message <- i18n$t("Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") } if (!all(in_data_check)) { data_rv$data_status <- "warning" - data_rv$data_message <- i18n$t( - "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." - ) + data_rv$data_message <- i18n$t("Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.") } data_rv$code <- code - ## Level labels nare lost at this point... data_rv$data <- out |> dplyr::select(-dplyr::ends_with("_complete")) |> # dplyr::select(-dplyr::any_of(record_id)) |> REDCapCAST::suffix2label() - } }) - shiny::observeEvent(data_rv$data_status, { - if (identical(data_rv$data_status, "error")) { - ## The insert error wouldn't work. Inserted through regular. - # datamods:::insert_error(mssg = data_rv$data_message, - # selector = ns("retrieved")) - datamods:::insert_alert( - selector = ns("retrieved"), - status = "danger", - tags$p( - tags$b( - phosphoricons::ph("warning", weight = "bold"), - "Warning!" - ), - data_rv$data_message + shiny::observeEvent( + data_rv$data_status, + { + # browser() + if (identical(data_rv$data_status, "error")) { + datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = i18n$t("Click to see the imported data"), + dataIdName = "see_data", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) + ), + btn_show_data = TRUE + ) ) - ) - } else if (identical(data_rv$data_status, "success")) { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - # tags$p( - # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), - # data_rv$data_message - # ), - include_data_alert( - see_data_text = i18n$t("Click to see the imported data"), - dataIdName = "see_data", - extra = tags$p(tags$b( - phosphoricons::ph("check", weight = "bold"), + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), data_rv$data_message - )), - btn_show_data = TRUE + ) ) - ) - } else { - datamods:::insert_alert( - selector = ns("retrieved"), - status = data_rv$data_status, - tags$p( - tags$b( - phosphoricons::ph("warning", weight = "bold"), - "Warning!" - ), - data_rv$data_message - ) - ) + } } - }) - - return( - list( - status = shiny::reactive(data_rv$data_status), - name = shiny::reactive(data_rv$info$project_title), - info = shiny::reactive(data_rv$info), - code = shiny::reactive(data_rv$code), - data = shiny::reactive(data_rv$data) - ) ) + + return(list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + )) } - shiny::moduleServer(id = id, module = module) + shiny::moduleServer( + id = id, + module = module + ) } #' @importFrom htmltools tagList tags @@ -9145,12 +8503,14 @@ include_data_alert <- function(dataIdName = "see_data", extra = NULL, session = shiny::getDefaultReactiveDomain()) { if (isTRUE(btn_show_data)) { - success_message <- tagList(extra, - tags$br(), - shiny::actionLink( - inputId = session$ns(dataIdName), - label = tagList(phosphoricons::ph("book-open-text"), see_data_text) - )) + success_message <- tagList( + extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + ) + ) } return(success_message) } @@ -9202,18 +8562,20 @@ is_valid_redcap_url <- function(url) { #' @examples #' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") #' is_valid_token(token) -is_valid_token <- function(token, - pattern_env = NULL, - nchar = 32) { +is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { checkmate::assert_character(token, any.missing = TRUE, len = 1) if (!is.null(pattern_env)) { - checkmate::assert_character(pattern_env, any.missing = FALSE, len = 1) + checkmate::assert_character(pattern_env, + any.missing = FALSE, + len = 1 + ) pattern <- pattern_env } else { pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", - .open = "<", - .close = ">") + .open = "<", + .close = ">" + ) } if (is.na(token)) { @@ -9253,15 +8615,10 @@ repeated_instruments <- function(uri, token) { #' @export #' drop_empty_event <- function(data, event = "redcap_event_name") { - generics <- c( - names(data)[1], - "redcap_event_name", - "redcap_repeat_instrument", - "redcap_repeat_instance" - ) + generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") filt <- split(data, data[[event]]) |> - lapply(\(.x) { + lapply(\(.x){ dplyr::select(.x, -tidyselect::all_of(generics)) |> REDCapCAST::all_na() }) |> @@ -9271,327 +8628,6 @@ drop_empty_event <- function(data, event = "redcap_event_name") { } -#' Validate a REDCap server-side filter string against a data dictionary -#' -#' Checks that a REDCap filter expression is syntactically correct and -#' consistent with the field types defined in the project data dictionary. -#' Plain text without field references is always rejected. Multi-clause -#' filters joined by \code{AND} or \code{OR} are supported. -#' -#' @param filter A single character string containing the filter expression, -#' e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}. -#' @param dictionary A data frame representing the REDCap data dictionary in -#' API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. -#' Must contain at least the columns \code{field_name} and \code{field_type}. -#' The columns \code{text_validation_type_or_show_slider_number} and -#' \code{select_choices_or_calculations} are used when present for stricter -#' type and choice validation. -#' -#' @return A named list with two elements: -#' \describe{ -#' \item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} -#' \item{\code{message}}{Character. \code{"Filter is valid."} on success, or -#' a newline-separated string of error messages describing every problem -#' found.} -#' } -#' -#' @details -#' Validation rules by field type: -#' \describe{ -#' \item{\code{calc}}{Numeric fields. Value must be an unquoted number. -#' All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, -#' \code{<=}, \code{>=}) are accepted.} -#' \item{\code{text} with date validation}{Fields with validation type -#' \code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be -#' a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All -#' comparison operators are accepted.} -#' \item{\code{text} with time validation}{Fields with validation type -#' \code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time -#' string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} -#' \item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a -#' quoted choice code (e.g. \code{'1'}) that exists in the field's choice -#' list. Only \code{=} and \code{!=} are accepted.} -#' \item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. -#' Only \code{=} and \code{!=} are accepted.} -#' } -#' -#' @examples -#' \dontrun{ -#' dict <- REDCapCAST::get_redcap_metadata( -#' uri = "https://redcap.example.com/api/", -#' token = Sys.getenv("REDCAP_TOKEN") -#' ) -#' -#' validate_redcap_filter("[age] > 18", dict) -#' #> list(valid = TRUE, message = "Filter is valid.") -#' -#' validate_redcap_filter("only plain text", dict) -#' #> list(valid = FALSE, message = "Filter must contain at least one field ...") -#' -#' validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) -#' #> list(valid = TRUE, message = "Filter is valid.") -#' } -#' -#' @export -# REDCap filter validation based on data dictionary -# -# REDCap filter format: [field_name] operator value -# Example: [age] > 18 -# [cohabitation] = '1' -# [inclusion] > '2020-01-01' -# -# Supported field types and their allowed operators/value formats: -# text (no validation) -> string values, = != operators only -# text (date_ymd/date_dmy) -> quoted date strings, all comparison operators -# text (time_hh_mm_ss) -> quoted time strings, all comparison operators -# text (datetime_*) -> quoted datetime strings, all comparison operators -# text (autocomplete) -> string values, = != operators only -# calc -> numeric values, all comparison operators -# radio/dropdown -> quoted numeric codes, = != operators only - -validate_redcap_filter <- function(filter, dictionary) { - # --- Input checks --- - if (!is.character(filter) || - length(filter) != 1 || nchar(trimws(filter)) == 0) { - return(list(valid = FALSE, message = "Filter must be a non-empty string.")) - } - - if (!grepl("\\[.+\\]", filter)) { - return( - list(valid = FALSE, message = "Filter must contain at least one field reference in [brackets]. Plain text is not accepted.") - ) - } - - # --- Column names (API export format) --- - col_field <- "field_name" - col_type <- "field_type" - col_val_type <- "text_validation_type_or_show_slider_number" - col_choices <- "select_choices_or_calculations" - - missing_cols <- setdiff(c(col_field, col_type), names(dictionary)) - if (length(missing_cols) > 0) { - stop("Dictionary is missing required columns: ", - paste(missing_cols, collapse = ", ")) - } - - # --- Build lookup index once for O(1) field access --- - field_idx <- setNames(seq_len(nrow(dictionary)), dictionary[[col_field]]) - has_val_type <- col_val_type %in% names(dictionary) - has_choices <- col_choices %in% names(dictionary) - - # --- Classify field types --- - numeric_types <- c("calc") - date_validations <- c( - "date_ymd", - "date_dmy", - "datetime_ymd", - "datetime_dmy", - "datetime_seconds_ymd", - "datetime_seconds_dmy" - ) - time_validations <- c("time_hh_mm_ss", "time_mm_ss") - categorical_types <- c("radio", "dropdown", "checkbox") - text_types <- c("text", "autocomplete") - - num_ops <- c("=", "!=", "<", ">", "<=", ">=") - cat_ops <- c("=", "!=") - text_ops <- c("=", "!=") - - # --- Parse filter into clauses --- - # Split on AND/OR (REDCap uses 'and'/'or' or 'AND'/'OR') - clauses <- trimws(strsplit(filter, "(?i)\\s+(and|or)\\s+", perl = TRUE)[[1]]) - - clause_pattern <- "^\\[([^\\]]+)\\]\\s*(=|!=|<=|>=|<|>)\\s*(.+)$" - - errors <- character(0) - - for (clause in clauses) { - if (!grepl(clause_pattern, clause, perl = TRUE)) { - errors <- c( - errors, - sprintf( - "Clause '%s' does not match expected format: [field] operator value", - clause - ) - ) - next - } - - parts <- regmatches(clause, regexec(clause_pattern, clause, perl = TRUE))[[1]] - field <- parts[2] - operator <- parts[3] - value <- trimws(parts[4]) - - # --- Check field exists using pre-built index --- - row_i <- field_idx[field] - if (is.na(row_i)) { - errors <- c(errors, sprintf("Unknown field: [%s]", field)) - next - } - - field_type <- dictionary[[col_type]][row_i] - val_type <- if (has_val_type) - dictionary[[col_val_type]][row_i] - else - "" - if (is.na(val_type)) - val_type <- "" - - # --- Determine expected value format and allowed operators --- - if (field_type %in% numeric_types || - grepl("^integer$|^number", val_type)) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is numeric — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl("^-?[0-9]+(\\.[0-9]+)?$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is numeric — value '%s' should be an unquoted number (e.g. 18 or 3.5)", - field, - value - ) - ) - } - - } else if (val_type %in% date_validations) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a date — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl( - "^'[0-9]{4}-[0-9]{2}-[0-9]{2}(\\s[0-9]{2}:[0-9]{2}(:[0-9]{2})?)?'$", - value - )) { - errors <- c( - errors, - sprintf( - "[%s] is a date — value '%s' should be a quoted date string, e.g. '2020-01-31'", - field, - value - ) - ) - } - - } else if (val_type %in% time_validations) { - if (!operator %in% num_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a time — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(num_ops, collapse = ", ") - ) - ) - } - if (!grepl("^'[0-9]{2}:[0-9]{2}(:[0-9]{2})?'$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is a time — value '%s' should be a quoted time string, e.g. '14:30:00'", - field, - value - ) - ) - } - - } else if (field_type %in% categorical_types) { - if (!operator %in% cat_ops) { - errors <- c( - errors, - sprintf( - "[%s] is categorical — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(cat_ops, collapse = ", ") - ) - ) - } - - # Validate value is a known choice code - choices_raw <- if (has_choices) - dictionary[[col_choices]][row_i] - else - NA - if (!is.na(choices_raw) && nchar(trimws(choices_raw)) > 0) { - choice_codes <- trimws(gsub(",.+?(\\||$)", "", gsub( - "^\\s*", "", strsplit(choices_raw, "\\|")[[1]] - ))) - value_unquoted <- gsub("^'|'$", "", value) - if (!value_unquoted %in% choice_codes) { - errors <- c( - errors, - sprintf( - "[%s] is categorical — '%s' is not a valid choice code. Valid codes: %s", - field, - value_unquoted, - paste(choice_codes, collapse = ", ") - ) - ) - } - } - - if (!grepl("^'.*'$", value)) { - errors <- c(errors, - sprintf( - "[%s] is categorical — value should be quoted, e.g. '1'", - field - )) - } - - } else { - # Plain text field - if (!operator %in% text_ops) { - errors <- c( - errors, - sprintf( - "[%s] is a text field — operator '%s' is not valid. Use one of: %s", - field, - operator, - paste(text_ops, collapse = ", ") - ) - ) - } - if (!grepl("^'.*'$", value)) { - errors <- c( - errors, - sprintf( - "[%s] is a text field — value should be quoted, e.g. 'some text'", - field - ) - ) - } - } - } - - if (length(errors) > 0) { - return(list( - valid = FALSE, - message = paste(errors, collapse = "\n") - )) - } - - list(valid = TRUE, message = "Filter is valid.") -} - - - #' Test app for the redcap_read_shiny_module #' #' @rdname redcap_read_shiny_module @@ -9610,10 +8646,16 @@ redcap_demo_app <- function() { server <- function(input, output, session) { data_val <- m_redcap_readServer(id = "data") - output$data <- DT::renderDataTable({ - shiny::req(data_val$data) - data_val$data() - }, options = list(scrollX = TRUE, pageLength = 5), ) + output$data <- DT::renderDataTable( + { + shiny::req(data_val$data) + data_val$data() + }, + options = list( + scrollX = TRUE, + pageLength = 5 + ), + ) output$code <- shiny::renderPrint({ shiny::req(data_val$code) data_val$code() @@ -10653,8 +9695,7 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = phosphoricons::ph("calculator"), - # icon = bsicons::bs_icon("calculator"), + icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -10688,8 +9729,7 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = phosphoricons::ph("math-operations"), - # icon = bsicons::bs_icon("pencil"), + icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -10734,8 +9774,7 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = phosphoricons::ph("chart-bar-horizontal"), - # icon = bsicons::bs_icon("bar-chart-steps"), + icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -10778,8 +9817,7 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ) @@ -10800,8 +9838,7 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = phosphoricons::ph("checks"), - # icon = bsicons::bs_icon("clipboard-check"), + icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -11017,7 +10054,7 @@ regression_server <- function(id, rv$list$regression$models <- model_lists }, error = function(err) { - showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Creating regression models failed with the following error:"), err), type = "err") } ) } @@ -11082,7 +10119,7 @@ regression_server <- function(id, showNotification(paste0(warn), type = "warning") }, error = function(err) { - showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Creating a regression table failed with the following error:"), err), type = "err") } ) } @@ -11160,7 +10197,7 @@ regression_server <- function(id, gg_theme_shiny() }, error = function(err) { - showNotification(paste0(err), type = "error") + showNotification(paste0(err), type = "err") } ) }) @@ -11220,7 +10257,7 @@ regression_server <- function(id, # showNotification(paste0(warn), type = "warning") # }, error = function(err) { - showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "error") + showNotification(paste(i18n$t("Running model assumptions checks failed with the following error:"), err), type = "err") } ) } @@ -11291,7 +10328,7 @@ regression_server <- function(id, out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) }, error = function(err) { - showNotification(err, type = "error") + showNotification(err, type = "err") } ) @@ -11461,7 +10498,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -11945,8 +10982,7 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) } else { # Return NULL to show nothing @@ -12237,8 +11273,7 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = phosphoricons::ph("house", weight = "bold"), - # icon = shiny::icon("house"), + icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -12268,8 +11303,7 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = phosphoricons::ph("play", weight = "bold"), - # icon = shiny::icon("play"), + icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -12346,8 +11380,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars",weight = "bold"), - # icon = shiny::icon("binoculars"), + icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -12391,8 +11424,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play",weight = "bold"), - # icon = shiny::icon("play"), + icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -12411,13 +11443,11 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = phosphoricons::ph("note-pencil", weight = "bold"), - # icon = shiny::icon("pen-to-square"), + icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = phosphoricons::ph("eye"), - # icon = shiny::icon("eye"), + icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -12469,7 +11499,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", + href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -12492,8 +11522,7 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = phosphoricons::ph("pencil-line"), - # icon = shiny::icon("file-pen"), + icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -12522,13 +11551,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor"), + label = i18n$t("Modify factor levels"), width = "100%" ), shiny::tags$br(), - shiny::helpText(i18n$t( - "Modify the levels of factor/categorical variables." - )), + shiny::helpText( + i18n$t("Reorder or rename the levels of factor/categorical variables.") + ), shiny::tags$br(), shiny::tags$br() ), @@ -12541,7 +11570,9 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t("Create factor/categorical variable from other variables.") + i18n$t( + "Create factor/categorical variable from a continous variable (number/date/time)." + ) ), shiny::tags$br(), shiny::tags$br() @@ -12618,16 +11649,14 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = phosphoricons::ph("magnifying-glass", weight = "bold"), - # icon = shiny::icon("magnifying-glass-chart"), + icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = phosphoricons::ph("table"), - # icon = bsicons::bs_icon("table"), + icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12639,8 +11668,7 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = phosphoricons::ph("table"), - # icon = bsicons::bs_icon("table"), + icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -12682,8 +11710,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator",weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -12697,8 +11724,7 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = phosphoricons::ph("graph"), - # icon = bsicons::bs_icon("bounding-box"), + icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12739,8 +11765,7 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = phosphoricons::ph("placeholder") - # icon = bsicons::bs_icon("x-circle") + icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -12755,8 +11780,7 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = phosphoricons::ph("chart-line", weight = "bold"), - # icon = shiny::icon("chart-line"), + icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -12777,8 +11801,7 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = phosphoricons::ph("calculator", weight = "bold"), - # icon = shiny::icon("calculator"), + icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -12790,8 +11813,7 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = phosphoricons::ph("download-simple", weight = "bold"), - # icon = shiny::icon("download"), + icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -12827,8 +11849,7 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -12858,8 +11879,7 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = phosphoricons::ph("arrow-fat-down") - # icon = shiny::icon("download") + icon = shiny::icon("download") ) ) ), @@ -12916,7 +11936,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://freesearchr.github.io/FreesearchR-knowledge/", + href = "https://agdamsbo.github.io/FreesearchR/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", @@ -12978,33 +11998,22 @@ update_factor_ui <- function(id) { ), fluidRow( column( - width = 3, + width = 6, shinyWidgets::virtualSelectInput( inputId = ns("variable"), - label = i18n$t("Choose variable:"), + label = i18n$t("Factor variable to reorder:"), choices = NULL, width = "100%", zIndex = 50 ) ), - column( - width = 3, - class = "d-flex align-items-end", - actionButton( - disabled = TRUE, - inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), - class = "btn-outline-primary mb-3", - width = "100%" - ) - ), column( width = 3, class = "d-flex align-items-end", actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending",weight = "bold"), + phosphoricons::ph("sort-ascending"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -13017,7 +12026,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending",weight = "bold"), + phosphoricons::ph("sort-ascending"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -13030,9 +12039,7 @@ update_factor_ui <- function(id) { class = "float-end", shinyWidgets::prettyCheckbox( inputId = ns("new_var"), - label = i18n$t( - "Create a new variable; otherwise replaces (Updating labels always creates new variable)" - ), + label = i18n$t("Create a new variable; otherwise replaces (Updating labels always creates new variable)"), value = FALSE, status = "primary", outline = TRUE, @@ -13041,7 +12048,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise",weight = "bold"), + phosphoricons::ph("arrow-clockwise"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -13087,20 +12094,6 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { rv$data_grid <- grid }) - observeEvent(rv$data_grid, { - variable <- req(input$variable) - if (isTRUE(has_empty_levels(rv$data[[variable]]))) { - # browser() - updateActionButton(inputId = "drop_levels", disabled = FALSE) - } else { - updateActionButton(inputId = "drop_levels", disabled = TRUE) - } - }) - - observeEvent(input$drop_levels, { - rv$data_grid <- rv$data_grid[!rv$data_grid$Freq==0,] - }) - observeEvent(input$sort_levels, { if (input$sort_levels %% 2 == 1) { decreasing <- FALSE @@ -13184,7 +12177,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { ) data <- tryCatch({ - with_labels(data, { + with_labels(data,{ rlang::exec(factor_new_levels_labels, !!!modifyList(parameters, val = list(data = data))) }) @@ -13194,7 +12187,7 @@ update_factor_server <- function(id, data_r = reactive(NULL)) { "We encountered the following error creating the new factor:", err ), - type = "error") + type = "err") }) # browser() @@ -13348,15 +12341,6 @@ unique_names <- function(new, existing = character()) { } -has_empty_levels <- function(x) { - if (is.factor(x)) { - any(!levels(x) %in% x) - } else { - return(FALSE) - } -} - - ######## #### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R ######## @@ -13393,7 +12377,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear",weight = "bold"), + label = phosphoricons::ph("gear"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -13438,7 +12422,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), i18n$t("Apply changes") ), width = "100%" @@ -15887,7 +14871,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "error") + ), type = "err") }) }) @@ -16144,7 +15128,6 @@ server <- function(input, output, session) { inputId = "column_filter", label = i18n$t("Select data types to include"), selected = unique(data_type(rv$data)), - #[unique(data_type(rv$data))!="text"], choices = unique(data_type(rv$data)), updateOn = "change", multiple = TRUE, @@ -16237,58 +15220,48 @@ server <- function(input, output, session) { ######### Data filter # IDEAFilter has the least cluttered UI, but might have a License issue # Consider using shinyDataFilter, though not on CRAN - data_filter_raw <- IDEAFilter::IDEAFilter( + data_filter <- IDEAFilter::IDEAFilter( "data_filter", - data = shiny::reactive(non_character_cols(rv$data_variables)), + data = shiny::reactive(rv$data_variables), verbose = TRUE ) - data_filter <- reactive({ - apply_idea_filter(data_filter_raw, rv$data_variables) + shiny::observeEvent(list( + shiny::reactive(rv$data_variables), + shiny::reactive(rv$data_original), + data_filter(), + # regression_vars(), + input$complete_cutoff + ), + { + ### Save filtered data + rv$data_filtered <- data_filter() + + ### Save filtered data + ### without empty factor levels + rv$list$data <- data_filter() |> + REDCapCAST::fct_drop() |> + (\(.x) { + .x[!sapply(.x, is.character)] + })() + + ## This looks messy!! But it works as intended for now + + out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( + attr(rv$data_filtered, "code") + ), collapse = " "))) + + out <- strsplit(out, "%>%") |> + unlist() |> + (\(.x) { + paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"), collapse = "|> \n ") + })() + + rv$code <- append_list(data = out, + list = rv$code, + index = "filter") }) - shiny::observeEvent( - list( - shiny::reactive(rv$data_variables), - shiny::reactive(rv$data_original), - data_filter_raw(), - # regression_vars(), - input$complete_cutoff - ), - { - ### Save filtered data - # browser() - # rv$data_filtered <- apply_idea_filter(data_filter_raw, rv$data_variables)() - rv$data_filtered <- data_filter() - - ### Save filtered data - ### ~~without empty factor levels~~ - ### All factor levels are kept, but can be manually removed - # browser() - rv$list$data <- rv$data_filtered #|> - # # REDCapCAST::fct_drop() |> - # (\(.x) { - # .x[!sapply(.x, is.character)] - # })() - - ## This looks messy!! But it works as intended for now - # browser() - out <- gsub("filter", "dplyr::filter", gsub("\\s{2,}", " ", paste0(capture.output( - attr(data_filter_raw(), "code") - ), collapse = " "))) - - out <- strsplit(out, "%>%") |> - unlist() |> - (\(.x) { - paste(c("df <- df", .x[-1]), collapse = "|> \n ") - })() - - rv$code <- append_list(data = out, - list = rv$code, - index = "filter") - } - ) - ######### Data preview ### Overview @@ -16306,7 +15279,7 @@ server <- function(input, output, session) { observeEvent(input$modal_browse, { tryCatch({ show_data( - rv$data_filtered, + REDCapCAST::fct_drop(rv$data_filtered), title = i18n$t("Uploaded data overview"), type = "modal" ) @@ -16314,7 +15287,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error browsing your data:"), err - ), type = "error") + ), type = "err") }) }) @@ -16340,7 +15313,7 @@ server <- function(input, output, session) { showNotification(paste( i18n$t("We encountered the following error showing missingness:"), err - ), type = "error") + ), type = "err") }) }) @@ -16547,7 +15520,7 @@ server <- function(input, output, session) { # } # }, # error = function(err) { - # showNotification(err, type = "error") + # showNotification(err, type = "err") # } # ) @@ -16608,9 +15581,7 @@ server <- function(input, output, session) { ######### ############################################################################## - pl <- data_visuals_server("visuals", - data = shiny::reactive(rv$list$data), - palettes = color_choices()) + pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data)) ############################################################################## ######### @@ -16708,7 +15679,7 @@ server <- function(input, output, session) { "We encountered the following error creating your report: " ), err - ), type = "error") + ), type = "err") }) }) file.rename(paste0("www/report.", type), file) diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 517df60d..ce9abc8e 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -55,6 +55,7 @@ "Imported data","Importeret data" "www/intro.md","www/intro.md" "Choose your data","Vælg dine data" +"Factor variable to reorder:","Kategoriske variabel der skal ændres:" "Sort by levels","Sorter efter niveauer" "Sort by count","Sorter efter antal" "Update factor variable","Updater faktor-variabel" @@ -89,6 +90,7 @@ "and","og" "from each pair","fra hvert par" "Plot","Tegn" +"Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" "Plot width (mm)","Bredde af grafik (mm)" "File format","File format" @@ -96,7 +98,12 @@ "Select variable","Vælg variabel" "Response variable","Svarvariable" "Plot type","Type af grafik" +"Please select","Vælg" +"Additional variables","Yderligere variabler" +"Secondary variable","Sekundær variabel" "No variable","Ingen variabel" +"Grouping variable","Variabel til gruppering" +"No stratification","Ingen stratificering" "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" @@ -141,12 +148,16 @@ "Import data from REDCap","Importér data fra REDCap" "REDCap server","REDCap-server" "Web address","Serveradresse" +"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Adressen skal være som 'https://redcap.your.institution/' eller 'https://your.institution/redcap/'" "API token","API-nøgle" +"The token is a string of 32 numbers and letters.","En API-nøgle består af ialt 32 tal og bogstaver." "Connect","Forbind" "Data import parameters","Data import parameters" +"Select fields/variables to import and click the funnel to apply optional filters","Vælg variabler, der skal importeres og tryk på tragten for at anvende valgfrie filtre" "Import","Import" "Click to see data dictionary","Tryk for at se metadata (Data Dictionary)" "Connected to server!","Forbindelse til serveren oprettet!" +"The {data_rv$info$project_title} project is loaded.","{data_rv$info$project_title}-projektet er forbundet." "Data dictionary","Data dictionary" "Preview:","Forsmag:" "Imported data set","Importeret datasæt" @@ -154,6 +165,8 @@ "Specify the data format","Specificér dataformatet" "Fill missing values?","Skal manglende observationer udfyldes?" "Requested data was retrieved!","Det udvalgte data blev hentet!" +"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde ID-variablen. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." +"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data er hentet, men det ser ud til kun at indeholde nogle af de udvalgte variabler. Du skal kontakte din REDCap-administrator og sikre dig at du har adgang til faktisk at hente de udvalgte data." "Click to see the imported data","Tryk for at se de importerede data" "Regression table","Regressionstabel" "Import a dataset from an environment","Importer et datasæt fra et kodemiljø" @@ -254,6 +267,7 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR er tilgængelig på flere sprog. For at få hjælp med oversættelser, kontakt os venligst på info@freesearchr.org" "Home","Hjem" "Start with FreesearchR for basic data evaluation and analysis.","Start med FreesearchR til grundlæggende dataevaluering og -analyse." +"When you need more advanced tools, you'll be better prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være bedre forberedt på at bruge R direkte." "(Read more)","(Læs mere)" "Run the FreesearchR app locally when working with sensitive data.","Kør FreesearchR-appen lokalt, når du arbejder med følsomme data." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Indlæs data fra regneark, REDCap-servere, eller prøv med eksempeldata. Flere kilder understøttes for maksimal fleksibilitet." @@ -264,16 +278,20 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være forberedt på at bruge R direkte." "The app contains a selelct number of features and will guide you through key analyses.","Appen indeholder udvalgte funktioner, og guider dig gennem de vigtigste analyser." "Sort by Levels","Sorter efter niveauer" +"Modify factor levels","Ændr kategoriske niveauer" +"Reorder or rename the levels of factor/categorical variables.","Ændr navn eller rækkefølge på kategorisk variabel." "Maximum number of observations:","Maximale antal observationer:" "setting to 0 includes all","angiv 0 for at inkludere alle" "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." "Select a sample dataset from a package.","Vælg et træningsdatasæt." "Data ready to be imported!","Data er klar til at blive importeret!" +"Data has %s obs. of %s variables.","Data har %s obs. på %s variabler." "Data successfully imported!","Data successfully imported!" "Click to see data","Klik for at se data" "No data present.","Ingen data tilstede." "You have provided a complete dataset with no missing values.","Data er uden manglende observationer." "Start by loading data.","Start med at vælge data." +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -304,23 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" -"Drop empty","Drop empty" -"Choose variable:","Choose variable:" -"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." -"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." -"Likert diagram","Likert diagram" -"Modify factor","Modify factor" -"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." -"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." -"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." -"Define plot","Define plot" "Choose color palette","Choose color palette" -"Additional variable","Additional variable" -"Grouping variable","Grouping variable" -"Secondary variable","Secondary variable" -"Reverse colors","Reverse colors" -"Plot survey results","Plot survey results" -"Additional variables","Additional variables" -"Other variables","Other variables" -"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index c56e9549..96a7a109 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -55,6 +55,7 @@ "Imported data","Data iliyoingizwa" "www/intro.md","www/intro.md" "Choose your data","Chagua data yako" +"Factor variable to reorder:","Kigezo cha vipengele ili kupanga upya:" "Sort by levels","Panga kwa viwango" "Sort by count","Panga kwa hesabu" "Update factor variable","Sasisha kigezo cha kipengele" @@ -89,6 +90,7 @@ "and","na" "from each pair","kutoka kwa kila jozi" "Plot","Kipande cha habari" +"Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" "Plot width (mm)","Upana wa kiwanja (mm)" "File format","Umbizo la faili" @@ -96,7 +98,12 @@ "Select variable","Chagua kigezo" "Response variable","Kigezo cha majibu" "Plot type","Aina ya kiwanja" +"Please select","Tafadhali chagua" +"Additional variables","Vigezo vya ziada" +"Secondary variable","Kigezo cha pili" "No variable","Hakuna kigezo" +"Grouping variable","Kigezo cha kuweka katika makundi" +"No stratification","Hakuna matabaka" "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" @@ -141,12 +148,16 @@ "Import data from REDCap","Ingiza data kutoka REDCap" "REDCap server","Seva ya REDCap" "Web address","Anwani ya wavuti" +"Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'","Muundo unapaswa kuwa 'https://redcap.your.institution/' au 'https://your.institution/redcap/'" "API token","Tokeni ya API" +"The token is a string of 32 numbers and letters.","Tokeni ni mfuatano wa nambari na herufi 32." "Connect","Unganisha" "Data import parameters","Vigezo vya kuingiza data" +"Select fields/variables to import and click the funnel to apply optional filters","Chagua sehemu/vigezo vya kuingiza na ubofye faneli ili kutumia vichujio vya hiari" "Import","Ingiza" "Click to see data dictionary","Bofya ili kuona kamusi ya data" "Connected to server!","Imeunganishwa na seva!" +"The {data_rv$info$project_title} project is loaded.","Mradi wa {data_rv$info$project_title} umepakiwa." "Data dictionary","Kamusi ya data" "Preview:","Hakikisho:" "Imported data set","Seti ya data iliyoingizwa" @@ -154,6 +165,8 @@ "Specify the data format","Bainisha umbizo la data" "Fill missing values?","Jaza thamani zinazokosekana?" "Requested data was retrieved!","Data iliyoombwa ilipatikana!" +"Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana ni kitambulisho pekee kilichorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." +"Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access.","Data imerejeshwa, lakini inaonekana kama si sehemu zote zilizoombwa zilizorejeshwa kutoka kwa seva. Tafadhali wasiliana na msimamizi wako wa REDCap kama una ruhusa zinazohitajika kwa ufikiaji wa data." "Click to see the imported data","Bofya ili kuona data iliyoingizwa" "Regression table","Jedwali la urejeshaji" "Import a dataset from an environment","Ingiza seti ya data kutoka kwa mazingira" @@ -254,6 +267,7 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR inapatikana katika lugha nyingi. Ili kukusaidia na tafsiri, tafadhali wasiliana nasi kwa info@freesearchr.org." "Home","Nyumbani" "Start with FreesearchR for basic data evaluation and analysis.","Anza na FreesearchR kwa tathmini na uchambuzi wa data ya msingi." +"When you need more advanced tools, you'll be better prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari zaidi kutumia R moja kwa moja." "(Read more)","(Soma zaidi)" "Run the FreesearchR app locally when working with sensitive data.","Endesha programu ya FreesearchR ndani ya eneo lako unapofanya kazi na data nyeti." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Pakia data kutoka kwa lahajedwali, seva za REDCap, au jaribu na data ya sampuli. Vyanzo vingi vinaungwa mkono kwa unyumbufu wa hali ya juu." @@ -264,16 +278,20 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari kutumia R moja kwa moja." "The app contains a selelct number of features and will guide you through key analyses.","The app contains a selelct number of features and will guide you through key analyses." "Sort by Levels","Sort by Levels" +"Modify factor levels","Modify factor levels" +"Reorder or rename the levels of factor/categorical variables.","Reorder or rename the levels of factor/categorical variables." "Maximum number of observations:","Maximum number of observations:" "setting to 0 includes all","setting to 0 includes all" "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." "Select a sample dataset from a package.","Select a sample dataset from a package." "Data ready to be imported!","Data ready to be imported!" +"Data has %s obs. of %s variables.","Data has %s obs. of %s variables." "Data successfully imported!","Data successfully imported!" "Click to see data","Click to see data" "No data present.","No data present." "You have provided a complete dataset with no missing values.","You have provided a complete dataset with no missing values." "Start by loading data.","Start by loading data." +"Create a new variable; otherwise replaces (Updating labels always creates new variable)","Create a new variable; otherwise replaces (Updating labels always creates new variable)" "Data classes and missing observations","Data classes and missing observations" "We encountered the following error showing missingness:","We encountered the following error showing missingness:" "Please confirm data reset!","Please confirm data reset!" @@ -304,23 +322,4 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" -"Drop empty","Drop empty" -"Choose variable:","Choose variable:" -"An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." -"An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." -"Likert diagram","Likert diagram" -"Modify factor","Modify factor" -"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." -"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." -"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." -"Define plot","Define plot" "Choose color palette","Choose color palette" -"Additional variable","Additional variable" -"Grouping variable","Grouping variable" -"Secondary variable","Secondary variable" -"Reverse colors","Reverse colors" -"Plot survey results","Plot survey results" -"Additional variables","Additional variables" -"Other variables","Other variables" -"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/man/align_axes.Rd b/man/align_axes.Rd index f403e1a7..2a8ab279 100644 --- a/man/align_axes.Rd +++ b/man/align_axes.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{align_axes} \alias{align_axes} \title{Aligns axes between plots} \usage{ -align_axes(..., x.axis = TRUE, y.axis = TRUE, percentage = FALSE) +align_axes(..., x.axis = TRUE, y.axis = TRUE) } \arguments{ \item{...}{ggplot2 objects or list of ggplot2 objects} diff --git a/man/all_but.Rd b/man/all_but.Rd index 8dc3f46e..e2453d15 100644 --- a/man/all_but.Rd +++ b/man/all_but.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{all_but} \alias{all_but} \title{Select all from vector but} diff --git a/man/available_plots.Rd b/man/available_plots.Rd deleted file mode 100644 index 0ee1d5ac..00000000 --- a/man/available_plots.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R -\name{available_plots} -\alias{available_plots} -\title{Implemented functions} -\usage{ -available_plots() -} -\value{ -list -} -\description{ -Library of supported functions. The list name and "descr" element should be -unique for each element on list. -\itemize{ -\item fun: the plotting function -\item fun.args: default parameters for the plotting function -\item descr: Plot description -\item note: Short note/description of the function for displaying in ui and docs -\item primary.type: Primary variable data type (see \link{data_type}) -\item base: holds a list of parameters for plot input fields generation -Secondary and tertiary variable input fields are mandatory. -} -} -\examples{ -available_plots() |> str() -} diff --git a/man/clean_common_axis.Rd b/man/clean_common_axis.Rd index 67197d46..175053c9 100644 --- a/man/clean_common_axis.Rd +++ b/man/clean_common_axis.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{clean_common_axis} \alias{clean_common_axis} \title{Extract and clean axis ranges} diff --git a/man/colorSelectInput.Rd b/man/colorSelectInput.Rd index 0f673a0b..37561b0f 100644 --- a/man/colorSelectInput.Rd +++ b/man/colorSelectInput.Rd @@ -9,7 +9,7 @@ colorSelectInput( inputId, label, choices, - selected = NULL, + selected = "", previews = 4, ..., placeholder = "" diff --git a/man/create_baseline.Rd b/man/create_baseline.Rd index bca41929..23b3621f 100644 --- a/man/create_baseline.Rd +++ b/man/create_baseline.Rd @@ -12,8 +12,7 @@ create_baseline( add.diff = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon"), - detail_level = c("minimal", "extended"), - drop_empty = FALSE + detail_level = c("minimal", "extended") ) } \arguments{ diff --git a/man/data-plots.Rd b/man/data-plots.Rd index e6d84e08..5229751a 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -1,18 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R, R/plot-helpers.R, R/plot_bar.R, -% R/plot_box.R, R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, -% R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R +% Please edit documentation in R/data_plots.R, R/plot_bar.R, R/plot_box.R, +% R/plot_hbar.R, R/plot_ridge.R, R/plot_sankey.R, R/plot_scatter.R, +% R/plot_violin.R \name{data-plots} \alias{data-plots} \alias{data_visuals_ui} \alias{data_visuals_server} \alias{create_plot} -\alias{plot_bar} \alias{plot_bar_single} \alias{plot_box} \alias{plot_box_single} \alias{plot_hbars} -\alias{plot_likert} \alias{plot_ridge} \alias{sankey_ready} \alias{plot_sankey} @@ -22,21 +20,19 @@ \usage{ data_visuals_ui(id, tab_title = "Plots", ...) -data_visuals_server(id, data, palettes = color_choices(), ...) - -create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) - -plot_bar( +data_visuals_server( + id, data, - pri, - sec = NULL, - ter = NULL, - style = c("stack", "dodge", "fill"), - color.palette = "viridis", - max_level = 30, + palettes = c(`Perceptual (blue-yellow)` = "viridis", `Perceptual (fire)` = "plasma", + `Colour-blind friendly` = "Okabe-Ito", `Qualitative (bold)` = "Dark 2", + `Qualitative (paired)` = "Paired", `Sequential (blues)` = "Blues", + `Diverging (red-blue)` = "RdBu", `Tableau style` = "Tableau 10", Pastel = "Pastel 1", + Rainbow = "rainbow"), ... ) +create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) + plot_bar_single( data, pri, @@ -50,9 +46,7 @@ plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...) plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") -plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis", ...) - -plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis", ...) +plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) @@ -69,13 +63,12 @@ plot_sankey( default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing", - ... + missing.level = "Missing" ) -plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis", ...) +plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis") -plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis", ...) +plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis") } \arguments{ \item{id}{Module id. (Use 'ns("id")')} @@ -104,8 +97,6 @@ shiny server module ggplot2 object -ggplot list object - ggplot object ggplot2 object @@ -116,8 +107,6 @@ ggplot2 object ggplot2 object -ggplot2 object - data.frame ggplot2 object @@ -131,8 +120,6 @@ Data correlations evaluation module Wrapper to create plot based on provided type -Title - Single vertical barplot Beautiful box plot(s) @@ -141,8 +128,6 @@ Create nice box-plots Nice horizontal stacked bars (Grotta bars) -Nice horizontal bar plot centred on the central category - Plot nice ridge plot Readying data for sankey plot @@ -155,13 +140,6 @@ Beautiful violin plot } \examples{ create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -mtcars |> - dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> - plot_bar(pri = "cyl", sec = "am", style = "fill") - -mtcars |> - dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> - plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") mtcars |> dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> plot_bar_single(pri = "cyl", sec = "am", style = "fill") @@ -185,12 +163,7 @@ mtcars |> plot_hbars(pri = "carb", sec = "cyl") mtcars |> plot_hbars(pri = "carb", sec = "cyl", ter="am") mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Blues") mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Magma") -mtcars |> plot_hbars(pri = "carb", sec = "am",color.palette="Viridis") -mtcars |> plot_likert(pri = "carb", sec = "cyl") -mtcars |> plot_likert(pri = "carb", sec = "cyl", ter="am") -mtcars |> plot_likert(pri = "cyl",color.palette="Blues") -mtcars |> plot_likert(pri = "carb", sec = NULL,color.palette="Magma") -mtcars |> plot_likert(pri = "carb", sec = c("cyl","am"),color.palette="Viridis") +mtcars |> plot_hbars(pri = "carb", sec = NULL,color.palette="Viridis") mtcars |> default_parsing() |> plot_ridge(x = "mpg", y = "cyl") diff --git a/man/get_input_params.Rd b/man/get_input_params.Rd deleted file mode 100644 index 6766d73e..00000000 --- a/man/get_input_params.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R -\name{get_input_params} -\alias{get_input_params} -\title{Get the function parameters based on the selected function description} -\usage{ -get_input_params(data) -} -\arguments{ -\item{data}{vector} -} -\value{ -list -} -\description{ -Get the function parameters based on the selected function description -} -\examples{ -ls <- mtcars |> - default_parsing() |> - dplyr::pull(mpg) |> - possible_plots() |> - (\(.x){ - .x[[1]] - })() |> - get_input_params() -} diff --git a/man/get_label.Rd b/man/get_label.Rd index c808209e..108fd372 100644 --- a/man/get_label.Rd +++ b/man/get_label.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{get_label} \alias{get_label} \title{Print label, and if missing print variable name for plots} diff --git a/man/get_plot_options.Rd b/man/get_plot_options.Rd index 83001d38..08c04496 100644 --- a/man/get_plot_options.Rd +++ b/man/get_plot_options.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{get_plot_options} \alias{get_plot_options} \title{Get the function options based on the selected function description} diff --git a/man/line_break.Rd b/man/line_break.Rd index d926556e..65c987c7 100644 --- a/man/line_break.Rd +++ b/man/line_break.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{line_break} \alias{line_break} \title{Line breaking at given number of characters for nicely plotting labels} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd index 22d425c2..f481d5af 100644 --- a/man/plot_euler_single.Rd +++ b/man/plot_euler_single.Rd @@ -4,7 +4,7 @@ \alias{plot_euler_single} \title{Easily plot single euler diagrams} \usage{ -plot_euler_single(data, color.palette = "viridis", ...) +plot_euler_single(data, color.palette = "viridis") } \value{ ggplot2 object diff --git a/man/possible_plots.Rd b/man/possible_plots.Rd index d1519e38..28c0b623 100644 --- a/man/possible_plots.Rd +++ b/man/possible_plots.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{possible_plots} \alias{possible_plots} \title{Get possible regression models} \usage{ -possible_plots(data, source_list = supported_plots()) +possible_plots(data) } \arguments{ \item{data}{data} diff --git a/man/selectPlotVariables.Rd b/man/selectPlotVariables.Rd deleted file mode 100644 index f9e63e5d..00000000 --- a/man/selectPlotVariables.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R -\name{selectPlotVariables} -\alias{selectPlotVariables} -\title{Wrapper for columnSelectInput} -\usage{ -selectPlotVariables(data, exclude = NULL, allow_none = TRUE, var_types, ...) -} -\description{ -Wrapper for columnSelectInput -} diff --git a/man/subset_types.Rd b/man/subset_types.Rd index a33e1561..61fced5e 100644 --- a/man/subset_types.Rd +++ b/man/subset_types.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{subset_types} \alias{subset_types} \title{Easily subset by data type function} diff --git a/man/supported_plots.Rd b/man/supported_plots.Rd index caa250e3..c91ad753 100644 --- a/man/supported_plots.Rd +++ b/man/supported_plots.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{supported_plots} \alias{supported_plots} \title{Implemented functions} diff --git a/man/validate_redcap_filter.Rd b/man/validate_redcap_filter.Rd deleted file mode 100644 index 9fb42c5d..00000000 --- a/man/validate_redcap_filter.Rd +++ /dev/null @@ -1,72 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/redcap_read_shiny_module.R -\name{validate_redcap_filter} -\alias{validate_redcap_filter} -\title{Validate a REDCap server-side filter string against a data dictionary} -\usage{ -validate_redcap_filter(filter, dictionary) -} -\arguments{ -\item{filter}{A single character string containing the filter expression, -e.g. \code{"[age] > 18"} or \code{"[cohabitation] = '1' AND [age] > 18"}.} - -\item{dictionary}{A data frame representing the REDCap data dictionary in -API export format, as returned by e.g. \code{REDCapCAST::get_redcap_metadata()}. -Must contain at least the columns \code{field_name} and \code{field_type}. -The columns \code{text_validation_type_or_show_slider_number} and -\code{select_choices_or_calculations} are used when present for stricter -type and choice validation.} -} -\value{ -A named list with two elements: -\describe{ -\item{\code{valid}}{Logical. \code{TRUE} if the filter passes all checks.} -\item{\code{message}}{Character. \code{"Filter is valid."} on success, or -a newline-separated string of error messages describing every problem -found.} -} -} -\description{ -Checks that a REDCap filter expression is syntactically correct and -consistent with the field types defined in the project data dictionary. -Plain text without field references is always rejected. Multi-clause -filters joined by \code{AND} or \code{OR} are supported. -} -\details{ -Validation rules by field type: -\describe{ -\item{\code{calc}}{Numeric fields. Value must be an unquoted number. -All comparison operators (\code{=}, \code{!=}, \code{<}, \code{>}, -\code{<=}, \code{>=}) are accepted.} -\item{\code{text} with date validation}{Fields with validation type -\code{date_ymd}, \code{date_dmy}, \code{datetime_*}, etc. Value must be -a quoted date/datetime string in \code{'YYYY-MM-DD'} format. All -comparison operators are accepted.} -\item{\code{text} with time validation}{Fields with validation type -\code{time_hh_mm_ss} or \code{time_mm_ss}. Value must be a quoted time -string, e.g. \code{'14:30:00'}. All comparison operators are accepted.} -\item{\code{radio} / \code{dropdown}}{Categorical fields. Value must be a -quoted choice code (e.g. \code{'1'}) that exists in the field's choice -list. Only \code{=} and \code{!=} are accepted.} -\item{\code{text} (plain)}{Free-text fields. Value must be a quoted string. -Only \code{=} and \code{!=} are accepted.} -} -} -\examples{ -\dontrun{ -dict <- REDCapCAST::get_redcap_metadata( - uri = "https://redcap.example.com/api/", - token = Sys.getenv("REDCAP_TOKEN") -) - -validate_redcap_filter("[age] > 18", dict) -#> list(valid = TRUE, message = "Filter is valid.") - -validate_redcap_filter("only plain text", dict) -#> list(valid = FALSE, message = "Filter must contain at least one field ...") - -validate_redcap_filter("[cohabitation] = '1' AND [age] > 18", dict) -#> list(valid = TRUE, message = "Filter is valid.") -} - -} diff --git a/man/vertical_stacked_bars.Rd b/man/vertical_stacked_bars.Rd index 75335365..495588fe 100644 --- a/man/vertical_stacked_bars.Rd +++ b/man/vertical_stacked_bars.Rd @@ -9,7 +9,7 @@ vertical_stacked_bars( score = "full_score", group = "pase_0_q", strata = NULL, - t.size = 8, + t.size = 10, l.color = "black", l.size = 0.5, draw.lines = TRUE, diff --git a/man/wrap_plot_list.Rd b/man/wrap_plot_list.Rd index dcf1ae64..2a6e8d62 100644 --- a/man/wrap_plot_list.Rd +++ b/man/wrap_plot_list.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-helpers.R +% Please edit documentation in R/data_plots.R \name{wrap_plot_list} \alias{wrap_plot_list} \title{Wrapping} @@ -12,7 +12,6 @@ wrap_plot_list( guides = "collect", axes = "collect", axis_titles = "collect", - y.axis.percentage = FALSE, ... ) }