Create a reactive variable depending on active Tab on R Shiny - r

I have this simple app and I would like to be able to "catch" the active tab.
For example, if I'm on "tab1", my selectInput at the top would be c("a","b","c") but it would change if I am on the other tab
I want to create a variable active_tab that would be dynamic but I have no idea how to do it.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
title="Shiny Dashboard",
header = shinydashboardPlus::dashboardHeader(
title = "Example",
leftUi = tagList(
uiOutput("reactive_ui")
)),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem("tab1",tabName = "tab1"),
menuItem("tab2",tabName = "tab2")
)
),
body = dashboardBody(
tabItems(
tabItem("tab1"),
tabItem("tab2")
)
)
),
server = function(input, output) {
output$reactive_ui =renderUI({
if (active_tab == "tab1") choice = c("a","b","c","d")
if (active_tab == "tab2") choice = c("e","f","g")
selectInput("select", NULL,choices = choice )
})
}
)

sidebarMenu contains an id parameter that can be used to retrieve the name of the active tab on the server side.
If it is just the selectInput you want to update on the tab change, then have a look at updateSelectInput so that you can update the choices without having to re-render the input every time the tab changes. It also means the input is defined once the application opens.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
title = "Shiny Dashboard",
header = shinydashboardPlus::dashboardHeader(
title = "Example",
leftUi = tagList(
selectInput("select", NULL, choices = c("a", "b", "c", "d"))
)
),
sidebar = dashboardSidebar(
sidebarMenu(
id = "tab",
menuItem("tab1", tabName = "tab1"),
menuItem("tab2", tabName = "tab2")
)
),
body = dashboardBody(
tabItems(
tabItem("tab1"),
tabItem("tab2")
)
)
),
server = function(input, output, session) {
observeEvent(input$tab, {
if (input$tab == "tab1") {
choices <- c("a", "b", "c", "d")
} else if (input$tab == "tab2") {
choices <- c("e", "f", "g")
}
updateSelectInput(session, "select", choices = choices)
})
}
)

Related

How do i include input widgets under menuSubItem in shiny dashboard sidebar?

How is it possible to include a control widget under the menuSubItem in the sidebar of a shiny app?
This is my trial:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
ui <- dashboardPage(
### Header -----
dashboardHeader(title = "Example App"),
### Sidebar -----
dashboardSidebar(
sidebarMenu(
menuItem(
text = "A",
tabName = "analytics",
icon = icon("signal"),
startExpanded = TRUE,
menuSubItem(text = "a",
icon = NULL,
pickerInput(
inputId = "Id086",
label = "Placeholder",
choices = c("a", "b", "c", "d"),
options = list(
title = "This is a placeholder")
)
),
menuSubItem(text = "b",
icon = NULL)
)
)
),
dashboardBody(
)
)
## Server-function -----
server <- function(input, output) {
}
# Run the application
shinyApp(ui = ui, server = server)
However, the desired input does not appear within the app. I managed it to include the input widget under any of the menu items but i failed to make it appear under menuSubItems.
menuSubItems are intended to navigate tabItems in the body - that is why they can't have child elements.
You can use nested menuItems to place additional inputs in the sidebar (please see the below example) which "behave" differently when childfull / childless.
When a menuItem is childfull it accepts the parameters expandedName and startExpanded.
When a menuItem is childless it accepts the parameters tabName and selected.
A menuSubItem is always childless.
library(shiny)
library(shinyWidgets)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Example App"),
dashboardSidebar(sidebarMenu(
menuItem(
text = "A",
# tabName = "analytics", # childfull menuItems ignore the tabName parameter they use expandedName instead
icon = icon("signal"),
startExpanded = TRUE,
menuItem(
text = "a",
menuSubItem(
text = "a1",
tabName = "tab_a1",
icon = NULL
),
pickerInput(
inputId = "Id086",
label = "Placeholder",
choices = c("a", "b", "c", "d"),
options = list(title = "This is a placeholder")
),
icon = NULL,
startExpanded = TRUE
),
menuSubItem(
text = "b",
tabName = "tab_b",
icon = NULL
)
)
)),
dashboardBody(tabItems(
tabItem(tabName = "tab_a1",
h2("tab_a1 content")),
tabItem(tabName = "tab_b",
h2("tab_b content"))
))
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
Here you can find a related question.
However, personally I'd recommend using shinydashboardPlus's right sidebar for inputs and use the left sidebar only for navigation.

