How to check if a checkbox has been selected using ShinyDashboard? - r

I have created an app using ShinyDashboard that has one checkboxInput. If you click on it, you will see two checkboxGroupInput where you can select 1 or 2 choices.
The idea is that if you click 1 option, you will subset your dataframe with your individual choice, or if you click both options, you will subset your dataframe with those two options.
However, I am having problems to verify which option of the checkboxGroupInput the user has selected.
Here is a reproducible example. As you can see, if you select both, you end in the first if statement, subsetting two columns. However, if you select one option (setosa, for example), you are still subsetting by the two, because it doesn't recognise the choice that you have selected. However, if you select "virginica" it is subsetted.
Moreover, it appears this warning all the time.
Warning in if (c("setosa", "virginica") %in% input$species_choice) { :
the condition has length > 1 and only the first element will be used
The code:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("App1", tabName = "App1", icon = icon("th"))
)
),
dashboardBody(
fluidRow(
tabItems(
tabItem(tabName = "App1",
sidebarPanel(
checkboxInput(inputId = "species", label = "Select species"),
conditionalPanel(
condition = "input.species",
style = "margin-left: 20px;",
checkboxGroupInput("species_choice", "Choose the species:",
choices = c("setosa", "virginica"), selected = c("setosa", "virginica"))),
),
mainPanel(
dataTableOutput("table")
)
)
)
)
)
)
server <- function(input, output, session) {
mytables <- reactive({
if(input$species){
df_setosa <- iris[iris$Species=="setosa",]
df_virginica <- iris[iris$Species=="virginica",]
df_both <- rbind(df_setosa, df_virginica)
if(c("setosa", "virginica") %in% input$species_choice){
print("both")
return(df_both)
}
if("setosa" %in% input$species_choice){
print("setosa")
return(df_setosa)
}
if("virginica" %in% input$species_choice){
print("virginica")
return(df_virginica)
}
}
})
output$table <- renderDataTable({
mytables()
})
}
shinyApp(ui, server)
I have tried this way too, but it doesn't work:
if(input$species_choice == "setosa"){
print("setosa")
return(df_setosa)
}
if(input$species_choice == "virginica"){
print("virginica")
return(df_virginica)
}
if(input$species_choice == c("setosa, virginica"){
print("both")
return(df_both)
}
Does anyone know how to help me, please?
Thanks in advance

There is no need to subset your dataframe before the if conditions, and you don't need all those if conditions. You can simply check if the first button is clicked (my first if condition), and if it is then you can subset your dataframe with the selected specie(s).
Note that if you select none of the two species, the table is empty (but you can change this behavior).
mytables <- reactive({
if (input$species) {
iris[iris$Species %in% input$species_choice, ]
} else {
iris
}
})

I found another solution:
I just have to include if(all(c(OPTIONS) ....
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("App1", tabName = "App1", icon = icon("th"))
)
),
dashboardBody(
fluidRow(
tabItems(
tabItem(tabName = "App1",
sidebarPanel(
checkboxInput(inputId = "species", label = "Select species"),
conditionalPanel(
condition = "input.species",
style = "margin-left: 20px;",
checkboxGroupInput("species_choice", "Choose the species:",
choices = c("setosa", "virginica"), selected = c("setosa", "virginica"))),
),
mainPanel(
dataTableOutput("table")
)
)
)
)
)
)
server <- function(input, output, session) {
mytables <- reactive({
if(input$species){
df_setosa <- iris[iris$Species=="setosa",]
df_virginica <- iris[iris$Species=="virginica",]
df_both <- rbind(df_setosa, df_virginica)
if(all(c("setosa", "virginica") %in% input$species_choice)){
print("both")
return(df_both)
}
if(all(c("setosa") %in% input$species_choice)){
print("setosa")
return(df_setosa)
}
if(all(c("virginica") %in% input$species_choice)){
print("virginica")
return(df_virginica)
}
}
})
output$table <- renderDataTable({
mytables()
})
}
shinyApp(ui, server)

Related

How to make this R Shiny table example reactive?

