new vectorSelectInput to select vector with names displayed

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'250306_0759'
+app_version <- function()'250307_1438'

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 '<div style=\"padding: 3px 12px\">' +
+                   '<div><strong>' +
+                      escape(item.data.name) + ' ' +
+                   '</strong></div>' +
+                   (item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
+                 '</div>';
+        },
+
+        // avoid data vomit splashing on screen when an option is selected
+        item: function(item, escape) {
+        item.data = JSON.parse(item.label);
+        return '<div>' +
+                 escape(item.data.name) +
+               '</div>';
+        }
+      }"))
+    )
+  )
+}
+
+

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
       )
     })

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 '<div style=\"padding: 3px 12px\">' +
+                   '<div><strong>' +
+                      escape(item.data.name) + ' ' +
+                   '</strong></div>' +
+                   (item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
+                 '</div>';
+        },
+
+        // avoid data vomit splashing on screen when an option is selected
+        item: function(item, escape) {
+        item.data = JSON.parse(item.label);
+        return '<div>' +
+                 escape(item.data.name) +
+               '</div>';
+        }
+      }"))
+    )
+  )
+}
+
+
+
+
 ########
 #### Current file: /Users/au301842/freesearcheR/inst/apps/freesearcheR/ui.R 
 ########

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

renv.lock

@@ -3529,6 +3529,53 @@
       "Maintainer": "Hadley Wickham <hadley@rstudio.com>",
       "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 <cornelioid@gmail.com>",
+      "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) <doi:10.1109/INFVIS.2005.1532152> and Rosvall and Bergstrom (2010) <doi:10.1371/journal.pone.0008694>. Alluvial plots are statistical graphics in the sense of Wilkinson (2006) <doi:10.1007/0-387-28695-0>; 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) <doi:10.1198/jcgs.2009.07098> 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",