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.
Related
I tried to make dynamic Tab using argonDash package. However, I met some trouble with my code.
I guess argonDash seems to get different behavior than native shiny because argonDash uses Bootstrap 4 (instead of 3).
My code is composed of two key features:
The first widget uiOutput(outputId = "new_argonSidebarItem") works well.
The second widget uiOutput(outputId = "new_argonTabItem") doesn't work properly. I expect that the argonBadge() toggle with the second tab.
library(shiny)
library(argonDash)
library(argonR)
ui <- argonDashPage(
sidebar = argonDashSidebar(
id = "sidebar01",
vertical = FALSE,
size = "md",
background = "white",
argonSidebarMenu(
style = "display:-webkit-inline-box;",
argonSidebarItem(
tabName = "Tab1",
icon = NULL,
"Dashboard"
),
# New Tab
uiOutput(outputId = "new_argonSidebarItem")
)
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
actionButton("add_more", "Add a new btn")
),
# Body
uiOutput(outputId = "new_argonTabItem")
)
)
)
server <- function(input, output, session) {
observeEvent(input$add_more, {
tabId <- sample.int(n = 1000000, size = 1)
tabName <- paste0("Tab_", tabId)
insertUI(
selector = "#tab-Tab1",
where = "afterEnd",
ui = argonSidebarItem(
tabName = tabName,
tabName
)
)
output$new_argonTabItem <- renderUI({
argonTabItem(
tabName = tabName,
argonBadge(
text = tabName,
src = "#",
pill = FALSE,
status = "success"
)
)
})
})
}
shinyApp(ui, server)
Thank you for your time!
To update your badge you need to track which tab is selected. This is done accordingly to this solution : https://github.com/RinteRface/argonDash/issues/7
But your badge can not be modified, so I replaced it with a button from {shinyWidgets}.
I hope this is what you ask for, I'm not really sure to understand what you want to happen.
library(shiny)
library(argonDash)
library(argonR)
library(shinyWidgets)
ui <- argonDashPage(
sidebar = argonDashSidebar(
id = "sidebar01",
vertical = FALSE,
size = "md",
background = "white",
argonSidebarMenu(
style = "display:-webkit-inline-box;",
argonSidebarItem(
tabName = "Tab1",
icon = NULL,
"Dashboard"
),
# New Tab
uiOutput(outputId = "new_argonSidebarItem")
)
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
actionButton("add_more", "Add a new btn")
),
# Body
uiOutput(outputId = "new_argonTabItem")
),
tags$script( "$(document).on('click', function(event) {
Shiny.onInputChange('activeTab', $('.active').data().value);});")
)
)
server <- function(input, output, session) {
x <- reactiveValues(tabs = NULL)
observeEvent(input$add_more, {
tabId <- sample.int(n = 1000000, size = 1)
tabName <- paste0("Tab_", tabId)
insertUI(
selector = "#tab-Tab1",
where = "afterEnd",
ui = argonSidebarItem(
tabName = tabName,
tabName
)
)
output$new_argonTabItem <- renderUI({
argonTabItem(
tabName = tabName,
actionBttn(
inputId = paste0(input$activeTab,"_b"),
label = tabName,
style = "float",
color = "success"
)#,
# argonBadge(
# text = tabName,
# src = "#",
# pill = FALSE,
# status = "success"
# )
)
})
})
observeEvent(input$activeTab, {
updateActionButton(session,
paste0(input$activeTab,"_b"),
input$activeTab)
})
}
shinyApp(ui, server)
I'm trying to toggle the control bar using an actionLink in the top right (to basically copy what the gears icon is doing, and later I will remove the gears icon to just have one actionLink) and also to automate the toggling such that when the user clicks on feedback, the controlbar disappears and reappears when the user clicks on any other tab. I also want to make sure throughout this toggling, the controlbar does not overlay on the dashboard body (basically the dashboard body will resize appropriately whenever the control bar toggles).
This is what I've tried so far:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(shinyjs)
ui <- dashboardPage(
title = 'Test',
header = dashboardHeader(
title = span("Test"),
titleWidth = 600,
tags$li(
id = 'right-sidebar-toggle-list-item',
class = "dropdown",
actionLink("rightSidebarToggle", "Select Population"))
), # end of dashboardheader
sidebar = dashboardSidebar(
sidebarMenu(id = "sidebar",
menuItem("Overview", tabName = "introduction", icon = icon("info")),
menuItem("Feedback", tabName = "feedback", icon = icon("info")))),
body = dashboardBody(plotOutput("cars")),
controlbar = dashboardControlbar(
id = "controlbar",
width = 270,
skin = "light",
collapsed = F,
overlay = F,
controlbarMenu(
id = "menu",
controlbarItem(
' ',
# - select study
checkboxGroupButtons(
inputId = "select_study",
label = "Select Study",
choiceNames = c("1", "2"),
choiceValues = c("1", "2"),
selected = c("1", "2"),
justified = TRUE,
status = "primary",
direction = "vertical",
checkIcon = list(yes = icon("ok", lib = "glyphicon"))
),
)
)
)
)
server <- function(input, output, session) {
output$cars <- renderPlot({
plot(mtcars)
})
# event to toggle right sidebar menu
observeEvent(input$rightSidebarToggle, {
shinyjs::toggleClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
})
##### > Controlbar Collapse #####
observeEvent(input[["sidebar"]], {
if(input[["sidebar"]] == "feedback"){
removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
}else{
addClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
updateControlbar("controlbar")
}
})
}
shinyApp(ui, server)
There is no need to create a new actionLink and hide the existing a-tag. We can simply modify it.
Please check the following:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(shinyjs)
ui <- dashboardPage(
title = 'Test',
header = dashboardHeader(
title = span("Test"),
titleWidth = 600,
controlbarIcon = NULL
),
sidebar = dashboardSidebar(sidebarMenu(
id = "sidebar",
menuItem("Overview", tabName = "introduction", icon = icon("info")),
menuItem("Feedback", tabName = "feedback", icon = icon("info"))
)),
body = dashboardBody(
useShinyjs(),
tags$script(
HTML(
"var el = document.querySelector('body > div > header > nav > div:nth-child(4) > ul > li:last-child > a');
el.innerHTML = 'Select Population';"
)
),
plotOutput("cars")
),
controlbar = dashboardControlbar(
id = "controlbar",
width = 270,
skin = "light",
collapsed = FALSE,
overlay = FALSE,
controlbarMenu(id = "menu",
controlbarItem(' ',
checkboxGroupButtons(
inputId = "select_study",
label = "Select Study",
choiceNames = c("1", "2"),
choiceValues = c("1", "2"),
selected = c("1", "2"),
justified = TRUE,
status = "primary",
direction = "vertical",
checkIcon = list(yes = icon("ok", lib = "glyphicon"))
)
)
)
)
)
server <- function(input, output, session) {
output$cars <- renderPlot({
plot(mtcars)
})
observeEvent(input[["sidebar"]], {
if (input[["sidebar"]] == "feedback") {
removeClass(selector = "body", class = "control-sidebar-open")
shinyjs::runjs('Shiny.setInputValue(id = "controlbar", value = false);
$(window).trigger("resize");')
} else {
addClass(selector = "body", class = "control-sidebar-open")
shinyjs::runjs('Shiny.setInputValue(id = "controlbar", value = true);
$(window).trigger("resize");')
}
}, ignoreInit = FALSE)
}
shinyApp(ui, server)
Edit: Here is an UI-only approach not using library(shinyjs):
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
ui <- dashboardPage(
title = 'Test',
header = dashboardHeader(
title = span("Test"),
titleWidth = 600,
controlbarIcon = NULL
),
sidebar = dashboardSidebar(sidebarMenu(
id = "sidebar",
menuItem("Overview", tabName = "introduction", icon = icon("info")),
menuItem("Feedback", tabName = "feedback", icon = icon("info"))
)),
body = dashboardBody(
tags$script(
HTML(
"var el = document.querySelector('body > div > header > nav > div:nth-child(4) > ul > li:last-child > a');
el.innerHTML = 'Select Population';
$(document).on('shiny:connected', function(event) {
$(window).trigger('resize'); // resize once on session start - needed when using collapsed = FALSE
});
$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'sidebar') {
if (event.value === 'feedback') {
document.querySelector('body').classList.remove('control-sidebar-open');
Shiny.setInputValue(id = 'controlbar', value = false);
$(window).trigger('resize');
} else {
document.querySelector('body').classList.add('control-sidebar-open');
Shiny.setInputValue(id = 'controlbar', value = true);
$(window).trigger('resize');
}
}
});"
)
),
plotOutput("cars")
),
controlbar = dashboardControlbar(
id = "controlbar",
width = 270,
skin = "light",
collapsed = FALSE,
overlay = FALSE,
controlbarMenu(id = "menu",
controlbarItem(' ',
checkboxGroupButtons(
inputId = "select_study",
label = "Select Study",
choiceNames = c("1", "2"),
choiceValues = c("1", "2"),
selected = c("1", "2"),
justified = TRUE,
status = "primary",
direction = "vertical",
checkIcon = list(yes = icon("ok", lib = "glyphicon"))
)
)
)
)
)
server <- function(input, output, session) {
output$cars <- renderPlot({
plot(mtcars)
})
}
shinyApp(ui, server)
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)
I have an shinydashboard app, the app get an filter box and a tabset which show a datatatable depending on filter.
I have a reset button which reset the filters whith shinyjs::reset function, and I want to reset also the tableset and showing the complete table or nothing.
I want also to do it for a valuboxes.
My app is like this :
For server interface I have an basic : output$tableprint_A <- DT::renderDataRable ({})
ui :
body <- dashboardBody(
tabItems(
#### First tab item #####
tabItem(tabName = "fpc",
fluidRow(
infoBoxOutput("kpm_inf", width = 6),
infoBoxOutput(outputId = "fpc_inf", width = 6)
),
fluidRow(
box(title = "Variables filter",
shinyjs::useShinyjs(),
id = "side_panel",
br(),
background = "light-blue",
solidHeader = TRUE,
width = 2,
selectInput("aaa", "aaa", multiple = T, choices = c("All", as.character(unique(fpc$aaa))))
br(),
br(),
p(class = "text-center", div(style = "display:inline-block", actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right"))),
div(style = "display:inline-block", actionButton("reset_button", "Reset",
icon = icon("repeat")))),
p(class = 'text-center', downloadButton('dl_fpc', 'Download Data'))),
tabBox(
title = tagList(),
id = "tabset1",
width = 10,
tabPanel(
"A \u2030 ",
DT::dataTableOutput("tableprint_A"),
bsModal(id = 'startupModal', title = 'Update message', trigger = '',
size = 'large',
tags$p(tags$h2("Last update of A : 01/09/2017",
br(), br(),
"Last update of B : 01/09/2017",
br(), br(),
"Last update of C : 01/09/2017",
style = "color:green", align = "center")))
),
tabPanel(
"B % Table",
DT::dataTableOutput("tableprint_B")),
type = "pills"
)
),
fluidRow(
# Dynamic valueBoxes
valueBoxOutput("info_gen", width = 6)
)
I tried this :
observeEvent(input$reset_button, {
output$tableprint_A <- NULL
})
Edit:
I want something like that, but when I action the search button I want it to appear again :
shinyjs::onclick("reset_button",
shinyjs::toggle(id = "tableprint_A", anim = TRUE))
You should try this out:
output$tableprint_A <- renderDataTable({
if(input$reset_button == 1) {
NULL
}else{
datatable(...)
}
})
if the button is clicked then nothing will be displayed, else the datatable is shown.
[EDIT]
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(selectInput("select", "select", choices = unique(iris$Species), multiple = T),
actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right")),
actionButton("reset_button", "Reset",
icon = icon("repeat")),
DT::dataTableOutput('tbl')),
server = function(input, output) {
values <- reactiveValues(matrix = NULL)
observe({
if (input$go_button == 0)
return()
values$matrix <- iris[iris$Species %in% input$select, ]
})
observe({
if (input$reset_button == 0)
return()
values$matrix <- NULL
})
output$tbl = DT::renderDataTable({
datatable(values$matrix, options = list(lengthChange = FALSE))}
)
}
)
I have a Shiny app with the following structure:
shinyUI(dashboardPage(title="Map",
dashboardHeader(title = tags$img(src="logo.png")),
dashboardSidebar(sidebarMenu(id = "totalTab",
menuItem("Users", tabName = "dashboard", icon = icon("user-circle")),
menuItem("Map", tabName = "cities", icon = icon("map-o")),
menuItem("Med", tabName = "med", icon = icon("building-o"), selected = TRUE),
menuItem("Data", tabName = "opdata", icon = icon("database"))
),
dashboardBody(tabItems(
tabItem(tabName = "dashboard", uiOutput("bodyuser")),
tabItem(tabName = "med", uiOutput("bodyoutput")),
tabItem(tabName = "cities", uiOutput("citiesout")),
tabItem(tabName = "opdata", uiOutput("dataout"))
))
))
The first I see when I open the app is tab item "med". Inside "med" I have a tabset called "TabMap". I want to update "TabMap" using URL like this:
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
rv$rvpanel <- query[['panelname']]
updateTabsetPanel(session, "TabMap", selected = rv$rvpanel)
}
})
Or this:
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
updateTabsetPanel(session, "TabMap", selected = query[['panelname']])
}
})
But neither works. How can I do that?
PD: rv$rvpanel is a reactive value...
Tabset:
output$bodyoutput <- renderUI({
box(title = "Map", width ="100%", status = "info", solidHeader = TRUE,
uiOutput("tabmap"))
})
output$tabmap <- renderUI({
tabsetPanel(id = "TabMap",
tabPanel(width = "100%", title = "Add", value="panel5", uiOutput("formdead")),
tabPanel(width = "100%", title = "Ours", value="panel1", uiOutput("mapdeadout")),
tabPanel(width = "100%", title = "Month", value="panel4", uiOutput("mapmonthout")),
tabPanel(width = "100%", title = "Map", value = "panel2", uiOutput("maplifeout")),
tabPanel(width = "100%", title = "History", value="panel3", uiOutput("formhist"))
)
})
You just missed one thing, to check if "TabMap" is already rendered and available in the input before your observe code gets executed.
This codes below seem to work
observe({
if(any(names(input) == "TabMap")){
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
rv$rvpanel <- query[['panelname']]
updateTabsetPanel(session, "TabMap", selected = rv$rvpanel)
}
}
})
observe({
if(any(names(input) == "TabMap")){
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
updateTabsetPanel(session, "TabMap", selected = query[['panelname']])
}
}
})
Hope this helps!