I found the following code that creates an RShiny app that allows users to visualize a data table based on certain columns that they select. See following code (should run on it's own):
library(shiny)
library(ggplot2) # for the diamonds dataset
ui <- fluidPage(
title = "Examples of DataTables",
sidebarLayout(
sidebarPanel(
conditionalPanel(
'input.dataset === "diamonds"',
checkboxGroupInput("show_vars", "Columns in diamonds to show:",
names(diamonds), selected = names(diamonds))
)
),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("diamonds", DT::dataTableOutput("mytable1")),
)
)
)
)
server <- function(input, output) {
# choose columns to display
diamonds2 = diamonds[sample(nrow(diamonds), 1000), ]
output$mytable1 <- DT::renderDataTable({
DT::datatable(diamonds2[, input$show_vars, drop = FALSE])
})
}
shinyApp(ui, server)
My question is, how can I change this dataset to be reactive, such that instead of always using the diamonds dataset, a data table would result based on what dataset I select from a dropdown menu? Such as adding a selectInput() argument?
If you are just trying to have different tables show based on a selectInput(), then this will work for a small number of tables. Essentially, the output table is an if else statement, which displays a different table depending on what's selected in the selectInput().
library(shiny)
library(ggplot2) # for the diamonds dataset
ui <- fluidPage(
title = "Examples of DataTables",
sidebarLayout(
sidebarPanel(
selectInput("Datasetchoice", "Dataset", choices = c("diamonds", "iris", "mtcars")), #Choose which dataset to display
conditionalPanel(
'input.dataset === "diamonds"',
checkboxGroupInput("show_vars", "Columns in diamonds to show:",
names(diamonds), selected = names(diamonds))
)
),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("diamonds", DT::dataTableOutput("mytable1"))
)
)
)
)
server <- function(input, output) {
# choose columns to display
diamonds2 = diamonds[sample(nrow(diamonds), 1000), ]
output$mytable1 <- DT::renderDataTable({
if(input$Datasetchoice == "diamonds") { #If else statement, show a different table depending on the choice
DT::datatable(diamonds2[, input$show_vars, drop = FALSE])
} else if (input$Datasetchoice == "iris") {
DT::datatable(iris)
} else if(input$Datasetchoice == "mtcars") {
DT::datatable(mtcars)
}
})
}
shinyApp(ui, server)
Here is a solution that updates the checkboxes and the table upon selection of a different dataset. No limit on the number of datasets. But the datasets must be dataframes.
library(shiny)
library(datasets) # for the datasets
ui <- fluidPage(
title = "Examples of DataTables",
sidebarLayout(
sidebarPanel(
selectInput("dat",
label = "Choose data",
choices = c("cars", "mtcars", "faithful", "iris", "esoph", "USArrests")),
checkboxGroupInput("datavars", "Columns to show",
choices = NULL,
selected = NULL)
),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("dataset", DT::dataTableOutput("mytable1")),
)
)
)
)
server <- function(input, output, session) {
r <- reactiveValues(
dataobj = NULL
)
observeEvent(input$dat, {
dataobj <- r$dataobj <- get(input$dat, 'package:datasets')
datavars <- names(dataobj)
freezeReactiveValue(input, "datavars")
updateCheckboxGroupInput(session, "datavars",
choices = datavars,
selected = datavars)
})
output$mytable1 <- DT::renderDataTable({
req(r$dataobj, input$datavars)
DT::datatable(r$dataobj[, input$datavars, drop = FALSE])
})
}
shinyApp(ui, server)

How can I do UpdateSelectInput work correctly?

