From 4213487a77b5ec0d7f0849703340fe61246c0cd1 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 2 Apr 2026 10:10:40 +0200 Subject: [PATCH 01/17] v26.4.1 ready --- R/hosted_version.R | 2 +- app_docker/app.R | 202 ++++++++++++--------- app_docker/translations/translation_da.csv | 5 +- app_docker/translations/translation_sw.csv | 5 +- inst/apps/FreesearchR/app.R | 202 ++++++++++++--------- 5 files changed, 245 insertions(+), 171 deletions(-) diff --git a/R/hosted_version.R b/R/hosted_version.R index 608d59ed..6e001f53 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.1-260401' +hosted_version <- function()'v26.4.1-260402' diff --git a/app_docker/app.R b/app_docker/app.R index a2b1dc19..fe1bceb3 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpRQAQCo/file4ab639355bd6.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmlTuE8/file8be05102425f.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.3.6' +app_version <- function()'26.4.1' ######## @@ -2157,7 +2157,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_plot", title = "Create plot", - icon = bsicons::bs_icon("graph-up"), + icon = phosphoricons::ph("chart-line"), + # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -2174,7 +2175,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = shiny::icon("palette"), + icon = phosphoricons::ph("paint-brush"), + # icon = shiny::icon("palette"), disabled = FALSE ), shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) @@ -2182,7 +2184,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = bsicons::bs_icon("download"), + icon = phosphoricons::ph("download-simple"), + # icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -2221,7 +2224,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -3280,21 +3284,29 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "factor")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - shiny::icon("clock") + phosphoricons::ph("clock") + # shiny::icon("clock") } else { - shiny::icon("table") + phosphoricons::ph("calendar") + # shiny::icon("table") }} } @@ -3313,21 +3325,29 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "categorical")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (identical(x,"id")) { - shiny::icon("id-card") + phosphoricons::ph("identification-badge") + # shiny::icon("id-card") } else { - shiny::icon("table") + phosphoricons::ph("table") + # shiny::icon("table") } } } @@ -4925,7 +4945,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.3.6-260331' +hosted_version <- function()'v26.4.1-260402' ######## @@ -6137,20 +6157,6 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", - # Introduction text - # div( - # class = "row mb-5", - # div( - # class = "col-12 text-center", - # p( - # class = "lead", - # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), - # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), - # style = "font-size: 1.2rem; color: #555;" - # ) - # ) - # ), - # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -6168,7 +6174,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("file-import") + phosphoricons::ph("folder-simple-plus", weight = "bold") + # fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6189,7 +6196,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("pen-to-square") + phosphoricons::ph("note-pencil", weight = "bold") + # fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6210,7 +6218,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("magnifying-glass-chart") + phosphoricons::ph("magnifying-glass", weight = "bold") + # fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6235,7 +6244,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -6247,7 +6256,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -6264,7 +6273,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( @@ -6554,7 +6563,8 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = bsicons::bs_icon("gear"), + icon = phosphoricons::ph("gear"), + # icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -6571,14 +6581,16 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = phosphoricons::ph("download-simple") + # icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -7933,7 +7945,8 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) } @@ -8071,7 +8084,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = shiny::icon("link", lib = "glyphicon"), + icon = phosphoricons::ph("link",weight = "bold"), + # icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8127,7 +8141,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = shiny::icon("filter"), + label = phosphoricons::ph("funnel",weight = "bold"), + # label = shiny::icon("filter"), width = "50px" ), filter_ui @@ -8146,7 +8161,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = shiny::icon("download", lib = "glyphicon"), + icon = phosphoricons::ph("download-simple",weight = "bold"), + # icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -10141,7 +10157,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = bsicons::bs_icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -10175,7 +10192,8 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = bsicons::bs_icon("pencil"), + icon = phosphoricons::ph("math-operations"), + # icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -10220,7 +10238,8 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = bsicons::bs_icon("bar-chart-steps"), + icon = phosphoricons::ph("chart-bar-horizontal"), + # icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -10263,7 +10282,8 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ) @@ -10284,7 +10304,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = bsicons::bs_icon("clipboard-check"), + icon = phosphoricons::ph("checks"), + # icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -11428,7 +11449,8 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) } else { # Return NULL to show nothing @@ -11719,7 +11741,8 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = shiny::icon("house"), + icon = phosphoricons::ph("house", weight = "bold"), + # icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -11749,7 +11772,8 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = shiny::icon("play"), + icon = phosphoricons::ph("play", weight = "bold"), + # icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -11826,7 +11850,8 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = shiny::icon("binoculars"), + icon = phosphoricons::ph("binoculars"), + # icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -11870,7 +11895,8 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = shiny::icon("play"), + icon = phosphoricons::ph("play"), + # icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -11889,11 +11915,13 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = shiny::icon("pen-to-square"), + icon = phosphoricons::ph("note-pencil", weight = "bold"), + # icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = shiny::icon("eye"), + icon = phosphoricons::ph("eye"), + # icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -11968,7 +11996,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = shiny::icon("file-pen"), + icon = phosphoricons::ph("pencil-line"), + # icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -11997,13 +12026,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor levels"), + label = i18n$t("Modify factor"), width = "100%" ), shiny::tags$br(), - shiny::helpText( - i18n$t("Reorder or rename the levels of factor/categorical variables.") - ), + shiny::helpText(i18n$t( + "Modify the levels of factor/categorical variables." + )), shiny::tags$br(), shiny::tags$br() ), @@ -12016,9 +12045,7 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t( - "Create factor/categorical variable from a continous variable (number/date/time)." - ) + i18n$t("Create factor/categorical variable from other variables.") ), shiny::tags$br(), shiny::tags$br() @@ -12095,14 +12122,16 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = shiny::icon("magnifying-glass-chart"), + icon = phosphoricons::ph("magnifying-glass", weight = "bold"), + # icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12114,7 +12143,8 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -12156,7 +12186,8 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -12170,7 +12201,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = bsicons::bs_icon("bounding-box"), + icon = phosphoricons::ph("graph"), + # icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12211,7 +12243,8 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = bsicons::bs_icon("x-circle") + icon = phosphoricons::ph("placeholder") + # icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -12226,7 +12259,8 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = shiny::icon("chart-line"), + icon = phosphoricons::ph("chart-line", weight = "bold"), + # icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -12247,7 +12281,8 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator", weight = "bold"), + # icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -12259,7 +12294,8 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = shiny::icon("download"), + icon = phosphoricons::ph("download-simple", weight = "bold"), + # icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -12295,7 +12331,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -12325,7 +12362,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -12459,7 +12497,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 4f3752bd..2240bc2c 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -260,7 +260,6 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR er tilgængelig på flere sprog. For at få hjælp med oversættelser, kontakt os venligst på info@freesearchr.org" "Home","Hjem" "Start with FreesearchR for basic data evaluation and analysis.","Start med FreesearchR til grundlæggende dataevaluering og -analyse." -"When you need more advanced tools, you'll be better prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være bedre forberedt på at bruge R direkte." "(Read more)","(Læs mere)" "Run the FreesearchR app locally when working with sensitive data.","Kør FreesearchR-appen lokalt, når du arbejder med følsomme data." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Indlæs data fra regneark, REDCap-servere, eller prøv med eksempeldata. Flere kilder understøttes for maksimal fleksibilitet." @@ -271,8 +270,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Når du har brug for mere avancerede værktøjer, vil du være forberedt på at bruge R direkte." "The app contains a selelct number of features and will guide you through key analyses.","Appen indeholder udvalgte funktioner, og guider dig gennem de vigtigste analyser." "Sort by Levels","Sorter efter niveauer" -"Modify factor levels","Ændr kategoriske niveauer" -"Reorder or rename the levels of factor/categorical variables.","Ændr navn eller rækkefølge på kategorisk variabel." "Maximum number of observations:","Maximale antal observationer:" "setting to 0 includes all","angiv 0 for at inkludere alle" "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." @@ -321,3 +318,5 @@ "An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." "An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." "Likert diagram","Likert diagram" +"Modify factor","Modify factor" +"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index a375e0a5..7866710e 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -260,7 +260,6 @@ "FreesearchR is available in multiple languages. To help with translations, please contact us at info@freesearchr.org","FreesearchR inapatikana katika lugha nyingi. Ili kukusaidia na tafsiri, tafadhali wasiliana nasi kwa info@freesearchr.org." "Home","Nyumbani" "Start with FreesearchR for basic data evaluation and analysis.","Anza na FreesearchR kwa tathmini na uchambuzi wa data ya msingi." -"When you need more advanced tools, you'll be better prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari zaidi kutumia R moja kwa moja." "(Read more)","(Soma zaidi)" "Run the FreesearchR app locally when working with sensitive data.","Endesha programu ya FreesearchR ndani ya eneo lako unapofanya kazi na data nyeti." "Load data from spreadsheets, REDCap servers, or try with sample data. Multiple sources supported for maximum flexibility.","Pakia data kutoka kwa lahajedwali, seva za REDCap, au jaribu na data ya sampuli. Vyanzo vingi vinaungwa mkono kwa unyumbufu wa hali ya juu." @@ -271,8 +270,6 @@ "When you need more advanced tools, you'll be prepared to use R directly.","Unapohitaji zana za hali ya juu zaidi, utakuwa tayari kutumia R moja kwa moja." "The app contains a selelct number of features and will guide you through key analyses.","The app contains a selelct number of features and will guide you through key analyses." "Sort by Levels","Sort by Levels" -"Modify factor levels","Modify factor levels" -"Reorder or rename the levels of factor/categorical variables.","Reorder or rename the levels of factor/categorical variables." "Maximum number of observations:","Maximum number of observations:" "setting to 0 includes all","setting to 0 includes all" "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." @@ -321,3 +318,5 @@ "An empty data set was imported. Please review data filter.","An empty data set was imported. Please review data filter." "An error was encountered exporting data. Please review data filter.","An error was encountered exporting data. Please review data filter." "Likert diagram","Likert diagram" +"Modify factor","Modify factor" +"Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index e64d7b30..66df2775 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//RtmpRQAQCo/file4ab61747a8d7.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmlTuE8/file8be0207bfdc2.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.3.6' +app_version <- function()'26.4.1' ######## @@ -2157,7 +2157,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_plot", title = "Create plot", - icon = bsicons::bs_icon("graph-up"), + icon = phosphoricons::ph("chart-line"), + # icon = bsicons::bs_icon("graph-up"), shiny::uiOutput(outputId = ns("primary")), shiny::helpText( i18n$t( @@ -2174,7 +2175,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = shiny::icon("palette"), + icon = phosphoricons::ph("paint-brush"), + # icon = shiny::icon("palette"), disabled = FALSE ), shiny::helpText(i18n$t('Adjust settings, then press "Plot".')) @@ -2182,7 +2184,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { bslib::accordion_panel( value = "acc_pan_download", title = "Download", - icon = bsicons::bs_icon("download"), + icon = phosphoricons::ph("download-simple"), + # icon = bsicons::bs_icon("download"), shinyWidgets::noUiSliderInput( inputId = ns("height_slide"), label = i18n$t("Plot height (mm)"), @@ -2221,7 +2224,8 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -3280,21 +3284,29 @@ class_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "numeric")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "factor")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "logical")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (any(c("Date", "POSIXt") %in% x)) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (any("POSIXct", "hms") %in% x) { - shiny::icon("clock") + phosphoricons::ph("clock") + # shiny::icon("clock") } else { - shiny::icon("table") + phosphoricons::ph("calendar") + # shiny::icon("table") }} } @@ -3313,21 +3325,29 @@ type_icons <- function(x) { lapply(x,class_icons) } else { if (identical(x, "continuous")) { - shiny::icon("calculator") + phosphoricons::ph("calculator") + # shiny::icon("calculator") } else if (identical(x, "categorical")) { - shiny::icon("chart-simple") + phosphoricons::ph("chart-bar") + # shiny::icon("chart-simple") } else if (identical(x, "ordinal")) { - shiny::icon("arrow-down-1-9") + phosphoricons::ph("list-numbers") + # shiny::icon("arrow-down-1-9") } else if (identical(x, "text")) { - shiny::icon("arrow-down-a-z") + phosphoricons::ph("text-aa") + # shiny::icon("arrow-down-a-z") } else if (identical(x, "dichotomous")) { - shiny::icon("toggle-off") + phosphoricons::ph("toggle-left") + # shiny::icon("toggle-off") } else if (identical(x,"datetime")) { - shiny::icon("calendar-days") + phosphoricons::ph("calendar") + # shiny::icon("calendar-days") } else if (identical(x,"id")) { - shiny::icon("id-card") + phosphoricons::ph("identification-badge") + # shiny::icon("id-card") } else { - shiny::icon("table") + phosphoricons::ph("table") + # shiny::icon("table") } } } @@ -4925,7 +4945,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.3.6-260331' +hosted_version <- function()'v26.4.1-260402' ######## @@ -6137,20 +6157,6 @@ landing_page_ui <- function(i18n) { div( class = "container my-5", - # Introduction text - # div( - # class = "row mb-5", - # div( - # class = "col-12 text-center", - # p( - # class = "lead", - # i18n$t("Start with FreesearchR for basic data evaluation and analysis."), - # i18n$t("When you need more advanced tools, you'll be better prepared to use R directly."), - # style = "font-size: 1.2rem; color: #555;" - # ) - # ) - # ), - # Core Features Section h2(i18n$t("Core Features"), class = "text-center mb-4", style = "color: #1E4A8F; font-weight: 600;"), @@ -6168,7 +6174,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("file-import") + phosphoricons::ph("folder-simple-plus", weight = "bold") + # fa("file-import") ), h4(i18n$t("Import Data"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6189,7 +6196,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("pen-to-square") + phosphoricons::ph("note-pencil", weight = "bold") + # fa("pen-to-square") ), h4(i18n$t("Data Management"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6210,7 +6218,8 @@ landing_page_ui <- function(i18n) { class = "card-body text-center p-4", div( style = "font-size: 3rem; color: #1E4A8F; margin-bottom: 15px;", - fa("magnifying-glass-chart") + phosphoricons::ph("magnifying-glass", weight = "bold") + # fa("magnifying-glass-chart") ), h4(i18n$t("Descriptive Statistics"), class = "card-title", style = "color: #2D2D42; font-weight: 600;"), p( @@ -6235,7 +6244,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("chart-line"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("chart-line", weight = "bold"), " ", i18n$t("Data Visualization"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Create simple, clean plots for quick insights and overview")) ) ) @@ -6247,7 +6256,7 @@ landing_page_ui <- function(i18n) { style = "border-left: 4px solid #8A4FFF;", div( class = "card-body", - h5(fa("calculator"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), + h5(phosphoricons::ph("calculator", weight = "bold"), " ", i18n$t("Regression Models"), class = "card-title", style = "color: #2D2D42;"), p(class = "card-text small", i18n$t("Build simple regression models for advanced analysis")) ) ) @@ -6264,7 +6273,7 @@ landing_page_ui <- function(i18n) { style = "background: linear-gradient(135deg, #f5f7fa 0%, #c3cfe2 100%); border: none;", div( class = "card-body p-4", - h4(fa("download"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), + h4(phosphoricons::ph("book-bookmark", weight = "bold"), " ", i18n$t("Export & Learn"), class = "text-center mb-3", style = "color: #1E4A8F;"), div( class = "row text-center", div( @@ -6554,7 +6563,8 @@ data_missings_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_mis", title = "Settings", - icon = bsicons::bs_icon("gear"), + icon = phosphoricons::ph("gear"), + # icon = bsicons::bs_icon("gear"), shiny::conditionalPanel( condition = "output.missings == true", shiny::uiOutput(ns("missings_method")), @@ -6571,14 +6581,16 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ) ), do.call(bslib::accordion_panel, c( list( title = "Download", - icon = bsicons::bs_icon("file-earmark-arrow-down") + icon = phosphoricons::ph("download-simple") + # icon = bsicons::bs_icon("file-earmark-arrow-down") ), table_download_ui(id = ns("tbl_dwn"), title = NULL) )) @@ -7933,7 +7945,8 @@ plot_download_ui <- regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = "Download plot", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) } @@ -8071,7 +8084,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_connect"), label = i18n$t("Connect"), - icon = shiny::icon("link", lib = "glyphicon"), + icon = phosphoricons::ph("link",weight = "bold"), + # icon = shiny::icon("link", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -8127,7 +8141,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shinyWidgets::dropMenu( shiny::actionButton( inputId = ns("dropdown_params"), - label = shiny::icon("filter"), + label = phosphoricons::ph("funnel",weight = "bold"), + # label = shiny::icon("filter"), width = "50px" ), filter_ui @@ -8146,7 +8161,8 @@ m_redcap_readUI <- function(id, title = TRUE, url = NULL) { shiny::actionButton( inputId = ns("data_import"), label = i18n$t("Import"), - icon = shiny::icon("download", lib = "glyphicon"), + icon = phosphoricons::ph("download-simple",weight = "bold"), + # icon = shiny::icon("download", lib = "glyphicon"), width = "100%", disabled = TRUE ), @@ -10141,7 +10157,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_reg", title = i18n$t("Regression"), - icon = bsicons::bs_icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = bsicons::bs_icon("calculator"), shiny::uiOutput(outputId = ns("outcome_var")), # shiny::selectInput( # inputId = "design", @@ -10175,7 +10192,8 @@ regression_ui <- function(id, ...) { bslib::input_task_button( id = ns("load"), label = i18n$t("Analyse"), - icon = bsicons::bs_icon("pencil"), + icon = phosphoricons::ph("math-operations"), + # icon = bsicons::bs_icon("pencil"), label_busy = i18n$t("Working..."), icon_busy = fontawesome::fa_i("arrows-rotate", class = "fa-spin", @@ -10220,7 +10238,8 @@ regression_ui <- function(id, ...) { list( value = "acc_pan_coef_plot", title = "Coefficients plot", - icon = bsicons::bs_icon("bar-chart-steps"), + icon = phosphoricons::ph("chart-bar-horizontal"), + # icon = bsicons::bs_icon("bar-chart-steps"), shiny::tags$br(), shiny::uiOutput(outputId = ns("plot_model")) ), @@ -10263,7 +10282,8 @@ regression_ui <- function(id, ...) { shiny::downloadButton( outputId = ns("download_plot"), label = i18n$t("Download plot"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ) @@ -10284,7 +10304,8 @@ regression_ui <- function(id, ...) { bslib::accordion_panel( value = "acc_pan_checks", title = "Checks", - icon = bsicons::bs_icon("clipboard-check"), + icon = phosphoricons::ph("checks"), + # icon = bsicons::bs_icon("clipboard-check"), shiny::uiOutput(outputId = ns("plot_checks")) ) ) @@ -11428,7 +11449,8 @@ table_download_server <- function(id, data, file_name = "table", ...) { shiny::downloadButton( outputId = ns("act_table"), label = i18n$t("Download table"), - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) } else { # Return NULL to show nothing @@ -11719,7 +11741,8 @@ ui_elements <- function(selection) { "home" = bslib::nav_panel( title = "FreesearchR", # title = shiny::div(htmltools::img(src="FreesearchR-logo-white-nobg-h80.png")), - icon = shiny::icon("house"), + icon = phosphoricons::ph("house", weight = "bold"), + # icon = shiny::icon("house"), shiny::fluidRow( # "The browser language is", # textOutput("your_lang"), @@ -11749,7 +11772,8 @@ ui_elements <- function(selection) { ############################################################################## "import" = bslib::nav_panel( title = i18n$t("Get started"), - icon = shiny::icon("play"), + icon = phosphoricons::ph("play", weight = "bold"), + # icon = shiny::icon("play"), value = "nav_import", shiny::fluidRow( shiny::column(width = 2), @@ -11826,7 +11850,8 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = shiny::icon("binoculars"), + icon = phosphoricons::ph("binoculars"), + # icon = shiny::icon("binoculars"), disabled = FALSE ), shiny::br(), @@ -11870,7 +11895,8 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = shiny::icon("play"), + icon = phosphoricons::ph("play"), + # icon = shiny::icon("play"), disabled = TRUE ), shiny::br(), @@ -11889,11 +11915,13 @@ ui_elements <- function(selection) { ############################################################################## "prepare" = bslib::nav_menu( title = i18n$t("Prepare"), - icon = shiny::icon("pen-to-square"), + icon = phosphoricons::ph("note-pencil", weight = "bold"), + # icon = shiny::icon("pen-to-square"), value = "nav_prepare", bslib::nav_panel( title = i18n$t("Overview and filter"), - icon = shiny::icon("eye"), + icon = phosphoricons::ph("eye"), + # icon = shiny::icon("eye"), value = "nav_prepare_overview", tags$h3(i18n$t("Overview and filtering")), fluidRow( @@ -11968,7 +11996,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Edit and create data"), - icon = shiny::icon("file-pen"), + icon = phosphoricons::ph("pencil-line"), + # icon = shiny::icon("file-pen"), tags$h3(i18n$t("Subset, rename and convert variables")), fluidRow(shiny::column( width = 9, shiny::tags$p( @@ -11997,13 +12026,13 @@ ui_elements <- function(selection) { width = 3, shiny::actionButton( inputId = "modal_update", - label = i18n$t("Modify factor levels"), + label = i18n$t("Modify factor"), width = "100%" ), shiny::tags$br(), - shiny::helpText( - i18n$t("Reorder or rename the levels of factor/categorical variables.") - ), + shiny::helpText(i18n$t( + "Modify the levels of factor/categorical variables." + )), shiny::tags$br(), shiny::tags$br() ), @@ -12016,9 +12045,7 @@ ui_elements <- function(selection) { ), shiny::tags$br(), shiny::helpText( - i18n$t( - "Create factor/categorical variable from a continous variable (number/date/time)." - ) + i18n$t("Create factor/categorical variable from other variables.") ), shiny::tags$br(), shiny::tags$br() @@ -12095,14 +12122,16 @@ ui_elements <- function(selection) { "describe" = bslib::nav_menu( title = i18n$t("Evaluate"), - icon = shiny::icon("magnifying-glass-chart"), + icon = phosphoricons::ph("magnifying-glass", weight = "bold"), + # icon = shiny::icon("magnifying-glass-chart"), value = "nav_describe", # id = "navdescribe", # bslib::navset_bar( # title = "", bslib::nav_panel( title = i18n$t("Characteristics"), - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), bslib::layout_sidebar( sidebar = bslib::sidebar( shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12114,7 +12143,8 @@ ui_elements <- function(selection) { open = TRUE, value = "acc_pan_chars", title = "Settings", - icon = bsicons::bs_icon("table"), + icon = phosphoricons::ph("table"), + # icon = bsicons::bs_icon("table"), # vectorSelectInput( # inputId = "baseline_theme", # selected = "none", @@ -12156,7 +12186,8 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator"), + # icon = shiny::icon("calculator"), disabled = TRUE ), shiny::helpText(i18n$t( @@ -12170,7 +12201,8 @@ ui_elements <- function(selection) { ), bslib::nav_panel( title = i18n$t("Correlations"), - icon = bsicons::bs_icon("bounding-box"), + icon = phosphoricons::ph("graph"), + # icon = bsicons::bs_icon("bounding-box"), bslib::layout_sidebar( sidebar = bslib::sidebar( # shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), @@ -12211,7 +12243,8 @@ ui_elements <- function(selection) { do.call(bslib::nav_panel, c( list( title = i18n$t("Missings"), - icon = bsicons::bs_icon("x-circle") + icon = phosphoricons::ph("placeholder") + # icon = bsicons::bs_icon("x-circle") ), data_missings_ui(id = "missingness", validation_ui("validation_mcar")) )) @@ -12226,7 +12259,8 @@ ui_elements <- function(selection) { c( list( title = i18n$t("Visuals"), - icon = shiny::icon("chart-line"), + icon = phosphoricons::ph("chart-line", weight = "bold"), + # icon = shiny::icon("chart-line"), value = "nav_visuals" ), data_visuals_ui("visuals") @@ -12247,7 +12281,8 @@ ui_elements <- function(selection) { "analyze" = bslib::nav_panel( title = i18n$t("Regression"), - icon = shiny::icon("calculator"), + icon = phosphoricons::ph("calculator", weight = "bold"), + # icon = shiny::icon("calculator"), value = "nav_analyses", do.call(bslib::navset_card_tab, regression_ui("regression")) ), @@ -12259,7 +12294,8 @@ ui_elements <- function(selection) { "download" = bslib::nav_panel( title = i18n$t("Download"), - icon = shiny::icon("download"), + icon = phosphoricons::ph("download-simple", weight = "bold"), + # icon = shiny::icon("download"), value = "nav_download", shiny::fluidRow( shiny::column(width = 2), @@ -12295,7 +12331,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "report", label = "Download report", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ), shiny::br() # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), @@ -12325,7 +12362,8 @@ ui_elements <- function(selection) { shiny::downloadButton( outputId = "data_modified", label = "Download data", - icon = shiny::icon("download") + icon = phosphoricons::ph("arrow-fat-down") + # icon = shiny::icon("download") ) ) ), @@ -12459,7 +12497,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("sort-ascending"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) From 1e19486af1392eb35d57ff1705babb6336659d81 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:03:47 +0200 Subject: [PATCH 02/17] feat: revised color palette selection --- R/generate_colors.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/generate_colors.R b/R/generate_colors.R index 898c0a94..d7a7cc82 100644 --- a/R/generate_colors.R +++ b/R/generate_colors.R @@ -254,12 +254,12 @@ color_choices <- function() { "Perceptual (blue-yellow)" = "viridis", "Perceptual (fire)" = "plasma", "Colour-blind friendly" = "Okabe-Ito", - "Qualitative (bold)" = "Dark 2", - "Qualitative (paired)" = "Paired", - "Sequential (blues)" = "Blues", + "Diverging (red-yellow-green)"= "RdYlGn", "Diverging (red-blue)" = "RdBu", - "Tableau style" = "Tableau 10", - "Pastel" = "Pastel 1", - "Rainbow" = "rainbow" + "Sequential (blues)" = "Blues", + "Qualitative (paired)" = "Paired", + "Qualitative (bold)" = "Dark 2", + "Rainbow" = "Spectral", + "Generic" = "Set1" ) } From b2745f5628b182cbc0fc1a9d6eff802dc9d28475 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:04:20 +0200 Subject: [PATCH 03/17] feat: default to 5 preview colors --- R/data_plots.R | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index bc1995e6..a01403df 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -38,7 +38,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = phosphoricons::ph("paint-brush"), + icon = phosphoricons::ph("paint-brush",weight = "bold"), # icon = shiny::icon("palette"), disabled = FALSE ), @@ -243,7 +243,8 @@ data_visuals_server <- function(id, colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes + choices = palettes, + previews = 5 ) }) @@ -721,6 +722,7 @@ wrap_plot_list <- function(data, guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ...) { if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { @@ -734,7 +736,7 @@ wrap_plot_list <- function(data, .x } })() |> - align_axes() |> + align_axes(percentage=y.axis.percentage) |> patchwork::wrap_plots(guides = guides, axes = axes, axis_titles = axis_titles, @@ -779,7 +781,8 @@ wrap_plot_list <- function(data, #' align_axes <- function(..., x.axis = TRUE, - y.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)) { @@ -797,7 +800,7 @@ align_axes <- function(..., xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x) { + p_out <- purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -808,6 +811,15 @@ align_axes <- function(..., out }) }) + + if(isTRUE(percentage)){ + lapply(p_out,\(.x){ + .x+ + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } } #' Extract and clean axis ranges From af4e21b836d2ab0f423877a47c76ab0d51a5f42d Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:04:42 +0200 Subject: [PATCH 04/17] revised ui --- CITATION.cff | 2 +- DESCRIPTION | 2 +- NAMESPACE | 1 + NEWS.md | 4 ++ R/app_version.R | 2 +- R/create-column-mod.R | 4 +- R/cut-variable-ext.R | 2 +- R/hosted_version.R | 2 +- R/import-file-ext.R | 4 +- R/missings-module.R | 2 +- R/plot_bar.R | 90 ++++++++++++++++----------- R/separate_string.R | 2 +- R/sysdata.rda | Bin 2692 -> 2691 bytes R/ui_elements.R | 6 +- R/update-factor-ext.R | 8 +-- R/update-variables-ext.R | 4 +- SESSION.md | 9 ++- inst/translations/translation_da.csv | 2 +- inst/translations/translation_sw.csv | 2 +- man/align_axes.Rd | 2 +- man/data-plots.Rd | 23 +++++++ man/wrap_plot_list.Rd | 1 + 22 files changed, 110 insertions(+), 64 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 8629fb7c..86c9ebe0 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.1 +version: 26.4.2 doi: 10.5281/zenodo.14527429 identifiers: - type: url diff --git a/DESCRIPTION b/DESCRIPTION index 89673630..69564bc2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.4.1 +Version: 26.4.2 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), diff --git a/NAMESPACE b/NAMESPACE index 9ede131b..9e036c3f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -116,6 +116,7 @@ export(modify_qmd) export(names2val) export(overview_vars) export(pipe_string) +export(plot_bar) export(plot_bar_single) export(plot_box) export(plot_box_single) diff --git a/NEWS.md b/NEWS.md index fbff9355..785ee46a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.4.2 + +Bug fixes and revised color choices. + # FreesearchR 26.4.1 Minor adjustments and bug fixes including streamlining icon use to only use phosphoricons across the app. diff --git a/R/app_version.R b/R/app_version.R index 4f474ec7..2cbd2cc4 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.4.1' +app_version <- function()'26.4.2' diff --git a/R/create-column-mod.R b/R/create-column-mod.R index c2b6d403..6047aa33 100644 --- a/R/create-column-mod.R +++ b/R/create-column-mod.R @@ -76,7 +76,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil"), i18n$t("Create column") + phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -84,7 +84,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle"), + phosphoricons::ph("x-circle",weight = "bold"), i18n$t("Cancel") ), class = "btn-outline-danger", diff --git a/R/cut-variable-ext.R b/R/cut-variable-ext.R index b7d8eb80..84418736 100644 --- a/R/cut-variable-ext.R +++ b/R/cut-variable-ext.R @@ -64,7 +64,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") diff --git a/R/hosted_version.R b/R/hosted_version.R index 6e001f53..33aaf67c 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.1-260402' +hosted_version <- function()'v26.4.2-260410' diff --git a/R/import-file-ext.R b/R/import-file-ext.R index 709a55c1..6d78e381 100644 --- a/R/import-file-ext.R +++ b/R/import-file-ext.R @@ -714,7 +714,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -725,7 +725,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), diff --git a/R/missings-module.R b/R/missings-module.R index bb247b18..eeb46edd 100644 --- a/R/missings-module.R +++ b/R/missings-module.R @@ -37,7 +37,7 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ) diff --git a/R/plot_bar.R b/R/plot_bar.R index f820cc6b..0535b6f3 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -1,5 +1,29 @@ -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), - color.palette = "viridis", max_level = 30, ...) { +#' Title +#' +#' @name data-plots +#' +#' @param style barplot style passed to geom_bar position argument. +#' One of c("stack", "dodge", "fill") +#' +#' @returns ggplot list object +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> +#' plot_bar(pri = "cyl", sec = "am", style = "fill") +#' +#' mtcars |> +#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> +#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") +plot_bar <- function(data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -8,7 +32,7 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ds <- list(data) } - out <- lapply(ds, \(.ds){ + out <- lapply(ds, \(.ds) { plot_bar_single( data = .ds, pri = pri, @@ -19,7 +43,10 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ) }) - 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)}")), + y.axis.percentage = TRUE, + ...) } @@ -41,7 +68,11 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, +plot_bar_single <- function(data, + pri, + sec = NULL, + style = c("stack", "dodge", "fill"), + max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -51,16 +82,11 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data) - ) + p = Freq / NROW(data)) if (nrow(p_data) > max_level) { - p_data <- sort_by( - p_data, - p_data[["Freq"]], - decreasing = TRUE - ) |> + p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> head(max_level) } @@ -73,39 +99,31 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " fill <- pri } - p <- ggplot2::ggplot( - p_data, - ggplot2::aes( - x = .data[[pri]], - y = p, - fill = .data[[fill]] - ) - ) + + p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + ggplot2::geom_bar(position = style, stat = "identity") + - ggplot2::scale_y_continuous(labels = scales::percent) + - scale_fill_generate(palette=color.palette) + - ggplot2::ylab("Percentage") + - ggplot2::xlab(get_label(data,pri))+ - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) + scale_fill_generate(palette = color.palette) + + ggplot2::xlab(get_label(data, pri)) + + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | + any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, hjust = 1 - ))+ - ggplot2::theme( - axis.text.x = ggplot2::element_text(vjust = 0.5) - ) + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, + hjust = 1 + )) + + ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) - if (is.null(sec)){ + if (is.null(sec)) { p <- p + ggplot2::guides(fill = "none") } } - p + p + + ggplot2::scale_y_continuous(labels = scales::percent) + + ggplot2::ylab("Percentage") } diff --git a/R/separate_string.R b/R/separate_string.R index 0aa64e6c..61063b53 100644 --- a/R/separate_string.R +++ b/R/separate_string.R @@ -50,7 +50,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") diff --git a/R/sysdata.rda b/R/sysdata.rda index 443516d108cdaf03bb65689d76c67b6317ae4443..c56ca282b6b07bc77e3fda961193f62c47cf5e58 100644 GIT binary patch literal 2691 zcmV-}3ViiKT4*^jL0KkKS*kVc=KvXSf5iX)cm+a#|KNXb-@w2B|L{Nn03Zkf;0xau z5Q`53f~h(HbSN*McmYX$14;u^2oTYr2u~!`+5(Nf2j75h{%rqecelQ|E%A~d;b5AJcs<3w{OgNTpvXK zGE}l--wQtPb<&_+O%T3(j`F;L6-`=%fh8|197)z)Vzumja1Bva$&`Ch+xd- zR8XR2W46RXe}r!4D^n8oDQ@J`nwX@jjMgo=1ZBfwBE0WYlf~m6bdOK7>-WQ#4I?6M zS{~-%b+=xPz{VukH3m=2IqnG;#GoAZiO#97-|*Wjx6pi|o*e^XM;WIqv%?l|)Z-tN zX+;I_DXFTHu6G|2_(mYH>8UjJx?61xTMZ06w4o_+@GGzQwl`pJ7I1JzSocBo zXO1(}f?gb#nYdxvt>wJSvt8Z#xUI5d^6jd0asDi9fMj(oc0Hje6P*G8ctX3*1+u7#y&j%G$ z@y|^e7sAw&Zf~!S-yaxg;HV2Zw5o`l?&hod#@8i(9jUlLka-2gpldc46+KR zF}tZ#B+`{C>=Q^!NQi`yXd;&BITmK+5Xrp6w8U18ObZv+|cXst?;;Y`qGU5eftS5zq zsN&Yvxg?TOBLP#;V3XW^%zWgkjBo_9!qF(Cu_k52Dkt?J4Cn=rgCGQ8c$orrvPgAg zkl8#*iHtn9Lb1wEGt17hotay3$|m&Ti!@RVs-cN(3aph7JJY=wQ%u$n)c0K&Lf*{8 znGr~#F)=dP@Zm)d1@90O#MlEF0ahS{>(?+0EfxiqgFTuUZ`s+Wv68FbPbCZ6+u`mB zqSlQ{*JL0#gOb9sjHroPF$V^qG{Gli20hzY1Y6!1W5QXrdXamat(s zES5smmJ(VN2@d6fNJ)Ix@$Y1d2=`c9V0anLaZ<5aeQdyBD5Iva3N4{cF+2CjU{)hP zr7uV*Coc($l%I3O)=oCiruT71NT8(4NF^k7a8NCP;z0&A!$;$O%9ckAD+ZIhy_UkI zZ7QoQfGA4BMF`1~LKCK}non0LkDi>SwaZ1S($%Gj2`NFq#X*QYzq82ak9VINnrTG6 z4z#tZQKed2MR9^xyw41@*A{jqQkv-kO&B0suvLAd%%EUD3!RMi+qG(Cs4}vv6hQOZ~K_m=ll8e;$67q?j)C;eo%` zR^;WU7VtDg>69#Yo4P3&GKkTNMOw>$mTRE}Dg>vQTG$+iZTCzcq+pebI_yMTZ`l_w z9~rX}-XG2h=fUn}uGNXLQ7-|G5W1|fMWACM=U!SAHV#7uRJ~CQ-2@F%I&5?xH zbO=4u5DzClJ;?>c;!@FDt>nWlfJi$I@=BT*epPz7g|4B#nb#&K9W{oC_nu}9mT-s^ z+A^3>_h5cFMx=k(g?r|rjyl<3q{MoB102Hvp2{4u7y-k9q!_qJz8_Xj)qX(XazF6#-pCtG0$WKvHZ#H<6XWi5HJ-JPq!L2%d z#(=#S2|O$hPq|QXBD5h07+(8QqAbkFy$7NTj!Z5;IR(bMVz`a|bD)F`QP;ofs2>aj zNvfXOXPK{?eZ?jYL^dLe+a`9C3=?QZSixZVh(Vl*$?Qt!*52>g!x11Z+v$QHa@IBQ3VJTa!ZX`OvSm$+B2 zZ_iVUMJ?k=Nb5~B zz8I~sV7!o2(_{GK0tBJ>OeG;!S-#fOm37%+$^A)LOK@#V2!#j+^S30%pi?rL!~s2m zHW7(JvkPiev=Pf?Q-=&MsSU}4I%dp|YVPly7GP4nxY)<(Ns$QH=jM=gt@bN2!D{g3 zPlGTQuz{O&=~2`$uby67bbQoSLTyd;)v(>aDz)wUqP~dZP356V%HED<&!W3C6y8g6 xYPppojg?UulPDzBX9mF_(JD$TTFbLh_ks107Al1d3OmQ*F64@Ep&?Xj+0M%_{yP8w delta 2691 zcmV-}3Vij06@(RkLRx4!F+o`-Q&|S3)zJVMjsL{||7Zn5fB)crZ{NVb|Nrnn000mO z0pJV&7Z8iM@H`boOo1YS^XJeCOXved@YKZ6LqGxyg*cV8f_DQ$_)&RhCz@G4FQB?0BF$A zNu-ey0i+okXfzK{0MG+X007Vc14009z7Pg5lE0yNOjG-Lxo zpa26CKn#G%l`Q6yJfnz)X^w!p>QqwrBBrjL0xQG!yt1e^u?)`_*Izzmp@1-OZSe3J zqHRSnl3hT5R5BO!XJ-8Ui?YRVKtx7FclW-WYXOLnHUF)w14?oBzVib|->CA7g8P}qon-;w6>b2!gdM>p~F|B%(gILMbA z&tl(gmfVYZj0s$*F@8bMa7ex-0OzQ#x+`z{`0I_kWSpRx$?3qS!qKOWa+L67W^j$%xHz_zTCsAInr2aPwmq{oKyW!I)3E()fK2(YSujVE%#5F!9T!4V7Q0Z8THqInylZv$o^ zqHBtRF;D=3AtAF!h%K!^f+72ep!1-J1=`Y$U&07F8+(R!qN?ga5Yg7hm9e#_my_3{ z6hXpf=Pe{4sv;<;#e&5JK@nhr#UhHah>D^Lu|*hyDkuWTq9CB6qY+rFR8zs}b~xu+ zPkO3eY38FM^0ksZt7 z)He*-inucBmiKmn-0yd6U0cYJWW)@cvvLb69X4R$STMz4P~v|qA)%6NnBkh?cg_~O z=5ND>#@WtCPXip|w)bfyk=qrDf^i5IR<4ahlH71|@)^S?F-4dcr>GRErL=3ij&3-N zb2B(y@>XtzGPTndw4Q(4I?&J%(nAUWw1kl2NP`DTUPkWaOp{7ftFTQWEg~WkMWBjX zq~uwfln4>2fe45ol7U1ub9NrevnnwZE~Jt~jD!njQo7eCB{$rqySlDnzPHPe9*Ly{ zm?YT~P7Ec^9AlTKBUnFRWz?2JT8UNIS?9*wGSryVQ9&f zw+x~=wJ~OjLA6vdD^RM*Q3IeI2*R3Xu!g5~(S$AOIf*PqB80@m%V*Jr6drs5I?aGF zkQHJGPCRn}!qIRd*mLZdoy~VBS*Fl~Oc|R1^Z4l!Yj@*nK^= zBv?nD!rKF;&K1Q5 z+c8m+D3+=ql_RBsgB(*Jh%vS*Z{5RV3~@rqE6?9z*i@~hRb`L`30O#>888V6$5u@z zchS}we01WP*A|OarK?LB2`NFq#bTllh4Aw5-+pG`(xu>WrL9tpD$?33j1s*Da?4F` zXGt#uTrGd9w74NPG>NM#dbe$BYim-AY@#iqkx4sSLubA}9#{}3c>R0ZdcFPgj^02J z1XVgl{P#%0*42(?LNVY(LAPFN4M@DLsLKok zzPZRm6QcPrloy^c->jAC{*tk zZ=8Q#$)h$27OO1&IX5y5DTJ%YtXLd}W!BaY&M!(t-Bltt3$;e$;o(~_EusA&o;#lA zSnU{^l+y1QUkhl*1Z=|z7fNx=p{Q~gGM(*2GjtFuNav~0gN{$0l56M;GaJlwwjF&> z{GtNb-mR6+ieR})BaOqjeo{-aCzW%=5OIG~`c#!d|ISFWGVQj91e36^Sax9XY$4b7 z9g=*{9HvSIk*Ktu8#UK@=w6@0hdbuDg*I&U4_}&0u!Kdxrs`=8+Y@96J=KT@lb;^c zgK#*Mvuf#aFw1x(9cOVR3K)9w*|aip7-t$T@i|k-7$KQjs~2Zl5X-wNg#qry{WO1t zO^5g)&&1p%!%C_Xn2#Rt$utnGPzj!hj04){N4Tx5V;%CfZ22|NH$HC8wHg8qzXnjf zEi$vWavwA%iselwV`e2rnd-Lj6Df5lY{u&6mh>G&GwBzk<(in3UFyoz7E5%*LNtV| zJ11Grx3&ljLdBYtP)DmZ7*9_*LN|X$4vd6qDozHQm5|SW?Rw)|G=izm_nHFoS|sq; z9)IbmIT2V8h9Lc)GB}CkMn&j75L|LX=XFqAcWhS^eYwy=0~}20nV{=HiCbEF=axp_ z75mCe9Dxl;qVcP_y~3S4KAId^ zw6z&f8|&+HZHWsEc?$2u#I1kW&l*P@;?Y!2j^k(Ws~e#@uqcDs$G$DI&2M-5(0qGJucdk*wKGNlw{)o-mwbW zw#muCwK;7H_gLlKy8Ea@a$e3gvlG^vd#jqO%2zHGG5OA9LNz)0BpqVzNZ~!jnM$f&j%Kf#nz9qzO|>*` x1BkY%K`SzWuM;bKR`wq~Vwjo}CV6oW*dK!erZ6xi$58)^xgwk>NCQ&p=zwI0{t5s9 diff --git a/R/ui_elements.R b/R/ui_elements.R index 2cd23878..6686879d 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -124,7 +124,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars"), + icon = phosphoricons::ph("binoculars",weight = "bold"), # icon = shiny::icon("binoculars"), disabled = FALSE ), @@ -169,7 +169,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play"), + icon = phosphoricons::ph("play",weight = "bold"), # icon = shiny::icon("play"), disabled = TRUE ), @@ -460,7 +460,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ), diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index e8699886..98d24dae 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -44,7 +44,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) @@ -55,7 +55,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -68,7 +68,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -92,7 +92,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise"), + phosphoricons::ph("arrow-clockwise",weight = "bold"), i18n$t("Update factor variable") ), class = "btn-outline-primary" diff --git a/R/update-variables-ext.R b/R/update-variables-ext.R index 17542646..b5dc5ab0 100644 --- a/R/update-variables-ext.R +++ b/R/update-variables-ext.R @@ -30,7 +30,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear"), + label = phosphoricons::ph("gear",weight = "bold"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -75,7 +75,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), i18n$t("Apply changes") ), width = "100%" diff --git a/SESSION.md b/SESSION.md index d1466928..1e301770 100644 --- a/SESSION.md +++ b/SESSION.md @@ -4,18 +4,18 @@ |setting |value | |:-----------|:------------------------------------------| |version |R version 4.5.2 (2025-10-31) | -|os |macOS Tahoe 26.4 | +|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-01 | +|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.1.260401 | +|FreesearchR |26.4.2.260410 | -------------------------------------------------------------------------------- @@ -83,7 +83,7 @@ |foreach |1.5.2 |2022-02-02 |CRAN (R 4.5.0) | |foreign |0.8-91 |2026-01-29 |CRAN (R 4.5.2) | |Formula |1.2-5 |2023-02-24 |CRAN (R 4.5.0) | -|FreesearchR |26.4.1 |NA |NA | +|FreesearchR |26.4.2 |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) | @@ -147,7 +147,6 @@ |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) | diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 2240bc2c..927131ba 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." "Select a sample dataset from a package.","Vælg et træningsdatasæt." "Data ready to be imported!","Data er klar til at blive importeret!" -"Data has %s obs. of %s variables.","Data har %s obs. på %s variabler." "Data successfully imported!","Data successfully imported!" "Click to see data","Klik for at se data" "No data present.","Ingen data tilstede." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 7866710e..134ec155 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." "Select a sample dataset from a package.","Select a sample dataset from a package." "Data ready to be imported!","Data ready to be imported!" -"Data has %s obs. of %s variables.","Data has %s obs. of %s variables." "Data successfully imported!","Data successfully imported!" "Click to see data","Click to see data" "No data present.","No data present." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/man/align_axes.Rd b/man/align_axes.Rd index 2a8ab279..6d3e79e2 100644 --- a/man/align_axes.Rd +++ b/man/align_axes.Rd @@ -4,7 +4,7 @@ \alias{align_axes} \title{Aligns axes between plots} \usage{ -align_axes(..., x.axis = TRUE, y.axis = TRUE) +align_axes(..., x.axis = TRUE, y.axis = TRUE, percentage = FALSE) } \arguments{ \item{...}{ggplot2 objects or list of ggplot2 objects} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 6da5a230..4222466f 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -7,6 +7,7 @@ \alias{data_visuals_ui} \alias{data_visuals_server} \alias{create_plot} +\alias{plot_bar} \alias{plot_bar_single} \alias{plot_box} \alias{plot_box_single} @@ -25,6 +26,17 @@ data_visuals_server(id, data, palettes, ...) create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) +plot_bar( + data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ... +) + plot_bar_single( data, pri, @@ -91,6 +103,8 @@ shiny server module ggplot2 object +ggplot list object + ggplot object ggplot2 object @@ -116,6 +130,8 @@ Data correlations evaluation module Wrapper to create plot based on provided type +Title + Single vertical barplot Beautiful box plot(s) @@ -138,6 +154,13 @@ Beautiful violin plot } \examples{ create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +mtcars |> + dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> + plot_bar(pri = "cyl", sec = "am", style = "fill") + +mtcars |> + dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> + plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") mtcars |> dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> plot_bar_single(pri = "cyl", sec = "am", style = "fill") diff --git a/man/wrap_plot_list.Rd b/man/wrap_plot_list.Rd index 2a6e8d62..40cf0ba1 100644 --- a/man/wrap_plot_list.Rd +++ b/man/wrap_plot_list.Rd @@ -12,6 +12,7 @@ wrap_plot_list( guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ... ) } From 41c855a71c4f5d14bd8be47c0546c189916cf3e0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 10 Apr 2026 21:47:36 +0200 Subject: [PATCH 05/17] new version --- app_docker/app.R | 162 ++++++++++++--------- app_docker/translations/translation_da.csv | 2 +- app_docker/translations/translation_sw.csv | 2 +- inst/apps/FreesearchR/app.R | 162 ++++++++++++--------- 4 files changed, 194 insertions(+), 134 deletions(-) diff --git a/app_docker/app.R b/app_docker/app.R index fe1bceb3..4dd38592 100644 --- a/app_docker/app.R +++ b/app_docker/app.R @@ -1,7 +1,7 @@ ######## -#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmpmlTuE8/file8be05102425f.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprUCGcI/file4761ae70bf7.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.1' +app_version <- function()'26.4.2' ######## @@ -512,7 +512,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil"), i18n$t("Create column") + phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -520,7 +520,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle"), + phosphoricons::ph("x-circle",weight = "bold"), i18n$t("Cancel") ), class = "btn-outline-danger", @@ -1568,7 +1568,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -2175,7 +2175,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = phosphoricons::ph("paint-brush"), + icon = phosphoricons::ph("paint-brush",weight = "bold"), # icon = shiny::icon("palette"), disabled = FALSE ), @@ -2380,7 +2380,8 @@ data_visuals_server <- function(id, colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes + choices = palettes, + previews = 5 ) }) @@ -2858,6 +2859,7 @@ wrap_plot_list <- function(data, guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ...) { if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { @@ -2871,7 +2873,7 @@ wrap_plot_list <- function(data, .x } })() |> - align_axes() |> + align_axes(percentage=y.axis.percentage) |> patchwork::wrap_plots(guides = guides, axes = axes, axis_titles = axis_titles, @@ -2916,7 +2918,8 @@ wrap_plot_list <- function(data, #' align_axes <- function(..., x.axis = TRUE, - y.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)) { @@ -2934,7 +2937,7 @@ align_axes <- function(..., xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x) { + p_out <- purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -2945,6 +2948,15 @@ align_axes <- function(..., out }) }) + + if(isTRUE(percentage)){ + lapply(p_out,\(.x){ + .x+ + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } } #' Extract and clean axis ranges @@ -4031,13 +4043,13 @@ color_choices <- function() { "Perceptual (blue-yellow)" = "viridis", "Perceptual (fire)" = "plasma", "Colour-blind friendly" = "Okabe-Ito", - "Qualitative (bold)" = "Dark 2", - "Qualitative (paired)" = "Paired", - "Sequential (blues)" = "Blues", + "Diverging (red-yellow-green)"= "RdYlGn", "Diverging (red-blue)" = "RdBu", - "Tableau style" = "Tableau 10", - "Pastel" = "Pastel 1", - "Rainbow" = "rainbow" + "Sequential (blues)" = "Blues", + "Qualitative (paired)" = "Paired", + "Qualitative (bold)" = "Dark 2", + "Rainbow" = "Spectral", + "Generic" = "Set1" ) } @@ -4945,7 +4957,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.1-260402' +hosted_version <- function()'v26.4.2-260410' ######## @@ -6085,7 +6097,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6096,7 +6108,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6581,7 +6593,7 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ) @@ -6918,8 +6930,32 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), - color.palette = "viridis", max_level = 30, ...) { +#' Title +#' +#' @name data-plots +#' +#' @param style barplot style passed to geom_bar position argument. +#' One of c("stack", "dodge", "fill") +#' +#' @returns ggplot list object +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> +#' plot_bar(pri = "cyl", sec = "am", style = "fill") +#' +#' mtcars |> +#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> +#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") +plot_bar <- function(data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6928,7 +6964,7 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ds <- list(data) } - out <- lapply(ds, \(.ds){ + out <- lapply(ds, \(.ds) { plot_bar_single( data = .ds, pri = pri, @@ -6939,7 +6975,10 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ) }) - 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)}")), + y.axis.percentage = TRUE, + ...) } @@ -6961,7 +7000,11 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, +plot_bar_single <- function(data, + pri, + sec = NULL, + style = c("stack", "dodge", "fill"), + max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -6971,16 +7014,11 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data) - ) + p = Freq / NROW(data)) if (nrow(p_data) > max_level) { - p_data <- sort_by( - p_data, - p_data[["Freq"]], - decreasing = TRUE - ) |> + p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> head(max_level) } @@ -6993,41 +7031,33 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " fill <- pri } - p <- ggplot2::ggplot( - p_data, - ggplot2::aes( - x = .data[[pri]], - y = p, - fill = .data[[fill]] - ) - ) + + p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + ggplot2::geom_bar(position = style, stat = "identity") + - ggplot2::scale_y_continuous(labels = scales::percent) + - scale_fill_generate(palette=color.palette) + - ggplot2::ylab("Percentage") + - ggplot2::xlab(get_label(data,pri))+ - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) + scale_fill_generate(palette = color.palette) + + ggplot2::xlab(get_label(data, pri)) + + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | + any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, hjust = 1 - ))+ - ggplot2::theme( - axis.text.x = ggplot2::element_text(vjust = 0.5) - ) + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, + hjust = 1 + )) + + ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) - if (is.null(sec)){ + if (is.null(sec)) { p <- p + ggplot2::guides(fill = "none") } } - p + p + + ggplot2::scale_y_continuous(labels = scales::percent) + + ggplot2::ylab("Percentage") } @@ -10965,7 +10995,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -11850,7 +11880,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars"), + icon = phosphoricons::ph("binoculars",weight = "bold"), # icon = shiny::icon("binoculars"), disabled = FALSE ), @@ -11895,7 +11925,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play"), + icon = phosphoricons::ph("play",weight = "bold"), # icon = shiny::icon("play"), disabled = TRUE ), @@ -12186,7 +12216,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ), @@ -12497,7 +12527,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) @@ -12508,7 +12538,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -12521,7 +12551,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -12545,7 +12575,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise"), + phosphoricons::ph("arrow-clockwise",weight = "bold"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -12897,7 +12927,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear"), + label = phosphoricons::ph("gear",weight = "bold"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -12942,7 +12972,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), i18n$t("Apply changes") ), width = "100%" diff --git a/app_docker/translations/translation_da.csv b/app_docker/translations/translation_da.csv index 2240bc2c..927131ba 100644 --- a/app_docker/translations/translation_da.csv +++ b/app_docker/translations/translation_da.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Vælg et datasæt fra din kørende session eller vælg træningsdata." "Select a sample dataset from a package.","Vælg et træningsdatasæt." "Data ready to be imported!","Data er klar til at blive importeret!" -"Data has %s obs. of %s variables.","Data har %s obs. på %s variabler." "Data successfully imported!","Data successfully imported!" "Click to see data","Klik for at se data" "No data present.","Ingen data tilstede." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/app_docker/translations/translation_sw.csv b/app_docker/translations/translation_sw.csv index 7866710e..134ec155 100644 --- a/app_docker/translations/translation_sw.csv +++ b/app_docker/translations/translation_sw.csv @@ -275,7 +275,6 @@ "Select a dataset from your environment or sample dataset from a package.","Select a dataset from your environment or sample dataset from a package." "Select a sample dataset from a package.","Select a sample dataset from a package." "Data ready to be imported!","Data ready to be imported!" -"Data has %s obs. of %s variables.","Data has %s obs. of %s variables." "Data successfully imported!","Data successfully imported!" "Click to see data","Click to see data" "No data present.","No data present." @@ -320,3 +319,4 @@ "Likert diagram","Likert diagram" "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." +"The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 66df2775..fbadebb2 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//RtmpmlTuE8/file8be0207bfdc2.R +#### Current file: /var/folders/9l/xbc19wxx0g79jdd2sf_0v291mhwh7f/T//RtmprUCGcI/file47614d090a4c.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.1' +app_version <- function()'26.4.2' ######## @@ -512,7 +512,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("compute"), label = tagList( - phosphoricons::ph("pencil"), i18n$t("Create column") + phosphoricons::ph("pencil",weight = "bold"), i18n$t("Create column") ), class = "btn-outline-primary", width = "100%" @@ -520,7 +520,7 @@ create_column_ui <- function(id) { actionButton( inputId = ns("remove"), label = tagList( - phosphoricons::ph("x-circle"), + phosphoricons::ph("x-circle",weight = "bold"), i18n$t("Cancel") ), class = "btn-outline-danger", @@ -1568,7 +1568,7 @@ cut_variable_ui <- function(id) { toastui::datagridOutput2(outputId = ns("count")), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("scissors"), i18n$t("Create factor variable")), + label = tagList(phosphoricons::ph("scissors",weight = "bold"), i18n$t("Create factor variable")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -2175,7 +2175,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { inputId = ns("act_plot"), label = i18n$t("Plot"), width = "100%", - icon = phosphoricons::ph("paint-brush"), + icon = phosphoricons::ph("paint-brush",weight = "bold"), # icon = shiny::icon("palette"), disabled = FALSE ), @@ -2380,7 +2380,8 @@ data_visuals_server <- function(id, colorSelectInput( inputId = ns("color_palette"), label = i18n$t("Choose color palette"), - choices = palettes + choices = palettes, + previews = 5 ) }) @@ -2858,6 +2859,7 @@ wrap_plot_list <- function(data, guides = "collect", axes = "collect", axis_titles = "collect", + y.axis.percentage = FALSE, ...) { if (ggplot2::is_ggplot(data[[1]])) { if (length(data) > 1) { @@ -2871,7 +2873,7 @@ wrap_plot_list <- function(data, .x } })() |> - align_axes() |> + align_axes(percentage=y.axis.percentage) |> patchwork::wrap_plots(guides = guides, axes = axes, axis_titles = axis_titles, @@ -2916,7 +2918,8 @@ wrap_plot_list <- function(data, #' align_axes <- function(..., x.axis = TRUE, - y.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)) { @@ -2934,7 +2937,7 @@ align_axes <- function(..., xr <- clean_common_axis(p, "x") suppressWarnings({ - purrr::map(p, \(.x) { + p_out <- purrr::map(p, \(.x) { out <- .x if (isTRUE(x.axis)) { out <- out + ggplot2::xlim(xr) @@ -2945,6 +2948,15 @@ align_axes <- function(..., out }) }) + + if(isTRUE(percentage)){ + lapply(p_out,\(.x){ + .x+ + ggplot2::scale_y_continuous(labels = scales::percent) + }) + } else { + p_out + } } #' Extract and clean axis ranges @@ -4031,13 +4043,13 @@ color_choices <- function() { "Perceptual (blue-yellow)" = "viridis", "Perceptual (fire)" = "plasma", "Colour-blind friendly" = "Okabe-Ito", - "Qualitative (bold)" = "Dark 2", - "Qualitative (paired)" = "Paired", - "Sequential (blues)" = "Blues", + "Diverging (red-yellow-green)"= "RdYlGn", "Diverging (red-blue)" = "RdBu", - "Tableau style" = "Tableau 10", - "Pastel" = "Pastel 1", - "Rainbow" = "rainbow" + "Sequential (blues)" = "Blues", + "Qualitative (paired)" = "Paired", + "Qualitative (bold)" = "Dark 2", + "Rainbow" = "Spectral", + "Generic" = "Set1" ) } @@ -4945,7 +4957,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.1-260402' +hosted_version <- function()'v26.4.2-260410' ######## @@ -6085,7 +6097,7 @@ make_success_alert <- function(data, i18n$t("Data ready to be imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6096,7 +6108,7 @@ make_success_alert <- function(data, i18n$t("Data successfully imported!") ), sprintf( - i18n$t("Data has %s obs. of %s variables."), + i18n$t("The data set has %s obs. in %s variables."), nrow(data), ncol(data) ), @@ -6581,7 +6593,7 @@ data_missings_ui <- function(id, ...) { inputId = ns("act_miss"), label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ) @@ -6918,8 +6930,32 @@ missings_logic_across <- function(data, exclude = NULL) { #### Current file: /Users/au301842/FreesearchR/R//plot_bar.R ######## -plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fill"), - color.palette = "viridis", max_level = 30, ...) { +#' Title +#' +#' @name data-plots +#' +#' @param style barplot style passed to geom_bar position argument. +#' One of c("stack", "dodge", "fill") +#' +#' @returns ggplot list object +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> +#' plot_bar(pri = "cyl", sec = "am", style = "fill") +#' +#' mtcars |> +#' dplyr::mutate(dplyr::across(tidyselect::all_of(c("cyl","am","gear")),factor)) |> +#' plot_bar(pri = "cyl", sec = "gear", ter = "am", style = "stack",color.palette="turbo") +plot_bar <- function(data, + pri, + sec = NULL, + ter = NULL, + style = c("stack", "dodge", "fill"), + color.palette = "viridis", + max_level = 30, + ...) { style <- match.arg(style) if (!is.null(ter)) { @@ -6928,7 +6964,7 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ds <- list(data) } - out <- lapply(ds, \(.ds){ + out <- lapply(ds, \(.ds) { plot_bar_single( data = .ds, pri = pri, @@ -6939,7 +6975,10 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi ) }) - 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)}")), + y.axis.percentage = TRUE, + ...) } @@ -6961,7 +7000,11 @@ plot_bar <- function(data, pri, sec, ter = NULL, style = c("stack", "dodge", "fi #' mtcars |> #' dplyr::mutate(cyl = factor(cyl), am = factor(am)) |> #' plot_bar_single(pri = "cyl", style = "stack",color.palette="turbo") -plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", "fill"), max_level = 30, +plot_bar_single <- function(data, + pri, + sec = NULL, + style = c("stack", "dodge", "fill"), + max_level = 30, color.palette = "viridis") { style <- match.arg(style) @@ -6971,16 +7014,11 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " p_data <- as.data.frame(table(data[c(pri, sec)])) |> dplyr::mutate(dplyr::across(tidyselect::any_of(c(pri, sec)), forcats::as_factor), - p = Freq / NROW(data) - ) + p = Freq / NROW(data)) if (nrow(p_data) > max_level) { - p_data <- sort_by( - p_data, - p_data[["Freq"]], - decreasing = TRUE - ) |> + p_data <- sort_by(p_data, p_data[["Freq"]], decreasing = TRUE) |> head(max_level) } @@ -6993,41 +7031,33 @@ plot_bar_single <- function(data, pri, sec = NULL, style = c("stack", "dodge", " fill <- pri } - p <- ggplot2::ggplot( - p_data, - ggplot2::aes( - x = .data[[pri]], - y = p, - fill = .data[[fill]] - ) - ) + + p <- ggplot2::ggplot(p_data, ggplot2::aes(x = .data[[pri]], y = p, fill = .data[[fill]])) + ggplot2::geom_bar(position = style, stat = "identity") + - ggplot2::scale_y_continuous(labels = scales::percent) + - scale_fill_generate(palette=color.palette) + - ggplot2::ylab("Percentage") + - ggplot2::xlab(get_label(data,pri))+ - ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data,fill))) + scale_fill_generate(palette = color.palette) + + ggplot2::xlab(get_label(data, pri)) + + ggplot2::guides(fill = ggplot2::guide_legend(title = get_label(data, fill))) ## To handle large number of levels and long level names - if (nrow(p_data) > 10 | any(nchar(as.character(p_data[[pri]])) > 6)) { + if (nrow(p_data) > 10 | + any(nchar(as.character(p_data[[pri]])) > 6)) { p <- p + # ggplot2::guides(fill = "none") + - ggplot2::theme( - axis.text.x = ggplot2::element_text( - angle = 90, - vjust = 1, hjust = 1 - ))+ - ggplot2::theme( - axis.text.x = ggplot2::element_text(vjust = 0.5) - ) + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 90, + vjust = 1, + hjust = 1 + )) + + ggplot2::theme(axis.text.x = ggplot2::element_text(vjust = 0.5)) - if (is.null(sec)){ + if (is.null(sec)) { p <- p + ggplot2::guides(fill = "none") } } - p + p + + ggplot2::scale_y_continuous(labels = scales::percent) + + ggplot2::ylab("Percentage") } @@ -10965,7 +10995,7 @@ string_split_ui <- function(id) { ), actionButton( inputId = ns("create"), - label = tagList(phosphoricons::ph("pencil"), i18n$t("Apply split")), + label = tagList(phosphoricons::ph("pencil",weight = "bold"), i18n$t("Apply split")), class = "btn-outline-primary float-end" ), tags$div(class = "clearfix") @@ -11850,7 +11880,7 @@ ui_elements <- function(selection) { inputId = "modal_initial_view", label = i18n$t("Quick overview"), width = "100%", - icon = phosphoricons::ph("binoculars"), + icon = phosphoricons::ph("binoculars",weight = "bold"), # icon = shiny::icon("binoculars"), disabled = FALSE ), @@ -11895,7 +11925,7 @@ ui_elements <- function(selection) { inputId = "act_start", label = i18n$t("Let's begin!"), width = "100%", - icon = phosphoricons::ph("play"), + icon = phosphoricons::ph("play",weight = "bold"), # icon = shiny::icon("play"), disabled = TRUE ), @@ -12186,7 +12216,7 @@ ui_elements <- function(selection) { inputId = "act_eval", label = i18n$t("Evaluate"), width = "100%", - icon = phosphoricons::ph("calculator"), + icon = phosphoricons::ph("calculator",weight = "bold"), # icon = shiny::icon("calculator"), disabled = TRUE ), @@ -12497,7 +12527,7 @@ update_factor_ui <- function(id) { actionButton( disabled = TRUE, inputId = ns("drop_levels"), - label = tagList(phosphoricons::ph("trash"), i18n$t("Drop empty")), + label = tagList(phosphoricons::ph("trash",weight = "bold"), i18n$t("Drop empty")), class = "btn-outline-primary mb-3", width = "100%" ) @@ -12508,7 +12538,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_levels"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by levels") ), class = "btn-outline-primary mb-3", @@ -12521,7 +12551,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("sort_occurrences"), label = tagList( - phosphoricons::ph("sort-ascending"), + phosphoricons::ph("sort-ascending",weight = "bold"), i18n$t("Sort by count") ), class = "btn-outline-primary mb-3", @@ -12545,7 +12575,7 @@ update_factor_ui <- function(id) { actionButton( inputId = ns("create"), label = tagList( - phosphoricons::ph("arrow-clockwise"), + phosphoricons::ph("arrow-clockwise",weight = "bold"), i18n$t("Update factor variable") ), class = "btn-outline-primary" @@ -12897,7 +12927,7 @@ update_variables_ui <- function(id, title = "") { placement = "bottom-end", shiny::actionButton( inputId = ns("settings"), - label = phosphoricons::ph("gear"), + label = phosphoricons::ph("gear",weight = "bold"), class = "pull-right float-right" ), shinyWidgets::textInputIcon( @@ -12942,7 +12972,7 @@ update_variables_ui <- function(id, title = "") { shiny::actionButton( inputId = ns("validate"), label = htmltools::tagList( - phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes")), + phosphoricons::ph("arrow-circle-right", title = i18n$t("Apply changes"),weight = "bold"), i18n$t("Apply changes") ), width = "100%" From 7f14447627c29545c954940bc0ab44ac813d6fe0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 15 Apr 2026 23:47:49 +0200 Subject: [PATCH 06/17] revised --- R/generate_colors.R | 96 +++++++++++++++++++++------------------------ 1 file changed, 45 insertions(+), 51 deletions(-) diff --git a/R/generate_colors.R b/R/generate_colors.R index d7a7cc82..9daec605 100644 --- a/R/generate_colors.R +++ b/R/generate_colors.R @@ -56,38 +56,25 @@ #' #' @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, ...) @@ -107,35 +94,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") + } + } } } From 0d4f51f176a3becccef8f620b66e1f52ad194528 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 27 May 2026 20:23:58 +0200 Subject: [PATCH 07/17] upd --- .Rbuildignore | 2 ++ .gitignore | 1 + 2 files changed, 3 insertions(+) diff --git a/.Rbuildignore b/.Rbuildignore index 94927477..a0e3635f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,5 @@ ^app*$ ^page$ ^demo$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index ce227491..25eb7609 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ app page demo visuals +.positai From d1e0236437fe08aac8bf07e9c2d4468b0a189fae Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 29 May 2026 11:46:58 +0200 Subject: [PATCH 08/17] new dynamic plotting working --- R/data_plots.R | 338 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 286 insertions(+), 52 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index a01403df..f2ef156d 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -30,8 +30,9 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("basic_parameters")), + # shiny::uiOutput(outputId = ns("secondary")), + # shiny::uiOutput(outputId = ns("tertiary")), shiny::uiOutput(outputId = ns("color_palette")), shiny::br(), shiny::actionButton( @@ -174,13 +175,19 @@ 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, @@ -191,51 +198,124 @@ data_visuals_server <- function(id, }) 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) }) - 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)) + output$basic_parameters <- renderUI({ + req(input$type, rv$plot.params) - 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") - ) + # Get the plot function name + base_params <- rv$plot.params()[["basic"]] + + + params2update <- seq_along(base_params)[sapply(base_params, function(params) { + params$type %in% "select_variables" + })] + + # browser() + updated_params <- seq_along(params2update) |> lapply(function(index){ + params <- base_params[params2update][[index]] + params$exclude <- input$primary + + edits <- base_params[params2update][seq_len(index-1)] + + id_exclude <- unlist(lapply(edits,\(.x){.x[["id"]]})) + + if (length(id_exclude)>0){ + ids <- paste0("base_", id_exclude) + + params$exclude <- c(params$exclude, names(input)[ids %in% names(input)]) + } + + return(params) + }) + + base_params[params2update] <- updated_params + + # Create UI elements for base parameters + base_inputs <- lapply(base_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) + }) + + if(length(base_inputs) > 0) { + tagList(base_inputs) + } else { + p("No basic parameters available for this plot type.") + } }) - 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") - ) - }) + + # output$secondary <- shiny::renderUI({ + # shiny::req(input$type) + # + # browser() + # + # + # params <- rv$plot.params()[["inputs"]][[1]] + # + # # params$fun <- NULL + # params$exclude <- input$primary + # # params$inputId <- paste0("base_", names(available_plots()[[1]][["inputs"]])[1]) + # + # # input_fun <- rlang::eval_tidy(rlang::sym("selectPlotVariables"), env = asNamespace("shiny")) + # # + # # rlang::inject(input_fun(!!!append_list(data(), params, "data"))) + # + # create_input_element(input_id = paste0("base_", names(available_plots()[[1]][["inputs"]])[1]), + # ns = ns, + # params = append_list(data(), params, "data")) + # + # # rlang::exec(selectPlotVariables, + # # !!!append_list(data(), params, "data")) + # + # + # # cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( + # # subset_types(data(), rv$plot.params()[["secondary.type"]]) + # # ), input$primary)) + # # + # # columnSelectInput( + # # inputId = ns("secondary"), + # # data = data, + # # selected = cols[1], + # # placeholder = i18n$t("Please select"), + # # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) + # # i18n$t("Additional variables") + # # else + # # i18n$t("Secondary variable"), + # # multiple = rv$plot.params()[["secondary.multi"]], + # # maxItems = rv$plot.params()[["secondary.max"]], + # # col_subset = cols, + # # none_label = i18n$t("No variable") + # # ) + # }) + # + # output$tertiary <- shiny::renderUI({ + # shiny::req(input$type) + # 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") + # ) + # }) ### Color option output$color_palette <- shiny::renderUI({ @@ -251,13 +331,28 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { tryCatch({ - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary, - color.palette = input$color_palette - ) + + ## BELOW NEEDS REVISION ### + + # 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)) + + # Combine all parameters + dynamic_params <- c(base_inputs, advanced_inputs) + + # Build parameters for plotting function + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + color.palette = input$color_palette + ) + + parameters <- modifyList(parameters, dynamic_params) ## If the dictionary holds additional arguments to pass to the ## plotting function, these are included @@ -343,6 +438,118 @@ data_visuals_server <- function(id, ) } +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 ### + basic = list( + list( + id = "sec", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = FALSE + ), + list( + id = "ter", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = 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 ### + basic = list( + list( + id = "sec", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = FALSE + ), + list( + id = "ter", + 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 + + # Call the function with all arguments + do.call(input_function, params) +} + +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 @@ -533,7 +740,7 @@ supported_plots <- function() { #' default_parsing() |> #' dplyr::select("mpg") |> #' possible_plots() -possible_plots <- function(data) { +possible_plots <- function(data,source_list = supported_plots()) { # browser() # data <- if (is.reactive(data)) data() else data if (is.data.frame(data)) { @@ -545,7 +752,7 @@ possible_plots <- function(data) { if (type == "unknown") { out <- type } else { - out <- supported_plots() |> + out <- source_list |> lapply(\(.x) { if (type %in% .x$primary.type) { .x$descr @@ -584,6 +791,33 @@ get_plot_options <- function(data) { })() } +#' 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 From f2a522dcb6c33050b61d9640b6298e93dd332ccc Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 29 May 2026 11:47:15 +0200 Subject: [PATCH 09/17] allows ... inputs in plot models --- R/hosted_version.R | 2 +- R/plot_bar.R | 6 +++--- R/plot_box.R | 4 ++-- R/plot_euler.R | 2 +- R/plot_hbar.R | 6 ++++-- R/plot_likert.R | 3 ++- R/plot_sankey.R | 3 ++- R/plot_scatter.R | 2 +- R/plot_violin.R | 5 +++-- examples/visuals_module_demo.R | 2 +- 10 files changed, 20 insertions(+), 15 deletions(-) diff --git a/R/hosted_version.R b/R/hosted_version.R index 33aaf67c..5a0a6546 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260410' +hosted_version <- function()'v26.4.2-260528' diff --git a/R/plot_bar.R b/R/plot_bar.R index 0535b6f3..e9879ef3 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -39,14 +39,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) } diff --git a/R/plot_box.R b/R/plot_box.R index 01911aac..4acd67ab 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -32,11 +32,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette + color.palette=color.palette, ... ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) } diff --git a/R/plot_euler.R b/R/plot_euler.R index 27cdf02f..a5a0d31f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -131,7 +131,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis") { +plot_euler_single <- function(data,color.palette="viridis", ...) { data |> ggeulerr(shape = "circle") + diff --git a/R/plot_hbar.R b/R/plot_hbar.R index d93ef4c9..1405678f 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -15,13 +15,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, + ... ) } diff --git a/R/plot_likert.R b/R/plot_likert.R index c18c57a1..e33256a2 100644 --- a/R/plot_likert.R +++ b/R/plot_likert.R @@ -15,7 +15,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 { diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 23c1a13a..409a1050 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -95,7 +95,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 { diff --git a/R/plot_scatter.R b/R/plot_scatter.R index 142c30fd..8c73547e 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (is.null(ter)) { rempsyc::nice_scatter( data = data, diff --git a/R/plot_violin.R b/R/plot_violin.R index 83d11d2a..29850d26 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -23,7 +23,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) }) diff --git a/examples/visuals_module_demo.R b/examples/visuals_module_demo.R index 00a8c020..e4883d6c 100644 --- a/examples/visuals_module_demo.R +++ b/examples/visuals_module_demo.R @@ -22,7 +22,7 @@ visuals_demo_app <- function() { ) ) server <- function(input, output, session) { - pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars))) + pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars)),palettes = color_choices()) } shiny::shinyApp(ui, server) } From f774b90d073bf4d49dea4cb7fce60a61aa8e7053 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 19:55:45 +0200 Subject: [PATCH 10/17] transformed for a new pragmatic compromise to dynamically load additional input options where available --- R/data_plots.R | 882 ++++++------------------------------------------- 1 file changed, 106 insertions(+), 776 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index f2ef156d..41edfb20 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -14,12 +14,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")), @@ -30,20 +41,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), - shiny::uiOutput(outputId = ns("basic_parameters")), - # shiny::uiOutput(outputId = ns("secondary")), - # shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("secondary")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), shiny::uiOutput(outputId = ns("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", @@ -120,10 +126,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) { @@ -175,8 +178,7 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data, - source_list=available_plots()) + plots <- possible_plots(data = plot_data, source_list = available_plots()) plots_named <- get_input_params(plots) |> lapply(\(.x) { @@ -198,125 +200,77 @@ data_visuals_server <- function(id, }) rv$plot.params <- shiny::reactive({ - get_input_params(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) + + # Get the plot function name + base_params <- rv$plot.params()[["base"]] + + 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) + # 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()[["basic"]] + base_params <- rv$plot.params()[["base"]] - - params2update <- seq_along(base_params)[sapply(base_params, function(params) { - params$type %in% "select_variables" + filtered_params <- base_params[sapply(base_params, function(params) { + !params$id %in% c("secondary", "tertiary") })] - # browser() - updated_params <- seq_along(params2update) |> lapply(function(index){ - params <- base_params[params2update][[index]] - params$exclude <- input$primary - - edits <- base_params[params2update][seq_len(index-1)] - - id_exclude <- unlist(lapply(edits,\(.x){.x[["id"]]})) - - if (length(id_exclude)>0){ - ids <- paste0("base_", id_exclude) - - params$exclude <- c(params$exclude, names(input)[ids %in% names(input)]) - } - - return(params) - }) - - base_params[params2update] <- updated_params # Create UI elements for base parameters - base_inputs <- lapply(base_params, function(params) { + 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() - } + if (params$type %in% "select_variables") { + params$data <- data() + } create_input_element(params, ns, input_id) }) + tagList(base_inputs) - if(length(base_inputs) > 0) { - tagList(base_inputs) - } else { - p("No basic parameters available for this plot type.") - } }) - - # output$secondary <- shiny::renderUI({ - # shiny::req(input$type) - # - # browser() - # - # - # params <- rv$plot.params()[["inputs"]][[1]] - # - # # params$fun <- NULL - # params$exclude <- input$primary - # # params$inputId <- paste0("base_", names(available_plots()[[1]][["inputs"]])[1]) - # - # # input_fun <- rlang::eval_tidy(rlang::sym("selectPlotVariables"), env = asNamespace("shiny")) - # # - # # rlang::inject(input_fun(!!!append_list(data(), params, "data"))) - # - # create_input_element(input_id = paste0("base_", names(available_plots()[[1]][["inputs"]])[1]), - # ns = ns, - # params = append_list(data(), params, "data")) - # - # # rlang::exec(selectPlotVariables, - # # !!!append_list(data(), params, "data")) - # - # - # # cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - # # subset_types(data(), rv$plot.params()[["secondary.type"]]) - # # ), input$primary)) - # # - # # columnSelectInput( - # # inputId = ns("secondary"), - # # data = data, - # # selected = cols[1], - # # placeholder = i18n$t("Please select"), - # # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) - # # i18n$t("Additional variables") - # # else - # # i18n$t("Secondary variable"), - # # multiple = rv$plot.params()[["secondary.multi"]], - # # maxItems = rv$plot.params()[["secondary.max"]], - # # col_subset = cols, - # # none_label = i18n$t("No variable") - # # ) - # }) - # - # output$tertiary <- shiny::renderUI({ - # shiny::req(input$type) - # 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") - # ) - # }) - ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) @@ -330,34 +284,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)))] - ## BELOW NEEDS REVISION ### + # Remove the prefix from names + names(base_inputs) <- gsub("^base_", "", names(base_inputs)) + # names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) - # Get all input values with prefixes - base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))] - advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))] + base_inputs <- c(base_inputs, + list(color.palette = input$color_palette)) - # Remove the prefix from names - names(base_inputs) <- gsub("^base_", "", names(base_inputs)) - names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs)) + # 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 + } - # Combine all parameters - dynamic_params <- c(base_inputs, advanced_inputs) + # Build parameters for plotting function + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary + ) - # Build parameters for plotting function - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - color.palette = input$color_palette - ) - - parameters <- modifyList(parameters, dynamic_params) + 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.."), @@ -437,642 +406,3 @@ data_visuals_server <- function(id, } ) } - -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 ### - basic = list( - list( - id = "sec", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = FALSE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = FALSE - ), - list( - id = "ter", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - # inputId = "sec", - label = i18n$t("Grouping variable"), - multiple = 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 ### - basic = list( - list( - id = "sec", - type = "select_variables", - var_types = c("dichotomous", "categorical"), - allow_none = TRUE, - # inputId = "sec", - label = i18n$t("Additional variables"), - multiple = FALSE - ), - list( - id = "ter", - 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 - - # Call the function with all arguments - do.call(input_function, params) -} - -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_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,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() -} From 5ca751d3ea65f52cd20187a6b817782203acf8d3 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 19:56:25 +0200 Subject: [PATCH 11/17] all plot helper functions are moved --- R/plot-helpers.R | 878 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 878 insertions(+) create mode 100644 R/plot-helpers.R diff --git a/R/plot-helpers.R b/R/plot-helpers.R new file mode 100644 index 00000000..361e15ef --- /dev/null +++ b/R/plot-helpers.R @@ -0,0 +1,878 @@ +#' 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 = 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_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() +} From ab3df0eda657caf1ea9371a5dafeb9ac12c2b0dd Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 19:59:31 +0200 Subject: [PATCH 12/17] new renders --- DESCRIPTION | 3 ++- NAMESPACE | 2 ++ NEWS.md | 4 ++++ R/hosted_version.R | 2 +- R/plot_hbar.R | 2 +- inst/translations/translation_da.csv | 7 ------- inst/translations/translation_sw.csv | 7 ------- man/align_axes.Rd | 2 +- man/all_but.Rd | 2 +- man/available_plots.Rd | 27 +++++++++++++++++++++++++++ man/clean_common_axis.Rd | 2 +- man/data-plots.Rd | 19 ++++++++++--------- man/get_input_params.Rd | 27 +++++++++++++++++++++++++++ man/get_label.Rd | 2 +- man/get_plot_options.Rd | 2 +- man/line_break.Rd | 2 +- man/plot_euler_single.Rd | 2 +- man/possible_plots.Rd | 4 ++-- man/selectPlotVariables.Rd | 11 +++++++++++ man/subset_types.Rd | 2 +- man/supported_plots.Rd | 2 +- man/wrap_plot_list.Rd | 2 +- 22 files changed, 97 insertions(+), 38 deletions(-) create mode 100644 man/available_plots.Rd create mode 100644 man/get_input_params.Rd create mode 100644 man/selectPlotVariables.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 69564bc2..881625b1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.4.2 +Version: 26.5.1 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), @@ -118,6 +118,7 @@ Collate: 'launch_FreesearchR.R' 'missings-module.R' 'plot-download-module.R' + 'plot-helpers.R' 'plot_bar.R' 'plot_box.R' 'plot_euler.R' diff --git a/NAMESPACE b/NAMESPACE index 9e036c3f..947b97e8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ export(append_column) export(append_list) export(apply_labels) export(argsstring2list) +export(available_plots) export(baseline_table) export(class_icons) export(clean_common_axis) @@ -64,6 +65,7 @@ export(format_writer) export(generate_colors) export(get_data_packages) export(get_fun_options) +export(get_input_params) export(get_label) export(get_list_elements) export(get_plot_options) diff --git a/NEWS.md b/NEWS.md index 785ee46a..62106e48 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.5.1 + +*NEW* The visuals module has been restructured to allow for more advanced inputs, which will be added in the future. Basically a more future proof design allowing for more adjustments, while striving to keep the simplicity. Have fun! + # FreesearchR 26.4.2 Bug fixes and revised color choices. diff --git a/R/hosted_version.R b/R/hosted_version.R index 5a0a6546..b2178643 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260528' +hosted_version <- function()'v26.4.2-260530' diff --git a/R/plot_hbar.R b/R/plot_hbar.R index 1405678f..fc33b20d 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -76,7 +76,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) } diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 927131ba..50a8e93b 100644 --- a/inst/translations/translation_da.csv +++ b/inst/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:" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 134ec155..cff599bb 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/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:" diff --git a/man/align_axes.Rd b/man/align_axes.Rd index 6d3e79e2..f403e1a7 100644 --- a/man/align_axes.Rd +++ b/man/align_axes.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{align_axes} \alias{align_axes} \title{Aligns axes between plots} diff --git a/man/all_but.Rd b/man/all_but.Rd index e2453d15..8dc3f46e 100644 --- a/man/all_but.Rd +++ b/man/all_but.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{all_but} \alias{all_but} \title{Select all from vector but} diff --git a/man/available_plots.Rd b/man/available_plots.Rd new file mode 100644 index 00000000..0ee1d5ac --- /dev/null +++ b/man/available_plots.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{available_plots} +\alias{available_plots} +\title{Implemented functions} +\usage{ +available_plots() +} +\value{ +list +} +\description{ +Library of supported functions. The list name and "descr" element should be +unique for each element on list. +\itemize{ +\item fun: the plotting function +\item fun.args: default parameters for the plotting function +\item descr: Plot description +\item note: Short note/description of the function for displaying in ui and docs +\item primary.type: Primary variable data type (see \link{data_type}) +\item base: holds a list of parameters for plot input fields generation +Secondary and tertiary variable input fields are mandatory. +} +} +\examples{ +available_plots() |> str() +} diff --git a/man/clean_common_axis.Rd b/man/clean_common_axis.Rd index 175053c9..67197d46 100644 --- a/man/clean_common_axis.Rd +++ b/man/clean_common_axis.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{clean_common_axis} \alias{clean_common_axis} \title{Extract and clean axis ranges} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 4222466f..e6d84e08 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R, R/plot_bar.R, R/plot_box.R, -% R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, R/plot_sankey.R, -% R/plot_scatter.R, R/plot_violin.R +% Please edit documentation in R/data_plots.R, R/plot-helpers.R, R/plot_bar.R, +% R/plot_box.R, R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, +% R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R \name{data-plots} \alias{data-plots} \alias{data_visuals_ui} @@ -22,7 +22,7 @@ \usage{ data_visuals_ui(id, tab_title = "Plots", ...) -data_visuals_server(id, data, palettes, ...) +data_visuals_server(id, data, palettes = color_choices(), ...) create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) @@ -50,9 +50,9 @@ plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...) plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") -plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis") +plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis", ...) plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) @@ -69,12 +69,13 @@ plot_sankey( default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing" + missing.level = "Missing", + ... ) -plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis", ...) } \arguments{ \item{id}{Module id. (Use 'ns("id")')} diff --git a/man/get_input_params.Rd b/man/get_input_params.Rd new file mode 100644 index 00000000..6766d73e --- /dev/null +++ b/man/get_input_params.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{get_input_params} +\alias{get_input_params} +\title{Get the function parameters based on the selected function description} +\usage{ +get_input_params(data) +} +\arguments{ +\item{data}{vector} +} +\value{ +list +} +\description{ +Get the function parameters based on the selected function description +} +\examples{ +ls <- mtcars |> + default_parsing() |> + dplyr::pull(mpg) |> + possible_plots() |> + (\(.x){ + .x[[1]] + })() |> + get_input_params() +} diff --git a/man/get_label.Rd b/man/get_label.Rd index 108fd372..c808209e 100644 --- a/man/get_label.Rd +++ b/man/get_label.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{get_label} \alias{get_label} \title{Print label, and if missing print variable name for plots} diff --git a/man/get_plot_options.Rd b/man/get_plot_options.Rd index 08c04496..83001d38 100644 --- a/man/get_plot_options.Rd +++ b/man/get_plot_options.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{get_plot_options} \alias{get_plot_options} \title{Get the function options based on the selected function description} diff --git a/man/line_break.Rd b/man/line_break.Rd index 65c987c7..d926556e 100644 --- a/man/line_break.Rd +++ b/man/line_break.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{line_break} \alias{line_break} \title{Line breaking at given number of characters for nicely plotting labels} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd index f481d5af..22d425c2 100644 --- a/man/plot_euler_single.Rd +++ b/man/plot_euler_single.Rd @@ -4,7 +4,7 @@ \alias{plot_euler_single} \title{Easily plot single euler diagrams} \usage{ -plot_euler_single(data, color.palette = "viridis") +plot_euler_single(data, color.palette = "viridis", ...) } \value{ ggplot2 object diff --git a/man/possible_plots.Rd b/man/possible_plots.Rd index 28c0b623..d1519e38 100644 --- a/man/possible_plots.Rd +++ b/man/possible_plots.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{possible_plots} \alias{possible_plots} \title{Get possible regression models} \usage{ -possible_plots(data) +possible_plots(data, source_list = supported_plots()) } \arguments{ \item{data}{data} diff --git a/man/selectPlotVariables.Rd b/man/selectPlotVariables.Rd new file mode 100644 index 00000000..f9e63e5d --- /dev/null +++ b/man/selectPlotVariables.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{selectPlotVariables} +\alias{selectPlotVariables} +\title{Wrapper for columnSelectInput} +\usage{ +selectPlotVariables(data, exclude = NULL, allow_none = TRUE, var_types, ...) +} +\description{ +Wrapper for columnSelectInput +} diff --git a/man/subset_types.Rd b/man/subset_types.Rd index 61fced5e..a33e1561 100644 --- a/man/subset_types.Rd +++ b/man/subset_types.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{subset_types} \alias{subset_types} \title{Easily subset by data type function} diff --git a/man/supported_plots.Rd b/man/supported_plots.Rd index c91ad753..caa250e3 100644 --- a/man/supported_plots.Rd +++ b/man/supported_plots.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{supported_plots} \alias{supported_plots} \title{Implemented functions} diff --git a/man/wrap_plot_list.Rd b/man/wrap_plot_list.Rd index 40cf0ba1..dcf1ae64 100644 --- a/man/wrap_plot_list.Rd +++ b/man/wrap_plot_list.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{wrap_plot_list} \alias{wrap_plot_list} \title{Wrapping} From bcc490535445d9f9fecbc2521e9faf1df5cecf52 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Sat, 30 May 2026 20:00:42 +0200 Subject: [PATCH 13/17] adds --- .Rbuildignore | 2 ++ .gitignore | 1 + 2 files changed, 3 insertions(+) diff --git a/.Rbuildignore b/.Rbuildignore index 94927477..a0e3635f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,5 @@ ^app*$ ^page$ ^demo$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index ce227491..25eb7609 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ app page demo visuals +.positai From 1793a2650f38835ed2b5c0f15317e3790fdf6962 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:22:27 +0200 Subject: [PATCH 14/17] updated links --- R/data_plots.R | 27 +++++++++++++++++++++++---- R/ui_elements.R | 4 ++-- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/R/data_plots.R b/R/data_plots.R index 41edfb20..b9e84c85 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -41,6 +41,7 @@ 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")) ), @@ -102,14 +103,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")) @@ -193,7 +194,7 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { 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 ) @@ -362,7 +363,25 @@ data_visuals_server <- function(id, data, palettes = color_choices(), ...) { 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) } }) diff --git a/R/ui_elements.R b/R/ui_elements.R index 6686879d..b08d5152 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -247,7 +247,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" ), @@ -694,7 +694,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", From 5e85902d4b4367b3de0c3d7ef4d04ec2692bedea Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:22:55 +0200 Subject: [PATCH 15/17] version ready for merging --- DESCRIPTION | 2 +- NEWS.md | 2 +- R/app_version.R | 2 +- R/hosted_version.R | 2 +- R/plot-helpers.R | 2 +- inst/translations/translation_da.csv | 10 ++++++++++ inst/translations/translation_sw.csv | 10 ++++++++++ 7 files changed, 25 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 881625b1..cc854ec0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.5.1 +Version: 26.6.1 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), diff --git a/NEWS.md b/NEWS.md index 62106e48..ce86f7a7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# FreesearchR 26.5.1 +# FreesearchR 26.6.1 *NEW* The visuals module has been restructured to allow for more advanced inputs, which will be added in the future. Basically a more future proof design allowing for more adjustments, while striving to keep the simplicity. Have fun! diff --git a/R/app_version.R b/R/app_version.R index 2cbd2cc4..bce90462 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.4.2' +app_version <- function()'26.6.1' diff --git a/R/hosted_version.R b/R/hosted_version.R index b2178643..27a50899 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260530' +hosted_version <- function()'v26.6.1' diff --git a/R/plot-helpers.R b/R/plot-helpers.R index 361e15ef..5b4ae981 100644 --- a/R/plot-helpers.R +++ b/R/plot-helpers.R @@ -70,7 +70,7 @@ available_plots <- function() { id = "secondary", type = "select_variables", var_types = c("dichotomous", "categorical"), - allow_none = FALSE, + allow_none = TRUE, # inputId = "sec", label = i18n$t("Secondary variable"), multiple = FALSE diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 50a8e93b..8b230b1c 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -313,3 +313,13 @@ "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" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index cff599bb..4b0d628a 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -313,3 +313,13 @@ "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" From e8307d3a2e267090adad4da7916a56fd908964e3 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:25:50 +0200 Subject: [PATCH 16/17] feat: major restructuring of the visuals module --- inst/translations/translation_da.csv | 1 + inst/translations/translation_sw.csv | 1 + 2 files changed, 2 insertions(+) diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 8b230b1c..517df60d 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -323,3 +323,4 @@ "Plot survey results","Plot survey results" "Additional variables","Additional variables" "Other variables","Other variables" +"Select variables and plot type,\nthen click 'Plot' to generate visualization","Select variables and plot type,\nthen click 'Plot' to generate visualization" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 4b0d628a..c56e9549 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -323,3 +323,4 @@ "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" From acbed08a0db5bd381a165951efc9f5b95f7e82e0 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Mon, 1 Jun 2026 09:35:12 +0200 Subject: [PATCH 17/17] new version ready for release --- CITATION.cff | 2 +- R/sysdata.rda | Bin 2691 -> 2796 bytes SESSION.md | 43 +- app_docker/app.R | 1722 +++++++++++++------- app_docker/translations/translation_da.csv | 18 +- app_docker/translations/translation_sw.csv | 18 +- inst/apps/FreesearchR/app.R | 1722 +++++++++++++------- 7 files changed, 2237 insertions(+), 1288 deletions(-) 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 c56ca282b6b07bc77e3fda961193f62c47cf5e58..1829eab4c6b894f7f0b020e1f38304579981f4bd 100644 GIT binary patch literal 2796 zcmVB^SQH>P6wHkS3Zm4FMSiJxnzjH8T*J4^T7)MusCygH-UE zG))CIr=*^zf}2$HQ5p|OF#s4wh7f4e(qXCL2&!sm0LWwpfB(OK$ESd3fRo*nj;z^_05$>2KG)qhVvD13yD`q&;FBMKZ7LDCi3zS?A{4yXl zTiv@BO)bojHm6B*6<(DZoU*x;Ze7#0C|$I;pd#_e8|O!Tg*F$3V!vLma8lSXbmY6R zJf>u8s=E@nk=jdQk}hdp#;_&LaWpZj6;(Y-_W!#tvnfw|lc^bztj#;Ey2zs}&C|>O z&eVV}VKSPjHZ8m1FJrhYx7wO}&0U)%t`g=k66Tswk0P$l3w3ceiaMASOEc5Fot7}= z;E=b-AG2m^NhMp&JR=u=I4h~(X38AO-R^UHg$&}GD4L`YAlR3ico?h2R5y5eM%a09 zytw6N?BrA^oP*LPTZI6ftaZ zwmpA`z03afvIHlhcKT`xBE({-h@glf3ltTIsxeU*q)}92BNU8cih>BD5kX+FQIQp5 z2#N|ZQBLn?$LrUnzUrrE#)=>)^;ss(+kUHkE%4E~P!@8us)(6M#P}Ln0f&kLe z+q=>%8U~QVQFW!7c3Up{8>l9xmut&L*-ki^a@4IGH0Il804^AU+|?FF$kaLz;H(&{ zWKJ5Q@bcexZ8*xA#~GSvY>NX~jI{Tag=L6Qgl@OKxo0fW;|N+*7MzY8F7bm>?Q@xk z9#=V;Gix_d!GyLs%ihlH7+aYcXN7QVr+W%hue)SL**DBPCUj8fRvy)~o4m@W&_Rb8 zd#h9ifC4InkVqgst1w|&cWzM?A4I9Q4$Up@Mp$QgW^HMuYS(8R<*I2I>sg$x`71X< zhKew}T2qx&Mzx?NB(<~x5i3YVMUq+4sJ3~TN~oL1Ztd0raSKth8%Y>~Cw$wMIBRvF z^+=G8i6|69RlCL}%H_q}&1$r|2mp~Jfo#fGTIS}a`;=52lTnE;c|brdGD{@jBCSGM zK=*^iv})w}CHF^HARJ}S7883AghYZWBp}EHM34-~B*7bNkboHsXuwu^qXtiT_p$O) zsxin3LXy!avRIQc;uRI|e2|df2%$g6+{dXRLfdsj+0D0RuZ7)Cyl;vQRvKV z!zhj=S%s_%XsR0}Y86>3AajR2VNEiS$^M)&Lf(YTNn$A!CMG6ZD2g8odEg1$X#tEN zs}Ny1xXc3!MS*3Y&u+sFy}h~Jo`jWI*27)i|8Kw(MXeeoZMzacY7R>Z$}*xQXv7>E z#e+-|bU;ER@R9WJ>Cj}Vfg^qt#$$np(x3*2svhdnwk#V8Efl3BXe&wu5mOBW%TOy; zwA-@9Rujy<2{O_hEaJF|R1m%WU}^%2HLPJpv@FsmYMo39#AE%N#0GM=bgPt}M|+xX zgR?@KYKQ`m+R-6acW)UxEQe@;2+ZtRz?>n@n8{xQn_}2ht)*3FWF{~plqE?b!ZKh1 zCoNet{Ex4yY3fcBTH&izwWYNzMUaw~4hABTQOn-{2XB`yUYl@fQ;guWwX0NYr7uok zu978s8PhG-D?3Sen&oX(rNIfQq)kw~Tz0!{Yf+_bltr{sDJHzOO`fCa>3~8gJC%+4 za4H$VfC2(28nO+CTClugW^+RYEDOu0SvpZDf@!mQ_RO^G-IE#uI+B-X@9p&rUOrx` z0z0|2&=KAFarLS#w)Mp{TaQlPc&1@?L9Jpu+dF=*fZgF4uJ_K0`1n3DL0?M|!;UNs zSR6?BcF3fUJJ-xa(;qKa7A@|gWG~h04@ihB>FE0TvBeQ`=WK=6i=-9p_a@y2P-|jCKyILCE9hJ?336-cbM2G(_It?n0C%6MCt^Jguswq zCksPX#5YKI?i-CluGI)18Ix zS7Vel5!QDy_4>5E&b{u29-N;+gGWzVzJ;#GRX|Ua!)v&SA=m2lI*PkB+)xPI2^KL^ zqnMCjl;oi_A;c&h1cxJWNS?&Dj{5%nR*8U)CwX-hZf)IiI`x7q>`HGIWIodv=u^l@ zNNaBFx3*o_hv-ivcG8*pjpgBV4$6ug-O94&*=DK1c+Q4QT-NKxpp+{;wTWUw<{vCu zthvEeuC(Ek5H_uClY04(QYhcx!y#!4{7L{Fv@ZcWS2xr#tvcH_P7t9sI zk&3OvDlxpQ`wUNBDDuE%K(%Lx9N^Brggsi(JL+qaZj)=G@FGA2g==6rZ8a>GO|PgItW5|#sW7< zH!ckcLfXohy;`Fgl57czHqr&hq$}j-sr1@ViteQi#$zH5q?p_m7a`WaB8Y|ds%|^q z#0y1$5HnsolsE{!9s7qy8R~rmDq3sGm}oJ|sq^LTa<{tY#}l5IH7rJrmK0zg5?3N@ yUSgo#eY1QB36f^G;_R-jg6m3lE#=d&ejtBj29Nf2j75h{%rqecelQ|E%A~d;b5AJcs<3w{OgNTpvXK zGE}l--wQtPb<&_+O%T3(j`F;L6-`=%fh8|197)z)Vzumja1Bva$&`Ch+xd- zR8XR2W46RXe}r!4D^n8oDQ@J`nwX@jjMgo=1ZBfwBE0WYlf~m6bdOK7>-WQ#4I?6M zS{~-%b+=xPz{VukH3m=2IqnG;#GoAZiO#97-|*Wjx6pi|o*e^XM;WIqv%?l|)Z-tN zX+;I_DXFTHu6G|2_(mYH>8UjJx?61xTMZ06w4o_+@GGzQwl`pJ7I1JzSocBo zXO1(}f?gb#nYdxvt>wJSvt8Z#xUI5d^6jd0asDi9fMj(oc0Hje6P*G8ctX3*1+u7#y&j%G$ z@y|^e7sAw&Zf~!S-yaxg;HV2Zw5o`l?&hod#@8i(9jUlLka-2gpldc46+KR zF}tZ#B+`{C>=Q^!NQi`yXd;&BITmK+5Xrp6w8U18ObZv+|cXst?;;Y`qGU5eftS5zq zsN&Yvxg?TOBLP#;V3XW^%zWgkjBo_9!qF(Cu_k52Dkt?J4Cn=rgCGQ8c$orrvPgAg zkl8#*iHtn9Lb1wEGt17hotay3$|m&Ti!@RVs-cN(3aph7JJY=wQ%u$n)c0K&Lf*{8 znGr~#F)=dP@Zm)d1@90O#MlEF0ahS{>(?+0EfxiqgFTuUZ`s+Wv68FbPbCZ6+u`mB zqSlQ{*JL0#gOb9sjHroPF$V^qG{Gli20hzY1Y6!1W5QXrdXamat(s zES5smmJ(VN2@d6fNJ)Ix@$Y1d2=`c9V0anLaZ<5aeQdyBD5Iva3N4{cF+2CjU{)hP zr7uV*Coc($l%I3O)=oCiruT71NT8(4NF^k7a8NCP;z0&A!$;$O%9ckAD+ZIhy_UkI zZ7QoQfGA4BMF`1~LKCK}non0LkDi>SwaZ1S($%Gj2`NFq#X*QYzq82ak9VINnrTG6 z4z#tZQKed2MR9^xyw41@*A{jqQkv-kO&B0suvLAd%%EUD3!RMi+qG(Cs4}vv6hQOZ~K_m=ll8e;$67q?j)C;eo%` zR^;WU7VtDg>69#Yo4P3&GKkTNMOw>$mTRE}Dg>vQTG$+iZTCzcq+pebI_yMTZ`l_w z9~rX}-XG2h=fUn}uGNXLQ7-|G5W1|fMWACM=U!SAHV#7uRJ~CQ-2@F%I&5?xH zbO=4u5DzClJ;?>c;!@FDt>nWlfJi$I@=BT*epPz7g|4B#nb#&K9W{oC_nu}9mT-s^ z+A^3>_h5cFMx=k(g?r|rjyl<3q{MoB102Hvp2{4u7y-k9q!_qJz8_Xj)qX(XazF6#-pCtG0$WKvHZ#H<6XWi5HJ-JPq!L2%d z#(=#S2|O$hPq|QXBD5h07+(8QqAbkFy$7NTj!Z5;IR(bMVz`a|bD)F`QP;ofs2>aj zNvfXOXPK{?eZ?jYL^dLe+a`9C3=?QZSixZVh(Vl*$?Qt!*52>g!x11Z+v$QHa@IBQ3VJTa!ZX`OvSm$+B2 zZ_iVUMJ?k=Nb5~B zz8I~sV7!o2(_{GK0tBJ>OeG;!S-#fOm37%+$^A)LOK@#V2!#j+^S30%pi?rL!~s2m zHW7(JvkPiev=Pf?Q-=&MsSU}4I%dp|YVPly7GP4nxY)<(Ns$QH=jM=gt@bN2!D{g3 zPlGTQuz{O&=~2`$uby67bbQoSLTyd;)v(>aDz)wUqP~dZP356V%HED<&!W3C6y8g6 xYPppojg?UulPDzBX9mF_(JD$TTFbLh_ks107Al1d3OmQ*F64@Ep&?Xj+0M%_{yP8w 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",