Reset in Shiny applications

I am trying to clear what ever is written in the text area but looks like it not working. Based on the below applications, when the user clicks on "click" button, the contents (if written) should get cleared. But it is not. Can anyone help me here please........................................
data(mtcars)
library(shiny)
library(shinydashboard)
library(dplyr)
library(DT)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenu(id = "menu", sidebarMenuOutput("menu"))),
dashboardBody(tabItems
(
tabItem
(tabName = "plots", h2("Dashboard plots"),
fluidRow(column(width = 12, class = "well",
h4("Boxplot"),
plotOutput("bxp")))
),
tabItem(tabName = "dashboard", h2("Dashboard tab content"),
dataTableOutput(outputId = "subdt"),textAreaInput("sd","label1"),textAreaInput("sd1","label2") ,
actionButton("idff","click"))
)
)
)
server <- function(input, output, session) {
output$menu <- renderMenu({
sidebarMenu(
# menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
menuItem("Table Menu", icon = icon("info"),
menuSubItem(
"Dashboard", tabName = "dashboard", icon = icon("calendar")
),
selectInput(
inputId = "mcm", label = "Some label", multiple = TRUE,
choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)
)
)
)
})
observe({
print(input$menu)
})
datsub <- reactive({
mtcars %>%
filter_at(vars("cyl"), all_vars(. %in% input$mcm))
})
output$subdt <- renderDataTable({
datatable(datsub(),selection = if(input$menu == "dashboard"){'single'} else {'none'})
# print(datatable.selection())
})
# datatable(datsub(),selection = if(input$menu == "dashboard"){'single'} else {'none'})
output$bxp <- renderPlot({
hist(rnorm(100))
})
observeEvent(input$idff,{
print("cjec")
shinyjs::reset('sd')
shinyjs::reset('sd1')
})
}
shinyApp(ui, server)
I'd suggest to update the textAreaInput as suggested in the comments. Update the event handler as follows:
observeEvent(input$idff, {
updateTextAreaInput(session = session, inputId = 'sd', value = "")
updateTextAreaInput(session = session, inputId = 'sd1', value = "")
})

Append and remove tabs using sidebarPanel

Having trouble deleting tabs that have been newly created in Shiny.
Scenario:
Add new tab "A"
Add new tab "B"
Click delete on tab B - doesn't delete
Select tab A, click delete it works
I feel its something to do with ids, stumped with the logic.
Thanks in advance.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
navbarPage(title = "Test", id="tabs",
tabPanel("Home",
sidebarPanel(
selectInput("testlist", "Select test:",
list("A", "B", "C")),
actionButton("append", "New tab")),
mainPanel()
)
)
)
server <- function(input, output, session) {
tabnamesinput<-reactive({
input$testlist
})
observeEvent(input$append,{
id<-paste0(tabnamesinput())
appendTab(inputId = "tabs",
tabPanel(id,
sidebarPanel(
actionButton("remove", "Delete")
)
)
)
})
observeEvent(input$remove,{
removeTab(inputId = "tabs", target = input$tabs)
})
}
shinyApp(ui, server)
With your above approach you are trying to assign the same id = "remove" to each delete-button. This won't work. Every button needs it's own id.
Once each button has it's unique id you need an observer listening to all events triggered by those buttons. The following looks for all inputs matching the pattern "^remove_":
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
navbarPage(title = "Test", id = "tabs",
tabPanel("Home",
sidebarPanel(
selectInput("testlist", "Select test:", list("A", "B", "C"), selected = "A"),
actionButton("append", "New tab")),
mainPanel()
)
)
)
server <- function(input, output, session) {
observeEvent(input$append,{
appendTab(inputId = "tabs",
tabPanel(input$testlist,
sidebarPanel(
actionButton(paste0("remove_", input$testlist), "Delete")
)
)
)
})
observeEvent(lapply(grep(pattern = "^remove_", x = names(input), value = TRUE), function(x){input[[x]]}),{
if(input$tabs != "Home"){
removeTab(inputId = "tabs", target = input$tabs)
updateSelectInput(session, "testlist", selected = input$testlist) # keep the selection when re-rendering sidebarPanel
}
})
}
shinyApp(ui, server)

R Shiny conditional dateInput for every checkboxGroupInput selected