I'm trying to update a selectInput in shinyapp but it doesn't work correctly. When I change the input of datalab_data, the choices in the selectinput datalab_columns don't change and it keep the column names of Events. I hope someone can help me with this part of code:
library(shiny)
library(shinydashboard)
library(dplyr)
header <- dashboardHeader(
title = "dashboard_shiny", titleWidth = 250
)
sidebar <- dashboardSidebar(
width = 250,
sidebarMenu(
menuItem("Data Lab", tabName = "datalab", icon = icon("flask"))
)
)
body <- dashboardBody(
tabItems(
tabItem("datalab",
fluidRow(
column(6, wellPanel(radioButtons("datalab_data", "Select data source:", choices = c("Events", "Worknotes", "Occupations")))),
column(6, wellPanel(selectInput("datalab_columns", "Select data columns:", choices = "All Columns", multiple = T)))
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
observeEvent(input$datalab_data != "", {
if(input$datalab_data == "Events"){
columns <- events() %>% colnames()
}
if(input$datalab_data == "Worknotes"){
columns <- worknotes() %>% colnames()
}
if(input$datalab_data == "Occupations"){
columns <- occupations() %>% colnames()
}
updateSelectInput(session = session, inputId = "datalab_columns", choices = c("All Columns", columns), selected = "All Columns")
})
}
shinyApp(ui, server)

Navigate in the same dynamic tabPanel based on if condition in shiny app

I have the shiny app below in which I create tab panels based on a column of a dataframe. Then based on the radiobutton selected I display either a plot ot a table of either iris or mtcars datasets.
The issue is that if for example Im in Table mode of mtcars dataset and press the Plot mode I want to remain to the mtcars panel and see the mtcars plot instead of moving back to the iris panel. How could I achieve that?
Uni<-data.frame(NAME=c("Iris","Mtcars"))
# app.R ##
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
dbHeader <- dashboardHeaderPlus(
title = "Tabs"
)
ui <- dashboardPagePlus(
dbHeader,
dashboardSidebar(
uiOutput("r")
),
dashboardBody(
useShinyjs(),
tags$hr(),
tabsetPanel(
id ="tabA",
type = "tabs",
tabPanel("Front",icon = icon("accusoft")),
tabPanel("Data", icon = icon("table"),
uiOutput("dyntab")
)
)
)
)
server <- function(input, output) {
output$dyntab<-renderUI({
do.call(tabsetPanel,
c(id='tabB',
type="tabs",
lapply(1:nrow(Uni), function(i) {
tabPanel(Uni[i,],icon = icon("table"),
if(input$radioV2=="Table"){
renderDataTable({
if(input$tabB=="Iris"){
datatable(iris)
}
else{
datatable(mtcars)
}
})
}
else{
renderPlot({
if(input$tabB=="Iris"){
plot(iris)
}
else{
plot(mtcars)
}
})
}
)
}))
)
})
output$r<-renderUI({
if(input$tabA=="Front"){
return(NULL)
}
else{
radioButtons("radioV2", label = "Choose Mode",
choices = c("Table","Plot"),
selected = "Table")
}
})
}
shinyApp(ui = ui, server = server)
You had a few things going on, one is that the creation of dyntab was happening every time you change a tab, which is now been fixed to render only once on start
We shall take advantage of the shinyjs with its show and hide functions to show the radioButtons instead of creating it all the time with renderUI
Im still not 100% on the using the above approach in the dyntab as you can see I had to create the id for the div in order to show and hide it, this happens because it assigns random idto the tables and the charts you're rendering
I've also took advantage of hidden function to hide the div upon start
Uni <- data.frame(NAME=c("Iris","Mtcars"))
options(stringsAsFactors = F)
# app.R ##
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
dbHeader <- dashboardHeaderPlus(
title = "Tabs"
)
ui <- dashboardPagePlus(
dbHeader,
dashboardSidebar(
hidden(
radioButtons("radioV2", label = "Choose Mode",choices = c("Table","Plot"), selected = "Table")
)
),
dashboardBody(
useShinyjs(),
tags$hr(),
tabsetPanel(
id ="tabA",
type = "tabs",
tabPanel("Front",icon = icon("accusoft")),
tabPanel("Data", icon = icon("table"), uiOutput("dyntab")
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$tabA,{
if(input$tabA == "Front"){
hide("radioV2")
}
else{
show("radioV2")
}
})
output$dyntab <- renderUI({
do.call(tabsetPanel,
c(id='tabB',
type="tabs",
lapply(1:nrow(Uni), function(i) {
tabPanel(Uni[i,],icon = icon("table"),
div(id = paste0("Table",Uni$NAME[i]),DT::renderDataTable({
if(Uni$NAME[i] == "Iris"){
datatable(iris)
}else{
datatable(mtcars)
}
})),
hidden(div(id = paste0("Plot",Uni$NAME[i]),renderPlot({
if(Uni$NAME[i] == "Iris"){
plot(iris)
}else{
plot(mtcars)
}
})
))
)
})
)
)
})
observeEvent(input$radioV2,{
print(paste0(input$radioV2,input$tabB))
if(input$radioV2 == 'Table'){
show(paste0("Table",input$tabB))
hide(paste0("Plot",input$tabB))
}else{
hide(paste0("Table",input$tabB))
show(paste0("Plot",input$tabB))
}
})
}
shinyApp(ui = ui, server = server)

Refreshing Filter and Table

I have the following code:
library(shiny)
library(shinydashboard)
library(rhandsontable)
header <- dashboardHeader(title = "Sample", titleWidth = 375)
sidebar <- dashboardSidebar(width = 270,
sidebarMenu(id="mymenu",
menuItem(text = "Home", tabName = "tabCars", icon = icon("home", class="home"))
))
body <- dashboardBody (
tabItems(
tabItem(tabName = "tabCars",
fluidRow(
column(width = 2,
selectInput(
inputId = "selected_CarCylinders",
label = "Car Cylinders",
choices = mtcars$cyl,
selectize = TRUE,
width = "250px",
multiple = FALSE
)),
column(width = 2, style = "margin-top: 25px",
actionButton("deleteBtn", "Delete Selected Cylinders")),
column(width = 1, style = "margin-top: 25px",
actionButton("refreshBtn", "Refresh Filter/Chart")),
rHandsontableOutput("carDT")
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
output$carDT <- renderRHandsontable({
df <- mtcars
rhandsontable(df, stretchH = "all")
})
observeEvent(input$deleteBtn, {
# need help here
})
observeEvent(input$refreshBtn, {
# need help here
})
}
shinyApp(ui, server)
I need help writing what would go into the input$deleteBtn and input$refreshBtn sections of the server side. If you run the code as is, the idea is to select the number of cylinders from mtcars, then click the Delete button to remove all those entries from the table and filter; however, the filter and table would only update after clicking the refresh button.
While permanently delete screams a SQLite database to me, you could achieve this by using a reactiveVal to store the dataframe and call req to only refresh the table when you click the refreshBtn (in this case, you also have to click it to display the table at the start of the app).
server <- function(input, output, session) {
# Create a `reactiveVal` and set a value to it
df <- reactiveVal()
df(mtcars)
output$carDT <- renderRHandsontable({
req(input$refreshBtn)
rhandsontable(df(), stretchH = "all")
})
observeEvent(input$deleteBtn, {
data <- dplyr::filter(df(), cyl != input$selected_CarCylinders)
# Update `selectInput` to filter out the choices too (for good measure)
updateSelectInput(session, "selected_CarCylinders", choices = data$cyl)
# Update the `reactiveVal` value
df(data)
})
}

Shiny: problems with actionButton (no trespassing signal even

I'm building a Shiny app and for the last two days I'm being blocked on the following step: I've put a "Submit" button on a typeform and apparently there are no problems, but everytime I run the app I can't click on it because for the very beginning it shows me a "no trespassing" signal disallowing me to do nothing else.
Here's the code I'm using:
# Packages ----
if(require("pacman")=="FALSE"){
install.packages("pacman")
}
library(pacman)
pacman::p_load(dplyr, tidyr, shiny, shinydashboard)
# Global scope ----
dish <- c("Salad", "Spaghetti Carbonara", "Scrambled eggs")
allergens <- c("sesame", "lactose", "eggs")
keywords <- c("veggie", "pasta", "none")
dishes <- data.frame(dish, allergens, keywords)
# Function to label mandatory fields ----
labelMandatory <- function(label) {
tagList(
label,
span("*", class = "mandatory_star")
)
}
appCSS <- ".mandatory_star { color: red; }" #to make the asterisk red
MandatoryFields_dishes <- c(names(dishes[,-3]))
fields_dishes <- c(names(dishes))
ui <- dashboardPage(
dashboardHeader(title = "sample"),
dashboardSidebar(
sidebarMenu(
menuItem("Dishes", tabName = "dishes")
)
),
dashboardBody(
# Dishes
tabItems(
tabItem(tabName = "dishes",
tabsetPanel(
tabPanel("Typeform",
fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
titlePanel("Dish introduction"),
div(
id="form",
textInput("dish", labelMandatory("Dishes"), ""),
textInput("allergens", label = "Allergens",""),
textInput("keyword", label = "Keyword", ""),
actionButton("submit", "Submit", class="btn-primary")
)
))
))
))
)
server <- function(input, output) {
observe({
mandatoryFilled_dishes <-
vapply(MandatoryFields_dishes,
function(x) {
!is.null(input[[x]]) && input[[x]] != ""
},
logical(1))
mandatoryFilled_dishes <- all(mandatoryFilled_dishes)
shinyjs::toggleState(id = "submit", condition = mandatoryFilled_dishes)
})
}
shinyApp(ui, server)
I guess I'm missing something on the server. If someone could help me I'll be very grateful, lots of thanks in advance.

Resources