Shiny: dynamic checkboxGroupInput - r

I'm building a Shiny app and I would like to add a dynamic "checkboxGroup" which depends on some other input. More precisely, the user can upload N files, the app makes some calculations, then the output is a table with N columns (one for each file uploaded). At this point I would like the user to be able to select only certain columns, i.e. the ones he/she would like to consider, then the table should update according to the user's choice.
I had a look at some shiny apps on the web, and the closest solution is probably something like
https://shiny.rstudio.com/gallery/datatables-demo.html
but unfortunately in that example we have
checkboxGroupInput("show_vars", "Columns in diamonds to show:",
names(diamonds), selected = names(diamonds))
where diamonds is "known", whereas in my case I don't know how many files the user will upload and so how many columns my table will have.
Any ideas?
Cheers
EDITED:
Here there is the portion of code I'm reffering to. It works, the user can upload N excel files with same number of rows. The app returns a tab with N columns (the second column of each file uploaded).
Ideally, now I would like to add N check boxes (all selected initially), and the user can uncheck the columns he/she doesn't want to consider. Say he/she uncheck 2 columns, then the tab changes into a tab with N-2 columns.
Thanks again
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(data.table)
library(dplyr)
library(xlsx)
sidebar <- dashboardSidebar(
width = 350,
sidebarMenu(
tags$style(HTML(".sidebar-menu li a { color: #f4f8e8; }")),
menuItem("Computations",tabName = "tab1", icon = icon("file-text-o"))
))
body <- dashboardBody(
tags$style(".content-wrapper {background-color: #c3f9fa;}"),
style = "color: black;",
tabItems(
tabItem(
tabName = "tab1",
h2("upload files"),
tags$style(HTML(" .progress-bar { background-color: #1dbcbf; }")),
fileInput("csvs",
label="Upload CSVs here",
multiple = TRUE),
textInput(inputId="num_files",
label="number of files uploaded",
value = "",
width = NULL,
placeholder = NULL),
actionButton(inputId = "display_tab", label = "Display Tab after computations"),
box(title = "tab after computations:",tableOutput("all_cols"),width = 100),
checkboxGroupInput(inputId="show_vars", "Columns to keep:", choices = "selectedData", selected = "selectedData")
)))
dbHeader <- dashboardHeader(title = 'Exercise')
ui <- dashboardPage(
skin = "black",
dbHeader,
sidebar,
body
)
server <- function(input, output) {
options(shiny.maxRequestSize=260*1024^2)
computations <- function(num_files, db){
num_files <- as.numeric(num_files)
N <- nrow(db)/num_files #number of rows for 1 file (they all have same size)
tab_to_be_displayed <- db[1:N,2]
for(j in (1:(num_files - 1))){
left <- j*N+1
right <- (j+1)*N
tab_to_be_displayed <- cbind(tab_to_be_displayed, db[left:right,2])
}
return(tab_to_be_displayed)
}
mycsvs<-reactive({
rbindlist(lapply(input$csvs$datapath, fread),
use.names = TRUE, fill = TRUE)
})
selectedData <- reactive({
names(computations(input$num_files, mycsvs()))
})
observeEvent(input$display_tab,{
numero <- input$num_files
comp_tab <- computations(numero, mycsvs())
output$all_cols <- renderTable(comp_tab, align = 'c', rownames = TRUE, colnames = TRUE, digits = 3)
})
}
shinyApp(ui = ui, server = server)

I simplified the code a bit to demonstrate how the group checkboxes could work.
In simplifying, I kept the data as a list from the csv files. Then for computations extracted the second column from all data frames in the list, then used select to show columns based on the checkboxes.
The checkbox items are based on the names of the second columns of the data, with a default of all selected.
Instead of entering the number of files that were read, it is now computed based on the length of the list of data.
Let me know if this is closer to what you need.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(data.table)
library(dplyr)
library(xlsx)
sidebar <- dashboardSidebar(
width = 350,
sidebarMenu(
tags$style(HTML(".sidebar-menu li a { color: #f4f8e8; }")),
menuItem("Computations",tabName = "tab1", icon = icon("file-text-o"))
))
body <- dashboardBody(
tags$style(".content-wrapper {background-color: #c3f9fa;}"),
style = "color: black;",
tabItems(
tabItem(
tabName = "tab1",
h2("upload files"),
tags$style(HTML(" .progress-bar { background-color: #1dbcbf; }")),
fileInput("csvs",
label="Upload CSVs here",
multiple = TRUE),
textOutput("numfiles"),
box(title = "tab after computations:",tableOutput("all_cols"),width = 100),
uiOutput("checkboxes")
)))
dbHeader <- dashboardHeader(title = 'Exercise')
ui <- dashboardPage(
skin = "black",
dbHeader,
sidebar,
body
)
server <- function(input, output) {
options(shiny.maxRequestSize=260*1024^2)
db <- reactiveVal(list())
computations <- function(){
req(input$checkboxes)
do.call(cbind, lapply(db(), "[", , 2)) %>%
select_if(names(.) %in% input$checkboxes)
}
observeEvent(input$csvs, {
db(lapply(input$csvs$datapath, fread))
})
output$numfiles <- renderText(paste("Number of files: ", length(db())))
output$checkboxes <- renderUI({
choice_list <- unlist(lapply(db(), function(x) colnames(x)[2]))
checkboxGroupInput("checkboxes", "Columns to keep:", choices = choice_list, selected = choice_list)
})
output$all_cols <- renderTable(computations(), align = 'c', rownames = TRUE, colnames = TRUE, digits = 3)
}
shinyApp(ui = ui, server = server)

