Related
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)
The following shiny app works well but has a problem: it displays errors or warnings because of the dynamic filtering.
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
),
fluidRow(),
hr(),
fluidRow(style = 'background: white;',
div(
box(
title= "Much filters",
style = 'height:420px; background: gainsboro; margin-top: 5vw;',
width=3,
solidHeader = TRUE,
uiOutput("continent"),
uiOutput("country")
),
tabBox(
width = 9,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",
DT::dataTableOutput("awesometable")
)
)
)
)
)
)
)
)
library(data.table)
library(shiny)
library(gapminder
server <- function(input, output, session) {
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
# #
datasub <- reactive({
df[df$continent == input$continent,]
})
output$country = renderUI({
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
#
datasub2 <- reactive({
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
datasub2()
})
}
shinyApp(ui, server)
First part of the problem:
Errors started displaying once I included a filtering method I found here:
https://stackoverflow.com/a/51153769/12131069
After trying different methods, this is the one that works pretty close to what I am looking for.
However, once the app is loaded, this appears in the console:
Logical subscripts must match the size of the indexed input.
Input has size 392 but subscript datasub2()$country== input$country has size 0.
Second part of the problem:
The app is being developed with the {golem} package, which is really helpful when building scalable and maintainable shiny infrastructure. However, I don't get what I am expecting (and I get the errors). How can I solve that? How can I "modularize" the workaround I found to create interdependent filters?
I have been trying something like:
#' awesome_app_ui UI Function
#'
#' #description A shiny Module.
#'
#' #param id,input,output,session Internal parameters for {shiny}.
#'
#' #noRd
#'
#' #import DT
#' #import plotly
#' #import htmltools
#' #import shinydashboard
#' #importFrom reactable JS
#' #importFrom shiny NS tagList
mod_chiffres_cles_ts_ui <- function(id){
ns <- NS(id)
df <- gapminder::gapminder
tabBox(width = 9,title = "Results",d = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",DT::dataTableOutput("awesometable"))
}
#' awesome_app Server Functions
#'
#' #noRd
mod_chiffres_cles_ts_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
# #
datasub <- reactive({
df[df$continent == input$continent,]
})
output$country = renderUI({
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
#
datasub2 <- reactive({
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
datasub2()
})
}
Thanks!
Once you use req() appropriately, your program works fine.
library(shiny)
library(data.table)
library(shiny)
library(gapminder)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
),
fluidRow(),
hr(),
fluidRow(style = 'background: white;',
div(
box(
title= "Much filters",
style = 'height:420px; background: gainsboro; margin-top: 5vw;',
width=3,
solidHeader = TRUE,
uiOutput("continent"),
uiOutput("country")
),
tabBox(
width = 9,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",
DT::dataTableOutput("awesometable")
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
datasub <- reactive({
req(input$continent)
df[df$continent == input$continent,]
})
output$country = renderUI({
req(datasub())
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
datasub2 <- reactive({
req(datasub(),input$country)
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
req(datasub2())
datasub2()
})
}
shinyApp(ui, server)
You can also use modules as shown below. You may need to adjust where you want to place your selectInputs.
library(shiny)
library(data.table)
library(shiny)
library(gapminder)
moduleServer <- function(id, module) {
callModule(module, id)
}
mod_chiffres_cles_ts_ui <- function(id){
ns <- NS(id)
tagList(
box(
title= "Filter",
style = 'height:420px; background: gainsboro; margin-top: 3vw;',
#width=3,
solidHeader = TRUE,
uiOutput(ns("mycontinent"))
)
)
}
mod_chiffres_cles_ts_server <- function(id,dat,var){
moduleServer( id, function(input, output, session){
ns <- session$ns
df <- isolate(dat())
output$mycontinent = renderUI({
selectizeInput(inputId = ns("continent"),
label = paste(var, ":"),
choices = unique(df[,var]),
selected = unique(df[,var])[1])
})
#print(var)
return(reactive(input$continent))
})
}
mod_chiffres_cles_ds_server <- function(id,dat,var,value){
moduleServer( id, function(input, output, session){
df <- isolate(dat())
datasub <- reactive({
val = as.character(value())
df[df[[as.name(var)]] == val,]
})
#print(var)
return(reactive(as.data.frame(datasub())))
})
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
column(6,mod_chiffres_cles_ts_ui("gap1"),
mod_chiffres_cles_ts_ui("gap2")
),
column(6,style = 'background: white;',
div(
tabBox(
width = 12,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:560px;',"Awesome results !",
style="zoom: 90%;",
DTOutput("awesometable")
)
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
dfa <- reactive(gapminder)
session$userData$settings <- reactiveValues(df1=NULL,df2=NULL)
rv <- reactiveValues()
var1 <- mod_chiffres_cles_ts_server("gap1",dfa,"continent")
observeEvent(var1(), {
data1 <- mod_chiffres_cles_ds_server("gap1",dfa,"continent", var1 )
session$userData$settings$df1 <- data1()
var21 <- mod_chiffres_cles_ts_server("gap2",data1,"country")
df21 <- mod_chiffres_cles_ds_server("gap2",data1,"country", var21 )
session$userData$settings$df2 <- df21()
print(var21)
})
df22 <- reactive(session$userData$settings$df1)
var22 <- mod_chiffres_cles_ts_server("gap2",df22,"country")
observeEvent(var22(), {
print(var22())
data2 <- mod_chiffres_cles_ds_server("gap2",df22,"country",var22)
session$userData$settings$df2 <- data2()
})
output$awesometable <- renderDT({
datatable(session$userData$settings$df2)
})
}
shinyApp(ui, server)
I am creating a shiny dashboard that displays data tables in the body. I am trying to add a sidebar on the side with checkboxgroup that filters the data table. Right now the check boxes show but title and the option names are missing. If I do not use the sidebar and put the checkboxes in the dashboard body it does show. But I am trying to put in sidebar or fixed on the side of the page.
library(shiny)
library(shinydashboard)
library(tidyverse)
df <- mpg
header <- dashboardHeader(
title = "NSCLC Market Share"
)
body <- dashboardBody(
fluidRow(
column(width = 9,
tabBox(width = NULL,
title = "MarketShare",
id = "tabset1", height = "250px",
tabPanel("Incidence",
tableOutput('mpg_tbl'),
br(),
tabPanel("Prevalence", "Tab content 2")
)
)
)
))
sidebar <- dashboardSidebar(box(width = NULL, status = "warning",
checkboxGroupInput('modelFilter', "Select model",
choices =
unique(df$model),
selected = unique(df$model)
)),
br(),
box(width = NULL, status = "warning",
uiOutput("classFilter"),
checkboxGroupInput('classFilter', "Select class",
choices = unique(df$class),
selected = unique(df$class)
))
)
ui <- dashboardPage(
header,
sidebar,
body
)
server = function(input, output) {
filtData <- reactive({
df %>%
filter(model %in% input$modelFilter) %>%
filter(class %in% input$classFilter ) %>%
group_by(manufacturer) %>%
summarise(count = n())
})
output$mpg_tbl <- renderTable(
filtData()
)
}
# Run the application
shinyApp(ui = ui, server = server)
The issue is because of box, if you remove that it works -
library(shiny)
library(shinydashboard)
library(tidyverse)
df <- mpg
header <- dashboardHeader(
title = "NSCLC Market Share"
)
body <- dashboardBody(
fluidRow(
column(width = 9,
tabBox(width = NULL,
title = "MarketShare",
id = "tabset1", height = "250px",
tabPanel("Incidence",
tableOutput('mpg_tbl'),
br(),
tabPanel("Prevalence", "Tab content 2")
)
)
)
))
sidebar <- dashboardSidebar(checkboxGroupInput('modelFilter', "Select model",
choices =
unique(df$model),
selected = unique(df$model)
),
br(),
checkboxGroupInput('classFilter', "Select class",
choices = unique(df$class),
selected = unique(df$class)
)
)
ui <- dashboardPage(
header,
sidebar,
body
)
server = function(input, output) {
filtData <- reactive({
df %>%
filter(model %in% input$modelFilter) %>%
filter(class %in% input$classFilter ) %>%
group_by(manufacturer) %>%
summarise(count = n())
})
output$mpg_tbl <- renderTable(
filtData()
)
}
# Run the application
shinyApp(ui = ui, server = server)
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)
})
}
I am trying to build a shiny dashboard app, where I process the input data and produce summary statistics based on the user supplied grouping variables. The last step, where I am stuck is to
implement a working function , which enables the user to select to display only a subset of the columns after the calculation of the summary statistics.
My attempt is in the lines after output$select_col in global.R . Right now each time I try to use the selector shiny crashes with the error "incorrect number of dimensions".
global.R
# Shiny
library(shiny)
library(shinydashboard)
library(shinyjs)
# Data tools
library(dplyr)
library(tidyr)
library(tibble)
library(data.table)
server.R
server <- function(input, output) {
raw_tables<-reactive({
mtcars
})
output$cyl <- renderUI({
selectInput(inputId = "cyl",
label = "Which number of cyl to consider",
choices = c(4,6,8),
selected = NULL,
multiple=TRUE)
})
filtered_tables<-
reactive({
if(is.null(input$cyl)){
data_filtered <- raw_tables()
}
else{
data_filtered <- raw_tables() %>% filter(cyl %in% input$cyl)
}
})
new_statistics <- reactive({
if(is.null(filtered_tables())){
return(NULL)
}
if(length(input$grouping_variables) == 0){
op <- filtered_tables() %>%
ungroup()
} else {
op <- filtered_tables() %>%
group_by_(.dots = input$grouping_variables)
}
op %>% #
summarise(nr_cars = n(),
mean_mpg = mean(mpg,na.rm=T),
sd_mpg = sd(mpg,na.rm=T))
})
nice_table <-reactive({
if(is.null(new_statistics())){
return(NULL)
}
DT::datatable(new_statistics(),
colnames = c(
"nbr cars"="nr_cars" ,
"mean mpg"="mean_mpg",
"sd mpg"="sd_mpg"
), selection = list(target = 'column') , extensions = c('ColReorder'), options = list(colReorder = TRUE)
) %>%
DT::formatRound(columns=c(
"nbr cars" ,
"mean mpg",
"sd mpg"),
digits=2)
})
output$select_col <- renderUI({
if(is.null(nice_table())){
return(NULL)
}
selectInput("col", "Select columns:", choices = colnames(nice_table()), selected=NULL, multiple=TRUE)
})
output$statistics = DT::renderDataTable({
if(length(input$col)>0)
{
return(DT::datatable(nice_table()[, colnames(nice_table()) %in% input$col]))
}
else
{
return(NULL)
}
})
}
ui.R
dbHeader <- dashboardHeader(title = "test",
titleWidth = 250)
sidebar <- dashboardSidebar(
width = sidebarWidth,
br(),
sidebarMenu(
menuItem(text = "Data View",
tabName = "dat_view",
icon = icon("cloud-download")
)
)
)
body <- dashboardBody(
# Add shinyJS mini-sidebar
shinyjs::useShinyjs(),
tabItems(
tabItem(tabName = "dat_view",
fluidPage(
sidebarLayout(
sidebarPanel(width=2,
selectInput(inputId = 'grouping_variables',
label = 'Which grouping var?',
choices = c("cyl","gear","carb"),
selected = NULL,
multiple=TRUE,
selectize=TRUE),
uiOutput("cyl"),
uiOutput("select_col")
)
,
mainPanel(
tabsetPanel(id="dat_view_tabs",
tabPanel(
'statistics',
DT::dataTableOutput(outputId='statistics')
)
)
)
)))))
ui <- dashboardPage(skin = "blue",
header = dbHeader,
sidebar = sidebar,
body = body)