I am creating an app that allows the user to multi-select a list of projects. For each project selected, I would like to have a dateInput field to appear beside the project name (i.e. a/b/c).
Currently, I can display dateInput field for any one of the projects, but not multiple (shown below)
Once multiple dateInputs display beside project list as shown below: I wonder how the dateInput fields can line up nicely because they seem to take up more space than the checkbox list, like this:
ui <- dashboardPage(
dashboardHeader(
title = ""
),
dashboardSidebar(
sidebarMenu(
menuItem("Projects", tabName = "tab1")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "tab1",
fluidRow(h2("Projects"),
column(6,
checkboxGroupInput("Projects", "",
c("a", "b", "c")
)
),
column(4,
conditionalPanel(condition = "input.Projects == 'a' ||
input.Projects == 'b' || input.Projects
== 'c'", dateInput("proj_date", ""))
)
)
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
I understand I need to put in javascript in the conditionalPanel's condition argument. Please advise how I should correct the code and have one or more dateInput fields displayed for any and all selected projects.
Try uiOutput:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Projects", tabName = "tab1")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "tab1",
fluidRow(h2("Projects"),
column(6, checkboxGroupInput("Projects", "", c("a", "b", "c"))),
column(4, uiOutput('dates'))))
)
)
)
server <- function(input, output) {
output$dates <- renderUI({
lapply(input$Projects, function(project) {
div(dateInput(paste0("proj_date_",project), paste("Project", project, "date")))
})
})
}
shinyApp(ui, server)

shiny: pickerIntput choices based on search bar

hi i im trying to have the 'choices' in my pickerInput be dependent on what the user types in the search bar above. im using a spotify r package and if you search a certain artist the api returns a table of artists of the similar name and you need to choose which artist you want. anyways i want that table to go into the pickerInput and i can't seem to get it work.
ui <- dashboardPage(skin = "green",
dashboardHeader(title = "Lyric Prediction"),
dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "Overview", icon = icon("search")),
menuItem("Analysis", tabName = "Analysis", icon = icon("bar-chart-o"))
)
),
dashboardBody(
tags$head(
tags$style(HTML(".fa { font-size: 18px; }"))
),
tabItems(
# First tab content
tabItem(tabName = "Overview",
fluidRow(
column(12,
searchInput(
inputId = "search", label = "Search Artist on Spotify",
placeholder = "Search",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"
)
), align = "center"
),
#HERE - how can i have pickerInput take in the output
#of "res" from the server?
fluidRow(pickerInput(choices = "res")
)),
)
)
server <- function(input, output) {
#function to take search input
#output list of possible artists
output$res <- renderTable({
#Rspotify
possibleArtists <- searchArtist(input$search,token=my_oauth)
possibleArtists <- as_tibble(possibleArtists)
myCols <- c("display_name","id")
colNums <- match(myCols,names(possibleArtists))
possibleArtists <- possibleArtists %>%
select(colNums)
possibleArtists
})
}
shinyApp(ui, server)
Use update method in an observeEvent like this:
observeEvent(input$search, {
#Rspotify
possibleArtists <- searchArtist(input$search,token=my_oauth)
possibleArtists <- as_tibble(possibleArtists)
myCols <- c("display_name","id")
colNums <- match(myCols,names(possibleArtists))
possibleArtists <- possibleArtists %>%
select(colNums)
updatePickerInput(
session = session,
inputId = "picker",
choices = possibleArtists
)
}, ignoreInit = TRUE)
Full example:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "Lyric Prediction"),
dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "Overview", icon = icon("search")),
menuItem("Analysis", tabName = "Analysis", icon = icon("bar-chart-o"))
)
),
dashboardBody(
tags$head(
tags$style(HTML(".fa { font-size: 18px; }"))
),
tabItems(
# First tab content
tabItem(
tabName = "Overview",
fluidRow(
column(12,
searchInput(
inputId = "search", label = "Search Artist on Spotify",
placeholder = "Search",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"
)
), align = "center"
),
pickerInput(inputId = "picker", label = "Choose an artist:", choices = NULL)
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$search, {
updatePickerInput(
session = session,
inputId = "picker",
choices = c("The Beatles",
"The Beatles Recovered Band",
"Yesterday - A Tribute To The Beatles",
"The Beatles Revival Band & Orchestra")
)
}, ignoreInit = TRUE)
}
shinyApp(ui, server)

Resources