It sounds like you need your checkboxGroupInput to be reactive. That requires a combination of renderUI on your server script, and uiOutput on your ui script.

Related

Dynamic `updateTabItems()` in Shiny get executed later than it is supposed to

In the following example, I use an actionLink() in "Tab1" to switch the display to "Tab2", then to update the text in the textInput() with "iris" and finally to click the button to display the actual data.
For an unknown reason, this switch is executed after the Sys.sleep() which is after. This lead to a non-desired behavior since shinyjs::click() for instance try to trigger a button that does not exist yet and thereby the 'iris' table is not displayed. I would have expected the tab to be switched first, then to get the Sys.sleep().
Can someone explain to me why Shiny is behaving like that and how to perform the expected behavior please?
library(shiny)
library(shinydashboard)
library(shinydashboardPlus) # shinydashboardPlus_0.7.5 // devtools::install_version("shinydashboardPlus", version = "0.7.5", repos = "http://cran.us.r-project.org")
library(shinyjs)
available_data_sets <- c("mtcars", "iris")
ui_welcome <- fluidPage(actionLink(inputId = "switch_tab", label = "Switch tab, update text with 'iris' & click button", icon = icon("hand-point-right")))
ui_search <- fluidPage(
textInput(inputId = "dataset_name", label = "Select data set", value = ""),
actionButton(inputId = "display_tab", label = "Display selected set"),
br(),
tableOutput('table'))
ui <- dashboardPagePlus(
collapse_sidebar = TRUE,
title = "Minimal",
header = dashboardHeaderPlus(
title = "Test",
enable_rightsidebar = FALSE,
rightSidebarIcon = "gears",
fixed = FALSE),
sidebar = dashboardSidebar(
sidebarMenu(
id = "left_sidebar",
menuItem("Tab1", tabName = "tab1", icon = icon("home")),
menuItem("Tab2", tabName = "tab2", icon = icon("search")))
),
body = dashboardBody(
useShinyjs(),
tabItems(tabItem(tabName = "tab1", ui_welcome),
tabItem(tabName = "tab2", ui_search)))
)
server <- function(input, output, session) {
# RENDER DATA
observeEvent(input$display_tab, {
print("Within observeEvent 'display_tab'")
selected <- input$dataset_name
print(paste0("Value of 'input$dataset_name' received: ", selected))
if(!isTruthy(selected)) return(NULL)
if(!selected %in% available_data_sets) return(NULL)
output$table <- renderTable(if(selected == "iris") iris else mtcars)
})
# SWITCH TAB & TRIGGER BTN
observeEvent(input$switch_tab, {
print("Within observeEvent 'switch_tab'")
print("updateTabItems"); updateTabItems(session, inputId = "left_sidebar", selected = "tab2")
print("updateTextInput 1"); updateTextInput(inputId = "dataset_name", value = "")
print("updateTextInput 2"); updateTextInput(inputId = "dataset_name", value = "iris")
print("Sys.sleep"); Sys.sleep(3)
print("shinyjs::click"); shinyjs::click(id = "display_tab")
})
}
shinyApp(ui, server)
Shiny reactivity is based on reaction on single events. You are basically trying to do two actions in reaction to a single event (reconfigure interface then act on it). It won't work as the reconfiguration will actually be done in between reaction code. You are trying to circumvent this by waiting using Sys.sleep function. This will only pause the whole application and it will wake up as if nothing happened. Try to put a longer sleep time and you will notice that the UI will be non responsive.
The solution is to refactor your code to be data centric and not user centric. What you want is to be able to select and display a dataset in two different ways. One "automatically" by clicking on a link the other manually by providing the dataset name and click on a button.
Here I give some flesh to the dataset that will be able to redisplay on change and provide two ways to set it's state.
server <- function(input, output, session) {
# reactive value to store selected dataset
state <- reactiveValues(selected=NULL)
# AUTO RENDER DATA on selected dataset change
output$table <- renderTable({
if(!is.null(state$selected)) {
if(state$selected == "iris") iris else mtcars
}
})
# manual select dataset
# already on tab so no need to switch
observeEvent(input$display_tab, {
if(!isTruthy(input$dataset_name) || !(input$dataset_name %in% available_data_sets)) {
state$selected <- NULL
} else {
state$selected <- input$dataset_name
}
})
# automatic selection through actionlink
# select dataset and switch tab
observeEvent(input$switch_tab, {
state$selected <- "iris"
updateTabItems(session, inputId = "left_sidebar", selected = "tab2")
})
}

R Shiny Reactive Radio Buttons

In the following example I have two static radio buttons representing the mtcars and iris datasets. Upon making a selection, the user is presented with a second set of buttons based on data in each dataset. For the mtcars dataset, the user can filter by selecting from the unique list of carburetors or in the case of the iris dataset, the species. Now, I require another set of buttons based on the carb/species buttons to further filter the data. Say, for the mtcars dataset the list of unique gear selections associated with the carburetor selection and for the Iris the unique set of petal lengths. Given the real world application of what I'm trying to accomplish, there is no getting away from requiring a third set of reactive radio buttons. I just have no clue how to approach the next step.
ui.R
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "My DFS Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("MTCARS", tabName = "dashboard", icon = icon("dashboard")),
menuItem("IRIS", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
fluidRow (
column(width = 3,
box(title = "Select Dataset", width = NULL, status = "primary", background = "aqua",
radioButtons ("mydataset",
"",
inline = TRUE,
c("mtcars", "iris"),
selected = "mtcars"))),
column(width = 3,
box(title="Select Filter One", width = NULL, status = "primary", background = "aqua",
uiOutput("filter1"))),
column(width = 3,
box(title = "Select Fitler Two", width = NULL, status = "primary", background = "aqua",
uiOutput("filter2")))
)
)
)
server.R
library(tidyverse)
server <- function(input, output, session) {
data("mtcars")
data("iris")
cars <- mtcars
flowers <- iris
carbs <- cars %>%
dplyr::select(carb)
carbs <- carbs$carb
carbs <- as.data.frame(carbs)
carbs <- unique(carbs$carb)
spec <- flowers %>%
dplyr::select(Species)
spec <- unique(spec$Species)
vards <- reactive ({
switch(input$mydataset,
"mtcars" = carbs,
"iris" = spec,
)
})
output$filter1 <- renderUI({
radioButtons("fil1","", choices=vards())
})
}
Perhaps this may be helpful. You can add another reactive expression to filter your dataset and obtain choices for the third set of radio buttons. I included isolate so that the third set of buttons does not react to changes in the dataset (only changes in the second radio buttons, which is dependent already on the dataset). Please let me know if this is what you had in mind for behavior.
server <- function(input, output, session) {
data("mtcars")
data("iris")
cars <- mtcars
flowers <- iris
vards1 <- reactive({
switch(input$mydataset,
"mtcars" = unique(cars$carb),
"iris" = unique(flowers$Species),
)
})
vards2 <- reactive({
req(input$fil1)
if (isolate(input$mydataset) == "mtcars") {
cars %>%
filter(carb == input$fil1) %>%
pull(gear) %>%
unique()
} else {
flowers %>%
filter(Species == input$fil1) %>%
pull(Petal.Length) %>%
unique()
}
})
output$filter1 <- renderUI({
radioButtons("fil1","", choices=vards1())
})
output$filter2 <- renderUI({
radioButtons("fil2","", choices=vards2())
})
}

Shiny Dashboard formatting issue

