diff --git a/CITATION.cff b/CITATION.cff index 86c9ebe0..9d517f96 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.4.2 +version: 26.6.1 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/R/sysdata.rda b/R/sysdata.rda index c56ca282..1829eab4 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/SESSION.md b/SESSION.md index 1e301770..55c29962 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.4.1 | -|system |aarch64, darwin20 | -|ui |RStudio | -|language |(EN) | -|collate |en_US.UTF-8 | -|ctype |en_US.UTF-8 | -|tz |Europe/Copenhagen | -|date |2026-04-10 | -|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.4.2.260410 | +|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 | -------------------------------------------------------------------------------- @@ -26,6 +26,8 @@ |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) | @@ -44,6 +46,7 @@ |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) | @@ -61,6 +64,7 @@ |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) | @@ -83,7 +87,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.4.2 |NA |NA | +|FreesearchR |26.6.1 |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) | @@ -93,7 +97,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.0) | +|glue |1.8.0 |2024-09-30 |CRAN (R 4.5.2) | |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) | @@ -124,6 +128,7 @@ |MASS |7.3-65 |2025-02-28 |CRAN (R 4.5.0) | |Matrix |1.7-4 |2025-08-28 |CRAN (R 4.5.0) | |memoise |2.0.1 |2021-11-26 |CRAN (R 4.5.0) | +|mgcv |1.9-4 |2025-11-07 |CRAN (R 4.5.0) | |mime |0.13 |2025-03-17 |CRAN (R 4.5.0) | |minqa |1.2.8 |2024-08-17 |CRAN (R 4.5.0) | |mvtnorm |1.3-2 |2024-11-04 |CRAN (R 4.5.2) | @@ -136,6 +141,7 @@ |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) | @@ -147,6 +153,7 @@ |pkgload |1.5.0 |2026-02-03 |CRAN (R 4.5.2) | |plyr |1.8.9 |2023-10-02 |CRAN (R 4.5.0) | |polyclip |1.10-7 |2024-07-23 |CRAN (R 4.5.0) | +|polylabelr |1.0.0 |2026-01-19 |CRAN (R 4.5.2) | |pracma |2.4.6 |2025-10-22 |CRAN (R 4.5.0) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.5.0) | |promises |1.5.0 |2025-11-01 |CRAN (R 4.5.0) | @@ -191,6 +198,7 @@ |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) | @@ -223,4 +231,5 @@ |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 4dd38592..9eb30b87 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprUCGcI/file4761ae70bf7.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpAe8F1F/file150d92b07c28b.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.4.2' +app_version <- function()'26.6.1' ######## @@ -2151,12 +2151,23 @@ 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 = "Create plot", + title = i18n$t("Define plot"), icon = phosphoricons::ph("chart-line"), # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), @@ -2167,19 +2178,16 @@ 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")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), shiny::uiOutput(outputId = ns("color_palette")), - shiny::br(), - 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 settings, then press "Plot".')) + shiny::uiOutput(outputId = ns("basic_parameters")), ), bslib::accordion_panel( value = "acc_pan_download", @@ -2232,14 +2240,14 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::plotOutput(ns("plot"), height = "65vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -2256,10 +2264,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, - data, - palettes, - ...) { +data_visuals_server <- function(id, data, palettes = color_choices(), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -2311,69 +2316,99 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data) + plots <- possible_plots(data = plot_data, source_list = available_plots()) - plots_named <- get_plot_options(plots) |> + plots_named <- get_input_params(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::h4(i18n$t("Plot type")), + label = shiny::h5(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_plot_options(input$type) |> purrr::pluck(1) + get_input_params(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) - cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - subset_types(data(), rv$plot.params()[["secondary.type"]]) - ), input$primary)) + # Get the plot function name + base_params <- rv$plot.params()[["base"]] - 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") + 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") ) + }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - 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") + # 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") ) }) + + ### 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) @@ -2387,19 +2422,49 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + 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, - color.palette = input$color_palette + ter = input$tertiary ) + 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"]])) { - parameters <- modifyList(parameters, 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)]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -2435,7 +2500,25 @@ data_visuals_server <- function(id, if (!is.null(rv$plot)) { rv$plot } else { - return(NULL) + # 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) } }) @@ -2480,506 +2563,6 @@ data_visuals_server <- function(id, ) } -#' 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_euler = 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) { - # 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", - 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//data-summary.R @@ -3845,38 +3428,25 @@ footer_ui <- function(i18n) { #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { + + # --- Input validation ------------------------------------------------------- + if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { 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 — call directly with n and ... + # --- Function passthrough --------------------------------------------------- if (is.function(palette)) { return(palette(n, ...)) } - 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.") - } - + # --- Named palette dispatch ------------------------------------------------- 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, ...) @@ -3896,35 +3466,42 @@ 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 { - 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) + # 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") + } + } } } @@ -4957,7 +4534,7 @@ apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame() #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.4.2-260410' +hosted_version <- function()'v26.6.1' ######## @@ -6971,14 +6548,14 @@ plot_bar <- function(data, 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, - ...) + y.axis.percentage = TRUE) } @@ -7099,11 +6676,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)}"))) } @@ -7297,7 +6874,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") + @@ -7340,13 +6917,15 @@ 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, + ... ) } @@ -7399,7 +6978,7 @@ 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)) { + if (isTRUE(reverse) | reverse=="TRUE") { colors <- rev(colors) } @@ -7456,7 +7035,8 @@ plot_likert <- function(data, pri, sec = NULL, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7633,7 +7213,8 @@ 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 { @@ -7867,7 +7448,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, @@ -7904,7 +7485,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 { @@ -7919,7 +7500,8 @@ 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) }) @@ -8065,6 +7647,890 @@ 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 ######## @@ -12003,7 +12469,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -12450,7 +12916,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/", + href = "https://freesearchr.github.io/FreesearchR-knowledge/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 927131ba..517df60d 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -89,7 +89,6 @@ "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" @@ -97,12 +96,7 @@ "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" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" @@ -320,3 +313,14 @@ "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 134ec155..c56e9549 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -89,7 +89,6 @@ "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" @@ -97,12 +96,7 @@ "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" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" @@ -320,3 +313,14 @@ "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/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index fbadebb2..7baeb26b 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//RtmprUCGcI/file47614d090a4c.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpAe8F1F/file150d9fbea069.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.4.2' +app_version <- function()'26.6.1' ######## @@ -2151,12 +2151,23 @@ 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 = "Create plot", + title = i18n$t("Define plot"), icon = phosphoricons::ph("chart-line"), # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), @@ -2167,19 +2178,16 @@ 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")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), shiny::uiOutput(outputId = ns("color_palette")), - shiny::br(), - 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 settings, then press "Plot".')) + shiny::uiOutput(outputId = ns("basic_parameters")), ), bslib::accordion_panel( value = "acc_pan_download", @@ -2232,14 +2240,14 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::plotOutput(ns("plot"), height = "65vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -2256,10 +2264,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { #' @name data-plots #' @returns shiny server module #' @export -data_visuals_server <- function(id, - data, - palettes, - ...) { +data_visuals_server <- function(id, data, palettes = color_choices(), ...) { shiny::moduleServer( id = id, module = function(input, output, session) { @@ -2311,69 +2316,99 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data) + plots <- possible_plots(data = plot_data, source_list = available_plots()) - plots_named <- get_plot_options(plots) |> + plots_named <- get_input_params(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::h4(i18n$t("Plot type")), + label = shiny::h5(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_plot_options(input$type) |> purrr::pluck(1) + get_input_params(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) - cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - subset_types(data(), rv$plot.params()[["secondary.type"]]) - ), input$primary)) + # Get the plot function name + base_params <- rv$plot.params()[["base"]] - 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") + 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") ) + }) output$tertiary <- shiny::renderUI({ shiny::req(input$type) - 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") + # 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") ) }) + + ### 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) @@ -2387,19 +2422,49 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + 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, - color.palette = input$color_palette + ter = input$tertiary ) + 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"]])) { - parameters <- modifyList(parameters, 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)]) } shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."), @@ -2435,7 +2500,25 @@ data_visuals_server <- function(id, if (!is.null(rv$plot)) { rv$plot } else { - return(NULL) + # 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) } }) @@ -2480,506 +2563,6 @@ data_visuals_server <- function(id, ) } -#' 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_euler = 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) { - # 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", - 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//data-summary.R @@ -3845,38 +3428,25 @@ footer_ui <- function(i18n) { #' #' @export generate_colors <- function(n, palette = "viridis", ...) { - if (!is.numeric(n) || - length(n) != 1 || n < 1 || n != as.integer(n)) { + + # --- Input validation ------------------------------------------------------- + if (!is.numeric(n) || length(n) != 1 || n < 1 || n %% 1 != 0) { 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 — call directly with n and ... + # --- Function passthrough --------------------------------------------------- if (is.function(palette)) { return(palette(n, ...)) } - 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.") - } - + # --- Named palette dispatch ------------------------------------------------- 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, ...) @@ -3896,35 +3466,42 @@ 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 { - 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) + # 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") + } + } } } @@ -4957,7 +4534,7 @@ apply_idea_filter <- function(filtered_reactive, df_target, env = parent.frame() #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R ######## -hosted_version <- function()'v26.4.2-260410' +hosted_version <- function()'v26.6.1' ######## @@ -6971,14 +6548,14 @@ plot_bar <- function(data, 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, - ...) + y.axis.percentage = TRUE) } @@ -7099,11 +6676,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)}"))) } @@ -7297,7 +6874,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") + @@ -7340,13 +6917,15 @@ 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, + ... ) } @@ -7399,7 +6978,7 @@ 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)) { + if (isTRUE(reverse) | reverse=="TRUE") { colors <- rev(colors) } @@ -7456,7 +7035,8 @@ plot_likert <- function(data, pri, sec = NULL, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -7633,7 +7213,8 @@ 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 { @@ -7867,7 +7448,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, @@ -7904,7 +7485,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 { @@ -7919,7 +7500,8 @@ 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) }) @@ -8065,6 +7647,890 @@ 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 ######## @@ -12003,7 +12469,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -12450,7 +12916,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/", + href = "https://freesearchr.github.io/FreesearchR-knowledge/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank",