From 12db7a6025b4fcbe6afca7611f1e92326c85e934 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Fri, 7 Mar 2025 14:53:22 +0100 Subject: [PATCH] new vectorSelectInput to select vector with names displayed --- R/app_version.R | 2 +- ...lumnSelectInput.R => custom_SelectInput.R} | 99 +++++++++++++++- R/redcap_read_shiny_module.R | 4 +- inst/apps/freesearcheR/app.R | 110 +++++++++++++++++- .../shinyapps.io/agdamsbo/freesearcheR.dcf | 2 +- renv.lock | 47 ++++++++ 6 files changed, 255 insertions(+), 9 deletions(-) rename R/{columnSelectInput.R => custom_SelectInput.R} (53%) diff --git a/R/app_version.R b/R/app_version.R index be55055..a6af51d 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250306_0759' +app_version <- function()'250307_1438' diff --git a/R/columnSelectInput.R b/R/custom_SelectInput.R similarity index 53% rename from R/columnSelectInput.R rename to R/custom_SelectInput.R index a761392..2ca1bf8 100644 --- a/R/columnSelectInput.R +++ b/R/custom_SelectInput.R @@ -17,7 +17,7 @@ #' @return a \code{\link[shiny]{selectizeInput}} dropdown element #' #' @importFrom shiny selectizeInput -#' @keywords internal +#' @export #' columnSelectInput <- function(inputId, label, data, selected = "", ..., col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected") { @@ -80,3 +80,100 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., ) ) } + + + +#' A selectizeInput customized for named vectors +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param data A named \code{vector} object from which fields should be populated +#' @param selected default selection +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' +#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element +#' @export +#' +#' @examples +#' if (shiny::interactive()) { +#' shinyApp( +#' ui = fluidPage( +#' shiny::uiOutput("select"), +#' tableOutput("data") +#' ), +#' server = function(input, output) { +#' output$select <- shiny::renderUI({ +#' vectorSelectInput( +#' inputId = "variable", label = "Variable:", +#' data = c( +#' "Cylinders" = "cyl", +#' "Transmission" = "am", +#' "Gears" = "gear" +#' ) +#' ) +#' }) +#' +#' output$data <- renderTable( +#' { +#' mtcars[, c("mpg", input$variable), drop = FALSE] +#' }, +#' rownames = TRUE +#' ) +#' } +#' ) +#' } +vectorSelectInput <- function(inputId, + label, + data, + selected = "", + ..., + placeholder = "", + onInitialize) { + datar <- if (shiny::is.reactive(data)) data else shiny::reactive(data) + + labels <- sprintf( + IDEAFilter:::strip_leading_ws(' + { + "name": "%s", + "label": "%s" + }'), + datar(), + names(datar()) %||% "" + ) + + choices <- stats::setNames(datar(), labels) + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices, + selected = selected, + ..., + options = c( + list(render = I("{ + // format the way that options are rendered + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + + escape(item.data.name) + ' ' + + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
'; + }, + + // avoid data vomit splashing on screen when an option is selected + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + escape(item.data.name) + + '
'; + } + }")) + ) + ) +} + + diff --git a/R/redcap_read_shiny_module.R b/R/redcap_read_shiny_module.R index 9da0289..6a0ed2b 100644 --- a/R/redcap_read_shiny_module.R +++ b/R/redcap_read_shiny_module.R @@ -254,11 +254,11 @@ m_redcap_readServer <- function(id) { }) output$arms <- shiny::renderUI({ - shiny::selectizeInput( + vectorSelectInput( inputId = ns("arms"), selected = NULL, label = "Filter by events/arms", - choices = arms()[[3]], + data = stats::setNames(arms()[[3]],arms()[[1]]), multiple = TRUE ) }) diff --git a/inst/apps/freesearcheR/app.R b/inst/apps/freesearcheR/app.R index 0a85dab..79061e0 100644 --- a/inst/apps/freesearcheR/app.R +++ b/inst/apps/freesearcheR/app.R @@ -10,7 +10,7 @@ #### Current file: R//app_version.R ######## -app_version <- function()'250306_0759' +app_version <- function()'250307_1438' ######## @@ -64,7 +64,7 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, #' @return a \code{\link[shiny]{selectizeInput}} dropdown element #' #' @importFrom shiny selectizeInput -#' @keywords internal +#' @export #' columnSelectInput <- function(inputId, label, data, selected = "", ..., col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected") { @@ -2828,11 +2828,11 @@ m_redcap_readServer <- function(id) { }) output$arms <- shiny::renderUI({ - shiny::selectizeInput( + vectorSelectInput( inputId = ns("arms"), selected = NULL, label = "Filter by events/arms", - choices = arms()[[3]], + data = stats::setNames(arms()[[3]],arms()[[1]]), multiple = TRUE ) }) @@ -5207,6 +5207,108 @@ clean_date <- function(data){ } +######## +#### Current file: R//vectorSelectInput.R +######## + +library(shiny) + +#' A selectizeInput customized for named vectors +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param data A named \code{vector} object from which fields should be populated +#' @param selected default selection +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' +#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element +#' @export +#' +#' @examples +#' if (shiny::interactive()) { +#' shinyApp( +#' ui = fluidPage( +#' shiny::uiOutput("select"), +#' tableOutput("data") +#' ), +#' server = function(input, output) { +#' output$select <- shiny::renderUI({ +#' vectorSelectInput( +#' inputId = "variable", label = "Variable:", +#' data = c( +#' "Cylinders" = "cyl", +#' "Transmission" = "am", +#' "Gears" = "gear" +#' ) +#' ) +#' }) +#' +#' output$data <- renderTable( +#' { +#' mtcars[, c("mpg", input$variable), drop = FALSE] +#' }, +#' rownames = TRUE +#' ) +#' } +#' ) +#' } +vectorSelectInput <- function(inputId, + label, + data, + selected = "", + ..., + placeholder = "", + onInitialize) { + datar <- if (shiny::is.reactive(data)) data else shiny::reactive(data) + + labels <- sprintf( + IDEAFilter:::strip_leading_ws(' + { + "name": "%s", + "label": "%s" + }'), + datar(), + names(datar()) %||% "" + ) + + choices <- stats::setNames(datar(), labels) + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices, + selected = selected, + ..., + options = c( + list(render = I("{ + // format the way that options are rendered + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + + escape(item.data.name) + ' ' + + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
'; + }, + + // avoid data vomit splashing on screen when an option is selected + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + escape(item.data.name) + + '
'; + } + }")) + ) + ) +} + + + + ######## #### Current file: /Users/au301842/freesearcheR/inst/apps/freesearcheR/ui.R ######## diff --git a/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 601efea..48a5d11 100644 --- a/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -5,6 +5,6 @@ account: agdamsbo server: shinyapps.io hostUrl: https://api.shinyapps.io/v1 appId: 13611288 -bundleId: 9881752 +bundleId: 9899914 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/renv.lock b/renv.lock index a4543d5..8e89df4 100644 --- a/renv.lock +++ b/renv.lock @@ -3529,6 +3529,53 @@ "Maintainer": "Hadley Wickham ", "Repository": "CRAN" }, + "ggalluvial": { + "Package": "ggalluvial", + "Version": "0.12.5", + "Source": "Repository", + "Type": "Package", + "Title": "Alluvial Plots in 'ggplot2'", + "Authors@R": "c( person(given = \"Jason Cory\", family = \"Brunson\", role = c(\"aut\", \"cre\"), email = \"cornelioid@gmail.com\"), person(given = \"Quentin D.\", family = \"Read\", role = 'aut'))", + "Maintainer": "Jason Cory Brunson ", + "Description": "Alluvial plots use variable-width ribbons and stacked bar plots to represent multi-dimensional or repeated-measures data with categorical or ordinal variables; see Riehmann, Hanfler, and Froehlich (2005) and Rosvall and Bergstrom (2010) . Alluvial plots are statistical graphics in the sense of Wilkinson (2006) ; they share elements with Sankey diagrams and parallel sets plots but are uniquely determined from the data and a small set of parameters. This package extends Wickham's (2010) layered grammar of graphics to generate alluvial plots from tidy data.", + "Depends": [ + "R (>= 3.6)", + "ggplot2 (>= 2.2)" + ], + "Imports": [ + "stats", + "dplyr (>= 0.7)", + "tidyr (>= 0.7)", + "lazyeval", + "rlang", + "tidyselect" + ], + "Suggests": [ + "grid", + "alluvial", + "testthat", + "knitr", + "rmarkdown", + "babynames", + "sessioninfo", + "ggrepel", + "shiny (>= 1.4.0.2)", + "htmltools", + "sp (>= 1.4-0)", + "ggfittext (>= 0.6)", + "vdiffr (>= 0.2)" + ], + "License": "GPL-3", + "LazyData": "true", + "URL": "http://corybrunson.github.io/ggalluvial/", + "BugReports": "https://github.com/corybrunson/ggalluvial/issues", + "VignetteBuilder": "knitr", + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Jason Cory Brunson [aut, cre], Quentin D. Read [aut]", + "Repository": "CRAN" + }, "ggeffects": { "Package": "ggeffects", "Version": "2.2.0",