library(needs)
needs(
shiny,
ggplot2,
tidyverse,
shinydashboard,
DT
)
source("~/functions.R",local = T)
# Define UI for application that draws a histogram
header = dashboardHeader(
# tags$li(class = "dropdown",
# tags$style(".main-header {max-height: 80px}"),
# tags$style(".main-header .logo {height: 80px}")),
#title = tags$img(src='logo.png',height='100',width='200')
)
sidebar = dashboardSidebar(
menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F,
fileInput("file","Upload CSV files",multiple=TRUE,accept=("text/comma"))),
menuItem(text = 'Simulate',tabName = 'simulate',icon=icon('chart-line'),
helpText('Simulation Parameters'),
radioButtons('type',"Please choose the type of analysis:",choices = list("Gender" = 1,"US Minority Status" = 2),selected = 1),
sliderInput("numSims","Number of simulations:",min = 1, max = 10000,step = 1000,value = 10000),
sliderInput("numYears","Number of years to simulate:",min = 1,max = 5,value = 3,step = 1),
numericInput('turnover','Total Turnover', value = 10),
sliderInput('promoRate','Set Promo rate', value = 25, min = 1, max = 100, step = 5),
sliderInput('growthRate','Set growth rate',value = 0,min=0,max=100,step = 1),
helpText('0% Growth Rate assumes a flat, constant headcount'),
actionButton('go',label = "Update"),width = 4)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'data',
fluidRow(wellPanel(
fileInput(
inputId = 'file',
label = "File Upload:",
accept = c("csv", ".csv")))),
wellPanel(DT::dataTableOutput('table'))),
tabItem(
tabName = 'simulate',
fluidRow(
wellPanel(
DT:::dataTableOutput('simDataTable')
))
)
))
ui = shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server = server <- function(input, output) {
options(shiny.maxRequestSize = 30 * 1024 ^ 2)
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath)
})
output$table = renderDataTable(dataset(), filter = 'top',options = list(scrollX = TRUE))
simulate = eventReactive(input$go,{
req(input$numSims,input$type)
x = dataset()
temp = dataSim(x,type=input$type,
numSims = input$numSims)
})
simulateAvg = reactive({
x = simulate()
y = x %>% group_by(Role) %>% summarise(mean(freq))
})
output$simDataTable = renderDataTable(simulateAvg())
}
shinyApp(ui,server)
I'm having some trouble with two issues.
1.) The formatting of the shiny dashboard is odd. The text on the side bar seems very compacted and not what other shiny dashboards look like. I'm not sure what the issue is.
2.) After upload, a table is suppose to appear on the dashboard body but it doesn't
3.) Once a table appears and I head to the simulate tab, will the dashboard body change accordingly and display the simulateAvgData set that I populated?
The dataSim function is from the source file on top. I don't receive any errors when I run anything so looking for guidance and inputs to whether or not this shiny dashboard work as intended. I'm newer to the dashboard packages from shiny.
You have a couple of issues here. You do not need a fileInput statement inside dashboardBody. Next, within dashboardSidebar, you can define fileInput at the top level of menuItem (option 1 in the code below), or a sub-level of the first menuItem (option 2 below). In either case, you need to have a menuItem with a tabName where you want to display the file that was read in. Once you read the input file, you need to select the appropriate tab to see the displayed data. Try this code
header <- dashboardHeader()
### option 1: fileInput at the first menuItem level
# sidebar <- dashboardSidebar(width=320,
# menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F),
# fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv"))
# )
### option 2 - fileInput as a subitem
sidebar <- dashboardSidebar(width=320,
menuItem("Full data",tabName="noData",icon=icon("table"),startExpanded = F, ## data not displayed for this tabName
menuItem("Full_data",tabName="Data", icon=icon("table")),
fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'Data',
fluidRow(DTOutput('table')))
))
ui <- shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server <- function(input, output, session) {
data1 <- reactive({
req(input$file)
data <- read.csv(input$file$datapath,sep = ",", header = TRUE)
})
output$table <- renderDT(data1())
}
shinyApp(ui,server)

How to combine multiple inputs in one vector in shiny. Number of inputs depends on user's choice

