andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-09-12 09:59:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

new vectorSelectInput to select vector with names displayed

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-03-07 14:53:22 +01:00
parent 469c7b01ad
commit 12db7a6025
No known key found for this signature in database
6 changed files with 255 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/app_version.R
View file

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

99
R/columnSelectInput.R → R/custom_SelectInput.R
View file

@ -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>';
}
}"))
)
)
}

4
R/redcap_read_shiny_module.R
View file

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

110
inst/apps/freesearcheR/app.R
View file

@ -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
########

2
inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf
View file

@ -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

47
renv.lock
View file

@ -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",