It appears the input value of a selectInput object is not updating. I have inserted one in the sidebar menu. I am using shinyDashboard. here is my code.
header & Sidebar
header <-
dashboardHeader(
title = "REPORT",
tags$li(class = "dropdown",
tags$style(
HTML(
"#import url('//fonts.googleapis.com/css?family=Libre+Baskerville:400,700|Open+Sans:400,700|Montserrat:400,700');"
)
)),
disable = FALSE,
titleWidth = '200'
)
header$children[[3]]$children[[3]] <-
tags$h1("DATABASE",
# align = 'left',
style = "color:#FFFFFF; font-weight: bold; font-family: 'Open Sans','Libre Baskerville',Montserrat, serif;font-size: 23px;")
data_type_list<-c('in vivo','in vitro','pbpk')
siderbar <- dashboardSidebar(
width = 200,
sidebarMenu(
id = 'sidebar',
style = "position: relative; overflow: visible;",
menuItem(
"TK Knowlegebase",
tabName = 'tk',
icon = icon('database'),
badgeColor = "teal",
#radioButtons("tk_data_type", "Select Data Type:",data_type_list)
selectInput('tk_data_type',"Select Data Type",data_type_list, selected=1)
)
)
)
body
body <- dashboardBody(width = 870,
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "custom.css")
),
#theme = shinythemes::shinytheme("darkly"),
tabItems(
tabItem (
tabName = "tk",
mainPanel(
#in vivo ----
conditionalPanel(
condition ="input.tk_data_type== 'in vivo'",
tags$h2('vivo')
),
# in vitro ----
conditionalPanel(
condition="input.tk_data_type== 'in vitro'",
tags$h2('vitro')
)
,
# pbpk ----
conditionalPanel(
condition="input.tk_data_type== 'pbpk'",
tags$h2('pbpk')
)
)))
server = function(input, output, session) {
observe({input$tk_data_type})
}
ui <- dashboardPage(title = 'ARC Toxkin App', skin = 'purple',
header, siderbar, body)
shiny::shinyApp(ui = ui, server = server)
I even attempted to use observe({input$tk_data_type}) in the server section to no success.
What I obtain is a blank page. what I wish to see is content from dashboardBody() appear.
Thank you for your time
UPDATE
This is a short-term fix solution, thanks to user YBS.
vitro_tabset<-tabsetPanel(
tabPanel("Detailed",
"This is a test"),
tabPanel("Phys-chem",
"This is a test"),
tabPanel("Exploratory",
"This is a test"),
tabPanel("Downloads",
"This is a test")
)
vivo_tabset<-tabsetPanel(
tabPanel("Detailed",
"This is a test"),
tabPanel("Phys-chem",
"This is a test"),
tabPanel("Exploratory",
"This is a test"),
tabPanel("Downloads",
"This is a test")
)
siderbar <- dashboardSidebar(
sidebarMenu(
id = 'sidebar',
menuItem(
"TK Knowlegebase",
tabName = 'tk',
icon = icon('database'),
badgeColor = "teal",
selected = TRUE,
startExpanded = TRUE,
#radioButtons("tk_data_type2", "Select Data Type:",data_type_list),
menuSubItem('vivo', tabName = 'vivo', icon = shiny::icon("angle-double-right"), selected = NULL),
menuSubItem('vitro', tabName = 'vitro', icon = shiny::icon("angle-double-right"), selected = TRUE),
menuSubItem('pbpk', tabName = 'pbpk', icon = shiny::icon("angle-double-right"), selected = NULL)
)
)
)
body <- dashboardBody(width = 870,
tabItems(
tabItem (tabName = "vivo",
vivo_tabset),
tabItem(tabName='vitro',
# in vitro ----
vitro_tabset),
# pbpk ----
tabItem(tabName='pbpk')
It appears that tabItems() and tabItem() don't work well in your program as the sidebarmenu requires minor tweaking. Also, you don't need mainPanel. Try this
data_type_list <- c("in vivo","in vitro","pbpk")
ui <- shinydashboard::dashboardPage(title = "ARC Toxkin App", skin = "purple",
shinydashboard::dashboardHeader(
title = "REPORT" ,
tags$li(class = "dropdown",
tags$style(
HTML(
"#import url('//fonts.googleapis.com/css?family=Libre+Baskerville:400,700|Open+Sans:400,700|Montserrat:400,700');"
)
)),
disable = FALSE,
titleWidth = '200'
),
shinydashboard::dashboardSidebar(width = 220,
useShinyjs(),
sidebarMenu(
id = "tabs",
style = "position: relative; overflow: visible;",
menuItem("TK Knowlegebase", tabName="tk", icon = icon("bar-chart-o"),
menuSubItem("TK Knowlegebase1", tabName = "tk1", icon = icon('database')),
selectInput("tk_data_type", label="Select Data Type", choices = data_type_list, selected=1),
menuSubItem("TK Knowlegebase2", tabName = "tk2", icon = icon('database'))
#radioButtons("tk_data_type2", "Select Data Type:",data_type_list)
)
)
),
shinydashboard::dashboardBody( #width = 870,
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "custom.css"),
),
#theme = shinythemes::shinytheme("darkly"),
tabItems(
#tabItem(tabName = "tk", headerPanel('First')),
tabItem(tabName = "tk1",
fluidRow(
shinydashboard::box(title = "Graphics Package", width = 12, solidHeader = TRUE, status="info",
## vivo
conditionalPanel(
condition = "input.tk_data_type == 'in vivo'",
tags$h2(' vivo')
),
## in vitro
conditionalPanel(
condition = "input.tk_data_type == 'in vitro'",
tags$h2(' vitro')
),
## pbpk
conditionalPanel(
condition = "input.tk_data_type == 'pbpk'",
tags$h2(' pbpk')
),
verbatimTextOutput("tb1"),
DTOutput("tb2")
))
),
tabItem(tabName = "tk2", headerPanel('Last'), DTOutput("tb3")
#verbatimTextOutput("tb4")
)
)
)
)
server <- function(input, output, session) {
output$tb3 <- renderDT(mtcars)
output$tb2 <- renderDT(iris)
output$tb1 <- renderPrint({input$tk_data_type})
output$tb4 <- renderPrint({input$tk_data_type2})
}
shinyApp(ui, server)
Related
In the following shiny app I would like to have the second tab inside the box if user selection is sh, So I was expecting the conditionalPanel command does the trick ! but it is not working:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "conditional tabBox"),
dashboardSidebar(
width = 250,
sidebarMenu(
id = "tabs",
radioButtons(inputId = "layout_status",
label = "",
inline = TRUE,
choices = c("Layout" = "ly","Shape file" = "sh"),
selected = "ly")
)
),
dashboardBody(
tabBox(width = 12,
tabPanel(
id = "p1",
title = HTML("<p style='color:#2071B5'><b>TAB 1</b></p>")
),
conditionalPanel(condition = " input.layout_status=='sh' ",
tabPanel(
id = "p2",
title = HTML("<p style='color:#2071B5'><b>TAB 2</b></p>")
)
)
)
)
)
server <- function(input, output) { }
shinyApp(ui, server)
tabBox expects tabPanel elements to be passed to its ... argument - conditionalPanel elements are not allowed.
However you can use hideTab / showTab instead:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "conditional tabBox"),
dashboardSidebar(
width = 250,
sidebarMenu(
id = "tabs",
radioButtons(inputId = "layout_status",
label = "",
inline = TRUE,
choices = c("Layout" = "ly","Shape file" = "sh"),
selected = "ly")
)
),
dashboardBody(
tabBox(
tabPanel(
value = "p1",
title = HTML("<p style='color:#2071B5'><b>TAB 1</b></p>")
),
tabPanel(
value = "p2",
title = HTML("<p style='color:#2071B5'><b>TAB 2</b></p>")
),
id = "tabBoxID", width = 12)
)
)
server <- function(input, output, session) {
observeEvent(input$layout_status, {
if(input$layout_status == 'sh'){
showTab(inputId = "tabBoxID", target = "p2", select = TRUE)
} else {
hideTab(inputId = "tabBoxID", target = "p2")
}
})
}
shinyApp(ui, server)
I want to trigger some action on clicking the menuItem. I use observe here: when I click 'Drivers' item I want some text to be returned in the console. Unfortunately, when I run the app the error comes up: Error in if: argument is of length 0. My menuItem exists, id is also ok so don't know why this error shows up.
Here is reproducible code (observe is on the bottom of my code):
library(shiny)
library(bs4Dash)
library(leaflet)
bodyTag <- dashboardBody(
tags$head(
tags$style(
"#map {
height: calc(100vh - 57px) !important;
}"
)
),
tabItems(
tabItem(
tabName = "live",
box(
title = "LIVE",
id = "panel",
height = 450,
collapsible = TRUE
)
),
tabItem(
tabName = "drivers",
box(
title = "Drivers",
id = "panel",
height = 450,
collapsible = TRUE
)
),
tabItem(
tabName = "customers",
box(
title = "Customers",
id = "panel",
height = 450,
collapsible = TRUE
)
)
),
leafletOutput("map")
)
ui <- dashboardPage(
dark = TRUE,
header = dashboardHeader(
title = h5("DEMO app")
),
sidebar = dashboardSidebar(
fixed = TRUE,
collapsed = TRUE,
expandOnHover = FALSE,
status = "purple",
customArea = fluidRow(
actionButton(
inputId = "myAppButton",
label = NULL,
icon = icon("users"),
width = NULL,
status = "primary",
style = "margin: auto",
dashboardBadge(1, color = "danger")
)
),
sidebarMenu(
id = "sidebarID",
menuItem("Live", tabName = "live", icon = icon("circle")),
menuItem("Drivers", tabName = "drivers", icon = icon("user-friends")),
menuItem("Customers", tabName = "customers", icon = icon("building"))
)
),
body = bodyTag
)
server <- function(input, output) {
observeEvent(input$sidebarID, {
updateBox("panel", action = "toggle")
})
output$map <- renderLeaflet({
leaflet() %>%
setView(lng = -73.98928, lat = 40.75042, zoom = 6) %>%
addProviderTiles("CartoDB.Positron")
})
# the problem is here
observe({
if(input$tabs == "drivers") {
print("Drivers")
#print(input$tabs)
} else {
print("other tabs")
}
})
}
shinyApp(ui = ui, server = server)
I'm pretty sure that input$tabs is how I should get to the given menuItem but maybe I'm wrong.
You're wrong. Many other posted solutions to this problem use tabs as the id of the sidebar menu, but you don't:
sidebarMenu(
id = "sidebarID",
menuItem("Live", tabName = "live", icon = icon("circle")),
menuItem("Drivers", tabName = "drivers", icon = icon("user-friends")),
menuItem("Customers", tabName = "customers", icon = icon("building"))
)
So you need
observe({
if(input$sidebarID == "drivers") {
print("Drivers")
#print(input$tabs)
} else {
print("other tabs")
}
})
It's a simple typo.
I have the shinydashboard below in which I have 3 tabPanels. In the 1st tabPanel "Resource Allocation" I want the left and right sidebar open by default. In the 2nd and 3rd tabpanels ("Time Series","Longitudinal View") I want only left sidebar and the right sidebar not just hidden but to not be able to open at all by pushing the "gears" icon above it which should be removed. And in the fourth panel "User Guide" I want no sidebar and no choise to open one of them at all.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
shinyApp(
ui = dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(
titleWidth = "0px"
),
sidebar = dashboardSidebar(minified = TRUE, collapsed = F),
body = dashboardBody(
useShinyjs(),#tags$head(tags$script(src="format_number.js")),
tags$script("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'hidden';"),
tabsetPanel(
tabPanel("Resource Allocation"),
tabPanel("Time Series"),
tabPanel("Longitudinal View"),
tabPanel("User Guide")
)
),
controlbar = dashboardControlbar(collapsed = F),
title = "DashboardPage"
),
server = function(input, output) { }
)
I have a solution for the left sidebar. I am sure you can spend sometime and figure out the solution for the right sidebar. Please note that this requires some more work to fine tune to your needs. Try this
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(DT)
ui <- shinydashboardPlus::dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
shinydashboardPlus::dashboardHeader(
#titleWidth = "0px"
),
shinydashboardPlus::dashboardSidebar( disable = TRUE ,
sidebarMenu(
selectInput(
"countries", label = "Select Countries",
choices = c("B", "C", "A"), selected = "A",
multiple = TRUE
))
),# minified = TRUE, collapsed = F),
controlbar = shinydashboardPlus::dashboardControlbar(id = "controlbar", collapsed = F,
skin = "dark",
controlbarMenu(
id = "menu",
controlbarItem(
"Tab 1",
"Welcome to tab 1"
),
controlbarItem(
"Tab 2",
"Welcome to tab 2"
)
)
),
shinydashboard::dashboardBody(
useShinyjs(),
tabsetPanel( id="tabset",
tabPanel("Resource Allocation", value="tab1", plotOutput("plot")),
tabPanel("Time Series", value="tab2", plotOutput("plot2")),
tabPanel("Longitudinal View", value="tab3", DTOutput("ir")),
tabPanel("User Guide", value="tab4", DTOutput("mt"))
)
),
# controlbar = dashboardControlbar(collapsed = F),
title = "DashboardPage"
)
server <- function(input, output) {
output$plot <- renderPlot(plot(cars))
output$plot2 <- renderPlot(plot(pressure))
output$mt <- renderDT(mtcars)
output$ir <- renderDT(iris)
observeEvent(input[["tabset"]], {
if(input[["tabset"]] == "tab4"){
addClass(selector = "body", class = "sidebar-collapse")
updateControlbar("controlbar")
}else{
removeClass(selector = "body", class = "sidebar-collapse")
}
})
}
shinyApp(ui, server)
I´ve been looking for the solution to this but I do not find it
My issue is that I have a shiny dashboard that looks like this:
It is selecting all tabs even If I do not select them (like pre-rendered)
I tried making an observeEvent with a button but It do not know how to make the UI appear after they click it.
My code is
library(shiny)
library(shinydashboard)
gamestop <- tags$img(src = "GSLL.png",
height = '30', width = '170')
ui <- dashboardPage(skin = "yellow",
dashboardHeader(title = gamestop,
dropdownMenu(type = "tasks",
messageItem(
from = "My contact",
message = "x",
icon = icon("glyphicon glyphicon-envelope"),
href = "mailto:x"),
messageItem(
from = "Leads",
message = "y",
icon = icon("glyphicon glyphicon-envelope"),
href = "mailto:y"),
messageItem(
from = "",
message = "z",
icon = icon("glyphicon glyphicon-envelope"),
href = "mailto:z"),
icon = icon("envelope")
)
),
dashboardSidebar(
sidebarMenu(
menuItem("Main menu", tabName = "main_menu", icon = icon("home")),
menuItem("Peripherals", tabName = "peripherals", icon = icon("hdd")),
menuItem("Database repair", tabName = "widgets", icon = icon("th")),
menuItem("Polling", tabName = "polling", icon = icon("cloud")),
menuItem("more issues!!", tabName = "issues", icon = icon("ad"))
)
),
dashboardBody(tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "Custom.css")),
fluidPage(
tabItem(tabName = "peripherals",
h1("Peripherals",
style = "color:#15942B"),
tabsetPanel(type = "tabs",
tabPanel("Printers",br(),
tabsetPanel(type = "tabs",
tabPanel("M452DW",br(),
tabsetPanel(type = "tabs",
tabPanel("Not pinging"),
tabPanel("Error messages")
)
),
tabPanel("M402DW",br(),
tabsetPanel(type = "tabs",
tabPanel("Not pinging")
),
)
)
),
tabPanel("Pinpad",br(),
tabsetPanel(type = "tabs",
tabPanel("Offline / busy"),
tabPanel("Not turning on")
)
),
tabPanel("Scanners",br(),
tabsetPanel(type = "tabs",
tabPanel("GBT4400"),
tabPanel("DS2278")
)
),
tabPanel("Receipt printer / cashdrawer",br(),
tabsetPanel(type = "tabs",
tabPanel("Receipt printer"),
tabPanel("Cash drawer")
)
),
tabPanel("Label printer",br(),
tabsetPanel(type ="tabs",
tabPanel("ZD410"),
tabPanel("LP2824 & +")
),
)
)
), #Final tab peripherals
tabItem(tabName = "main_menu",
h1("Main menu",
style = "color:#15942B"),
strong("Here we can add the news of the day or a welcome image"),br(),
br(),
br(),
strong("This is a work in progress, to be presented to our team leads so we can make
it an aid page for all of us")
),
tabItem(tabName = "issues",
h1("More issue resolutions to come!!!!!",
style = "color:#15942B" ),
strong("My plan is to add the hardest issue resolutions for our team, so they can access this web page and
with a glipse they can resolve the issue in hand")
),
tabItem(tabName = "polling",
)
)
)
)
)
server <- function(input, output) {
observeEvent(input$tabs,
if(input$sidebarmenu == "Printers"){
})
}
shinyApp(ui, server)
I would like to know how to render the tab when the user clicks on the tab itself and not before
Thanks a lot!!!
If you want to render the tab when the user clicks on the tab, you need to observe the tabsetpanel and check if the tab is clicked.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
tabItem(tabName = "peripherals",
h1("Peripherals",
style = "color:#15942B"),
tabsetPanel(id = "firsttabset",
type = "tabs",
tabPanel("Printers"),
tabPanel("Pinpad1",
h1("Dies ist tab \"Pinpad1\""),
textOutput("text")),
tabPanel("Scanners"),
tabPanel("Receipt printer / cashdrawer"),
tabPanel("Label printer")
)
)
)
server <- function(input, output) {
observeEvent(input$firsttabset, {
if(input$firsttabset == "Pinpad1") {
cat("tab \"Pinpad1\" is now being rendered \n")
output$text <- renderText({"tadaa"})
}
})
}
shinyApp(ui, server)
EDIT: If you want to apply this to nested tabsetpanels, I found a way by observing both tabsetpanel1 and tabsetpanel2 and checking in the conditions which tabs are selected. I suppose the first tab of tabsetpanel2, that is Scanners2 in this example, has to be rendered if you want to render the tab Pinpad1.
Check it out if it works for you. This logic can be extended to further nesting of tabsetpanels, but it will get complicated.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
tabItem(tabName = "peripherals",
h1("Peripherals",
style = "color:#15942B"),
tabsetPanel(id = "firsttabset",
type = "tabs",
tabPanel("Printers"),
tabPanel("Pinpad1",
tabsetPanel(id = "secondtabset",
type = "tabs",
tabPanel("Scanners2",
h1("Dies ist tab \"Scanners2\"")),
tabPanel("Pinpad2",
h1("Dies ist tab \"Pinpad2\""),
textOutput("text2"))),
h1("Dies ist tab \"Pinpad1\""),
textOutput("text")),
tabPanel("Scanners"),
tabPanel("Receipt printer / cashdrawer"),
tabPanel("Label printer")
)
)
)
server <- function(input, output) {
observeEvent(c(input$firsttabset,
input$secondtabset), {
if(input$firsttabset == "Pinpad1" & input$secondtabset == "Scanners2") {
cat("tab \"Pinpad1\" is now being rendered \n")
output$text <- renderText({"tadaa"})
}
if (input$firsttabset == "Pinpad1" & input$secondtabset == "Pinpad2") {
cat("tab2 \"Pinpad2\" is now being rendered \n")
output$text2 <- renderText({"tadooo"})
}
})
}
shinyApp(ui, server)
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)