I'm trying to create an UI in which user can choose some objects (as many as they want) and their respective weights. The weight input fields appear only when there's more than one object and increase as the user selects more objects. This part already works.
What I need is a vector that holds all the weights saved in the w1, w2 and so on.
I've tried using for loops and sapply with get() function but can't access the input$w1, input$w2 etc.
library(shiny)
# Create list of objects
object_list <- vector()
object_list <- paste0("O_", 1:10)
names(object_list) <- paste("Object", 1:10)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic UI"),
dashboardSidebar(
width = 700,
fluidRow(
column(7, selectInput("chosen_objects", "Chosen objects", choices = object_list, multiple = TRUE, width = "100%")),
column(5, uiOutput("weights"))
)
),
dashboardBody(
fluidPage(tabBox(width=2500,
tabPanel(
title = "Table"
)
)
)
)
)
server <- function(input,output) {
objects_number <- reactive({length(input$chosen_objects)})
output$weights <- renderUI({
if (is.na(objects_number()) | objects_number() <= 1)
return(NULL)
lapply(1:objects_number(), function(i) {
id <- paste0("w", i)
textInput(id, paste("Weight of", input$chosen_objects[i]), value = input[[id]], width = "50%", placeholder = "%")
})
})
}
shinyApp(ui, server)
Is there a way to collect the dynamic inputs in one vector or list?
I have made a few changes and based on your code I think you are good enough to see and get them by yourself. Let me know if you have any questions -
library(shiny)
# Create list of objects
object_list <- vector()
object_list <- paste0("O_", 1:10)
names(object_list) <- paste("Object", 1:10)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic UI"),
dashboardSidebar(
width = 700,
fluidRow(
column(7, selectInput("chosen_objects", "Chosen objects",
choices = object_list, multiple = TRUE, width = "100%")),
column(5, uiOutput("weights"))
)
),
dashboardBody(
fluidPage(tabBox(width=2500,
tabPanel(
title = "Table",
verbatimTextOutput("weight_output")
)
)
)
)
)
server <- function(input,output) {
objects_number <- reactive({length(input$chosen_objects)})
output$weights <- renderUI({
if (is.na(objects_number()) | objects_number() <= 1)
return(NULL)
lapply(gsub("[A-Z]+_", "", input$chosen_objects), function(i) {
id <- paste0("w", i)
textInput(id, paste("Weight of", paste0("O_", i)),
value = NULL, width = "50%", placeholder = "%")
})
})
output$weight_output <- renderPrint({
req(input$chosen_objects)
sapply(paste0("w", gsub("[A-Z]+_", "", input$chosen_objects)), function(a) input[[a]])
})
}
shinyApp(ui, server)

Placing ifelse statements into a render expression Shiny

In the below code, I am attempting to create an input to show all of my markets, or just a selection within a plot and a data table. I am doing this through, or attempting, through ifelse statements within my render functions, however I am getting errors, and neither the plot or data table will render. They do render without the if else statements. I have included an Example data set to hopefully help place in context.
ui <- dashboardPage(
dashboardHeader(title = "Example"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "Dashboard"),
menuItem("Example", tabName = "example"))),
dashboardBody(
tabItems(
tabItem(tabName = "Dashboard",
fluidRow(
valueBoxOutput("example"))),
tabItem(tabName = "example",
fluidRow(
box(title = "Example",
plotOutput("plotexample"), width = 12),
box(title = "Data Selection",
selectInput("market","Market(s): ", c(unique(data$marketnum),"All"),multiple = T, selectize = T, selected = "All"))),
fluidRow(
box(DT::dataTableOutput("markettable"), width = 12))))))
server <- function(input,output) {
ExampleAllMarkets <- reactive({
ExampleData %>%
group_by(Event,marketnum) %>%
summarise(ItemCount = n_distinct(ItemNumber))
})
Example <- reactive({
ExampleData %>%
filter(marketnum == input$market) %>%
group_by(Event,marketnum) %>%
summarise(PolicyCount = n_distinct(Policy_Number_9_Digit))
})
output$example <- renderValueBox({
valueBox(
paste0("44", "%"), "example", icon = icon("car"),
color = "red"
)
})
I am placing ifelse statements within my render blocks reactive to whether or not "All" is selected.
output$plotexample <- renderPlot({
ifelse(input$market=="All",
ggplot(Example(), aes(x=MBC_Number, y=ItemCount)) +
geom_bar(stat="identity"),
ggplot(ExampleAllMarkets(), aes(x=marketnum, y=ItemCount))
+
geom_bar(stat="identity"))
})
output$markettable <- DT::renderDataTable({
ifelse(input$market == "All",
ExampleAllMarkets(),
Example())
})
}
shinyApp(ui,server)
Example Data in csv format
marketnum,ItemNumber
2,118
7,101
1,109
2,109
10,101
4,102
8,100
12,103
5,106
13,116
5,112
10,103
7,113
9,114
10,112
6,114
2,116
11,113
3,107
13,102
8,107
10,109
12,110
1,120
4,106
8,116
2,112
2,106
11,101
6,108
11,107
10,111
6,120
10,118
11,119
13,117
You probably cannot use ifelse in this scenario.
Analyzing the source code for ifelse, since a plot object is not so simple, it does not just return the plot itself, but
rep(plot, length.out = 1)
or equivalently plot[1] which is just the dataset of the plot. A plot object has a length > 1 and for those, ifelse only returns its first element.
This can be easily confirmed by evaluating
> ifelse(T, c(1, 2), c(3, 4))
[1] 1
So the render function cannot draw anything, since it's input is just this dataset.
You will simply have to use the regular if else.

Resources