Related
In the shiny app below I want when a choice is selected in one of the 2 widgets then this choice to be unavailable or hidden from the other widget in a way that it will not be possible for both of them to have the same value at the same time.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
choices = c("RC", "TP", "IY", "HP","Population")
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
pickerInput(
inputId = "rtihcol1",
label = "Selection for column 1",
choices = choices,
selected = "Population",
options = list(
`actions-box` = TRUE),
multiple = F
),
#the 6th dropdown of the 1st column
#the dropdown from which you select between RC, TP, IY, HP
pickerInput(
inputId = "rtih",
label = "Selection for column 2",
choices = choices,
selected = "RC",
options = list(
`actions-box` = TRUE),
multiple = F
)),
dashboardBody()
)
server <- function(input, output, session) {
observeEvent(input$rtih, {
updateSelectInput(session, "rtihcol1", choices = choices[!choices %in% input$rtih])
})
observeEvent(input$rtihcol1, {
updateSelectInput(session, "rtih", choices = choices[!choices %in% input$rtihcol1])
})
}
shinyApp(ui, server)
One option would be to use observeEvent and updateSelectInput to dynamically set the choices for the selectInputs. Note: To make this work it's important to set the selected choice to different values when starting the app.
library(shiny)
library(shinydashboard)
choices <- c("Pop", "RC", "RT")
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
selectInput("Pr", "Select the price for analysis", choices = choices, multiple = F, selected = choices[1]),
selectInput("Pr2", "Select the price for analysis", choices = choices, multiple = F, selected = choices[2])
),
dashboardBody()
)
server <- function(input, output, session) {
observeEvent(input$Pr, {
updateSelectInput(session, "Pr2", choices = choices[!choices %in% input$Pr])
})
observeEvent(input$Pr2, {
updateSelectInput(session, "Pr", choices = choices[!choices %in% input$Pr2])
})
}
shinyApp(ui, server)
I want to use fileInput for Workbook and Sheet upload along with renderDataTable to upload a file and perform analysis and download the output in different formats. Couldn't figured out how to accomplish this. My minimum working example is below:
library(tidyverse)
library(shiny)
library(shinydashboard)
library(DT)
ui <-
dashboardPage(
skin = "green",
dashboardHeader(
title = "Test",
titleWidth = 280
),
dashboardSidebar(
width = 280,
sidebarMenu(
menuItem(text = "File(s) Upload", tabName = "Files", icon = icon("file-upload")),
menuItem(text = "Output", tabName = "Out1", icon = icon("file-upload"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "Files",
fluidRow(
column(
width = 4,
inputPanel(
fileInput(inputId = "File1", label = "File", multiple = TRUE, accept = c(".xlsx")),
selectInput(inputId = "Sheet1", label = "Select sheet", choices = NULL, selected = NULL)
)
)
)
),
tabItem(
tabName = "Out1",
fluidRow(column(width = 10, strong("Data")), align = "center"),
br(),
fluidRow(dataTableOutput("Data1"))
)
)
)
)
server <-
function(input, output){
thedata <-
reactive(
iris %>%
filter(Species == "setosa")
)
output$Data1 <-
renderDataTable(
thedata()
, extensions = "Buttons"
, options = list(
dom = "Bfrtip"
, buttons = c("copy", "csv", "excel", "pdf", "print")
)
)
}
runApp(
list(ui = ui, server = server)
, launch.browser = TRUE
)
Edited
Want to select both Excel Workbook and Sheet.
Here is a solution where you can choose any Excel file and dynamically change which sheet to read.
Add the following to your server:
# Populate the drop down menu with the names of the different Excel Sheets, but
# only after a new file is supplied
observe({
sheet_names <- readxl::excel_sheets(input$File1$datapath)
shiny::updateSelectInput(
inputId = "Sheet1",
choices = sheet_names,
selected = sheet_names[[1]] # Choose first sheet as default
)
}) %>%
bindEvent(input$File1)
# When the drop down meny is populated, read the selected sheet from the Excel
# file
thedata <- reactive({
req(input$Sheet1)
readxl::read_xlsx(input$File1$datapath, sheet = input$Sheet1)
})
The rest of your code can stay the same. Under is a full reprex.
Full example, based on your code
library(tidyverse)
library(shiny)
library(shinydashboard)
library(DT)
ui <-
dashboardPage(
skin = "green",
dashboardHeader(
title = "Test",
titleWidth = 280
),
dashboardSidebar(
width = 280,
sidebarMenu(
menuItem(text = "File(s) Upload", tabName = "Files", icon = icon("file-upload")),
menuItem(text = "Output", tabName = "Out1", icon = icon("file-upload"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "Files",
fluidRow(
column(
width = 4,
inputPanel(
fileInput(inputId = "File1", label = "File", multiple = TRUE, accept = c(".xlsx")),
selectInput(inputId = "Sheet1", label = "Select sheet", choices = NULL, selected = NULL)
)
)
)
),
tabItem(
tabName = "Out1",
fluidRow(column(width = 10, strong("Data")), align = "center"),
br(),
fluidRow(dataTableOutput("Data1"))
)
)
)
)
server <- function(input, output){
# Populate the drop down menu with the names of the different Excel Sheets, but
# only after a new file is supplied
observe({
sheet_names <- readxl::excel_sheets(input$File1$datapath)
shiny::updateSelectInput(
inputId = "Sheet1",
choices = sheet_names,
selected = sheet_names[[1]]
)
}) %>%
bindEvent(input$File1)
# When the drop down meny is populated, read the selected sheet from the Excel
# file
thedata <- reactive({
req(input$Sheet1)
readxl::read_xlsx(input$File1$datapath, sheet = input$Sheet1)
})
output$Data1 <-
renderDataTable(
thedata()
, extensions = "Buttons"
, options = list(
dom = "Bfrtip"
, buttons = c("copy", "csv", "excel", "pdf", "print")
)
)
}
runApp(
list(ui = ui, server = server)
, launch.browser = TRUE
)
Note: I see that you have multiple = TRUE in fileInput(). If you want to supply multiple Excel files at the same time, you need to add some logic to handle which file to read the sheet names from, and which sheet names to use for which file. I would probably set multiple to FALSE.
Provided you have your excel file locally with this structure (sheet name is 'Sheet1'):
structure(list(x = c(1, 2, 5), y = c(2, 9, 6)), class = "data.frame", row.names = c(NA,
-3L))
Let's say you upload it via file upload input. Then your code should be as follows:
library(tidyverse)
library(shiny)
library(shinydashboard)
library(DT)
ui <-
dashboardPage(
skin = "green",
dashboardHeader(
title = "Test",
titleWidth = 280
),
dashboardSidebar(
width = 280,
sidebarMenu(
menuItem(text = "File(s) Upload", tabName = "Files", icon = icon("file-upload")),
menuItem(text = "Output", tabName = "Out1", icon = icon("file-upload"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "Files",
fluidRow(
column(
width = 4,
inputPanel(
fileInput(inputId = "File1", label = "File", multiple = F, accept = c(".xlsx")),
selectInput(inputId = "sheet_name", label = "Select sheet", choices = 'Sheet1', selected = 'Sheet1')
)
)
)
),
tabItem(
tabName = "Out1",
fluidRow(column(width = 10, strong("Data")), align = "center"),
br(),
fluidRow(DT::DTOutput("Data1"))
)
)
)
)
server <- function(session, input, output){
values <- reactiveValues(
infile = NULL
)
thedata <- reactive({
if(is.null(input$File1))
return(NULL)
values$infile <- input$File1
df <- xlsx::read.xlsx(values$infile$datapath, encoding="UTF-8", sheetName = input$sheet_name)
# do some calculations here, add additional column 'z'
df <- df %>% mutate(z=x+y)
df
})
output$Data1 <- DT::renderDT(server=FALSE,{
# Load data
data <- thedata()
# Show data
datatable(data, extensions = 'Buttons',
options = list(
dom = "Bfrtip",
buttons = c("copy", "csv", "excel", "pdf", "print")
))
})
}
shinyApp(ui, server)
I'm working on a shinydashboard that is secured using shinymanager and I am having trouble. I want to make a tab appear or disappear based on two bits of information. I have saved in my shinymanager credentials a user code that says what their home organization is. In my app I also have a selectInput that allows the user to choose a particular user code. I have tabs that I would like to show only if the user code for that user's credentials match the selected user code from selectInput. So for example, in the below example, if I had in res_auth a field called 'unit' with the choices aa, bb, cc, dd, ee - and the user who logs in is in unit aa, and they choose aa from the selectInput, then the iris tabs would show up - but if they choose bb they would not see the iris tabs.
library(shiny)
library(shinythemes)
library(shinymanager)
library(shinydashboard)
library(tidyverse)
options(warn=-1)
data(iris)
data(mtcars)
tabset1 = tabsetPanel(id = "mtcars",
tabPanel(id = "mtplots","mtcars plots",
fluidRow(box(title = "Plot1", plotOutput("mtcarsplot1"))
)),
tabPanel(id = "mttable","MTcars tables",
fluidRow(box(title = "Table 1", tableOutput("mtcarstable1")))
))
tabset2 = tabsetPanel(id = "iris",
tabPanel(id = "iris","iris plots",
fluidRow(box(title = "Plot1", plotOutput("irisplot1"))
)),
tabPanel(id = "mttable","iris tables",
fluidRow(box(title = "Table 1", tableOutput("iristable1")))
))
# Define UI for application that draws a histogram
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
selectInput("which unit", "Choose a unit", choices = c("aa", "bb", "cc", "dd")),
menuItem("MTCARS", tabName = "mt", icon = icon("user-tie")),
selectInput("mtvar", "Choose a variable", choices = colnames(mtcars)),
# RIGHT HERE
menuItem("IRIS", icon = icon("envelope-open-text"), tabName = "ir"),
selectInput("irvar", "Choose a variable", choices = colnames(iris))
)
),
dashboardBody(
tabItems(
tabItem("ir", tabset2),
tabItem("mt", tabset1)
)
)
)
ui <- secure_app(ui, enable_admin = TRUE)
# Begin Server ----------------------------------------------
server <- function(input, output, session) {
res_auth <- secure_server(
check_credentials = check_credentials("mycredentials.sqlite")
)
output$mtcarsplot1=renderPlot({
ggplot(mtcars, aes_string(x = input$mtvar)) + stat_bin(nbins = input$irislines)
})
output$irisplot1=renderPlot({
ggplot(iris, aes_string(x = input$irvar)) + stat_bin(nbins = input$mtlines)
})
output$mtcarstable1=renderTable({
head(mtcars, input$mtlines)
})
output$iristable1=renderTable({
head(iris, input$irislines)
})
}
shinyApp(ui, server)
First replace the line below # RIGHT HERE with:
uiOutput("test"),
Then add a function like this to the server:
output$test <- renderUI({
if(input$`which unit`=="aa") {
menuItem("IRIS", icon = icon("envelope-open-text"), tabName = "ir")
}
})
You will need to add a condition to the if to require their credentials to match in your situation, but this is essentially what you want.
I am trying to make a shinydashboard with a bunch of different tabs that show up for different types of data. What I want is when a certain tabItem is selected, for a selectInput item to show up in the sidebar. (Eventually I would like for this to happen for multiple tabs, but I will work on just one tab for now.)
Here's an executable example of what I want:
library(shiny)
library(shinythemes)
library(shinydashboard)
library(tidyverse)
options(warn=-1)
data(iris)
data(mtcars)
tabset1 = tabsetPanel(id = "mtcars",
tabPanel(id = "mtplots","mtcars plots",
fluidRow(box(title = "Plot1", plotOutput("mtcarsplot1"))
)),
tabPanel(id = "mttable","MTcars tables",
fluidRow(box(title = "Table 1", tableOutput("mtcarstable1")))
))
tabset2 = tabsetPanel(id = "iris",
tabPanel(id = "iris","iris plots",
fluidRow(box(title = "Plot1", plotOutput("irisplot1"))
)),
tabPanel(id = "mttable","iris tables",
fluidRow(box(title = "Table 1", tableOutput("iristable1")))
))
# Define UI for application that draws a histogram
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("MTCARS", tabName = "mt", icon = icon("user-tie")),
selectInput("mtvar", "Choose a variable", choices = colnames(mtcars)),
sliderInput("mtlines", "Number of lines", 1,50,10),
# **I would like a conditionalPanel here such that if the tab mtplots is selected, a selectInput as below shows up - but only is visible for that tab **
#selectInput("colorvar", "choose a color", choices = c("red", "yellow", "green", "blue"))
menuItem("IRIS", icon = icon("envelope-open-text"), tabName = "ir"),
selectInput("irvar", "Choose a variable", choices = colnames(iris)),
sliderInput("irislines", "Number of lines", 1,50,10)
)
),
dashboardBody(
tabItems(
tabItem("ir", tabset2),
tabItem("mt", tabset1)
)
)
)
# Begin Server ----------------------------------------------
server <- function(input, output, session) {
output$mtcarsplot1=renderPlot({
ggplot(mtcars, aes_string(x = input$mtvar)) + geom_histogram()
})
output$irisplot1=renderPlot({
ggplot(iris, aes_string(x = input$irvar)) + geom_histogram()
})
output$mtcarstable1=renderTable({
head(mtcars, input$mtlines)
})
output$iristable1=renderTable({
head(iris, input$irislines)
})
}
shinyApp(ui, server)
You can use input$mtcars to determine which tab in the tabsetPanel is active. To render a dynamic/conditional UI element, you can use uiOutput/renderUI. In renderUI, I use req to only render it if the correct tabPanel is chosen:
library(shiny)
library(shinythemes)
library(shinydashboard)
library(tidyverse)
data(iris)
data(mtcars)
tabset1 = tabsetPanel(id = "mtcars",
tabPanel(id = "mtplots","mtcars plots",
fluidRow(box(title = "Plot1", plotOutput("mtcarsplot1"))
)),
tabPanel(id = "mttable","MTcars tables",
fluidRow(box(title = "Table 1", tableOutput("mtcarstable1")))
))
tabset2 = tabsetPanel(id = "iris",
tabPanel(id = "iris","iris plots",
fluidRow(box(title = "Plot1", plotOutput("irisplot1"))
)),
tabPanel(id = "mttable","iris tables",
fluidRow(box(title = "Table 1", tableOutput("iristable1")))
))
# Define UI for application that draws a histogram
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("MTCARS", tabName = "mt", icon = icon("user-tie")),
selectInput("mtvar", "Choose a variable", choices = colnames(mtcars)),
sliderInput("mtlines", "Number of lines", 1,50,10),
# **I would like a conditionalPanel here such that if the tab mtplots is selected, a selectInput as below shows up - but only is visible for that tab **
uiOutput("UI_conditional_input"),
menuItem("IRIS", icon = icon("envelope-open-text"), tabName = "ir"),
selectInput("irvar", "Choose a variable", choices = colnames(iris)),
sliderInput("irislines", "Number of lines", 1,50,10)
)
),
dashboardBody(
tabItems(
tabItem("ir", tabset2),
tabItem("mt", tabset1)
)
)
)
# Begin Server ----------------------------------------------
server <- function(input, output, session) {
output$mtcarsplot1=renderPlot({
ggplot(mtcars, aes_string(x = input$mtvar)) + geom_histogram()
})
output$irisplot1=renderPlot({
ggplot(iris, aes_string(x = input$irvar)) + geom_histogram()
})
output$mtcarstable1=renderTable({
head(mtcars, input$mtlines)
})
output$iristable1=renderTable({
head(iris, input$irislines)
})
output$UI_conditional_input <- renderUI({
req(input$mtcars == "mtcars plots")
selectInput("colorvar", "choose a color", choices = c("red", "yellow", "green", "blue"))
})
}
shinyApp(ui, server)
I have a dashboard where I would like to show a table, but I cant figure out why my table is not showing. If I replace the table for example with some text, h2(....) it does show. I would like to click on "Species" and have the table show on the right when clicking it.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(sidebarMenu(
menuItem(
"Species",
tabName = "Species",
icon = NULL,
switchInput(
inputId = "long1",
onLabel = "Go",
offLabel = "NoGo",
value = T
),
actionButton("Gobtn", "Get data"),
menuItem("Specs", tabName = "Specs", icon = NULL)
)
)),
dashboardBody(tabItems(
tabItem(tabName = "Species",
DT::renderDataTable("Table1")),
tabItem(tabName = "Specs",
h2("Hi"))
))
)
server.r
server <- shinyServer(function(input, output, session) {
output$Table1 <- DT::renderDataTable({
iris
})
})
shinyApp(ui, server)
Few things to get your code up and running here. Couple have been noted by other contributors.
We need to use DT::dataTableOutput("Table1") on the UI side as renderDataTable will not work here, that is the server side function.
The other would be that using the switchInput within the menuItem may confused the app, as these are not standard parameters to pass into the function. From what I can see from your code, which is a common challenge, is that you want to be able to show this switchInput only when the 'Species' tab is selected. We can account for this using conditionalPanel. To do this, we can set id = "tabs" within the sidebarMenu and then reference this sidebarMenu within the conditionalPanel:
conditionalPanel(
condition = "input.tabs== 'Species' ",
switchInput(
inputId = "long1",
onLabel = "Go",
offLabel = "NoGo",
value = T
)
)
To finish, I have altered the layouts of the ui.R and server.R, as the shinyApp function was not needed for the app to work with the server and ui files. This is how I lay out my dashboards. It may show you a few other possible ways you can use the app structure within Shiny, but equally you could just align the changes to the basic layout.
ui.R
header <- dashboardHeader(title = "Basic dashboard")
sidebar <- dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem(
"Species",
tabName = "Species",
icon = NULL),
conditionalPanel(
condition = "input.tabs== 'Species' ",
switchInput(
inputId = "long1",
onLabel = "Go",
offLabel = "NoGo",
value = T
)
),
actionButton("Gobtn", "Get data"),
menuItem("Specs", tabName = "Spec", icon = NULL)
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "Species",
DT::dataTableOutput("Table1")),
tabItem(tabName = "Spec",
h2("Hi"))
)
)
dashboardPage(skin = "blue", header = header, sidebar = sidebar, body = body)
server.R
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(DT)
shinyServer(function(input, output, session){
output$Table1 <- DT::renderDataTable({
datatable(iris)
})
})
You need to change/add some part of the dashboardBody, see Using shiny modules and shinydashboard: shiny.tag error
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(sidebarMenu(
menuItem(
"Species",
tabName = "Species",
icon = NULL,
switchInput(
inputId = "long1",
onLabel = "Go",
offLabel = "NoGo",
value = T
),
actionButton("Gobtn", "Get data")
)
)),
dashboardBody(tags$div(
tabName = "Species",
fluidRow(box(DT::dataTableOutput("Table1"))), class = "tab-content"
))
)
server.r
server <- shinyServer(function(input, output, session) {
output$Table1 <- DT::renderDataTable({
iris
})
})
shinyApp(ui, server)