I am building an app using the bs4Dash package, and I would like to include action buttons in the main page that would allow the user to jump to the appropriate page. However, the buttons do not do anything.
This is very much the same as this question. I believe the issue here is that updatebs4TabItems requires a TabSetPanel inputId... Except that I do not wish to include tabset panels here.
library(shiny)
library(bs4Dash)
ui <- bs4DashPage(
# Sidebar -------------------------------------------------------------
sidebar = bs4DashSidebar(
bs4SidebarMenu(
bs4SidebarMenuItem(
"Welcome",
tabName = "item0"
),
bs4SidebarMenuItem(
"Page 1",
tabName = "item1"
),
bs4SidebarMenuItem(
"Page 2",
tabName = "item2"
)
)
),
# Body -------------------------------------------------------------
body = bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "item0",
fluidRow(
actionButton("JumpToV1", "Go to Page 1"),
actionButton("JumpToV2", "Go to Page 2")
)
),
bs4TabItem(
tabName = "item1",
fluidRow(
bs4Callout(
title = "This is Page 1",
elevation = 4,
status = "danger"
)
)
),
bs4TabItem(
tabName = "item2",
fluidRow(
bs4Callout(
title = "This is Page 2",
elevation = 4,
status = "danger")
)
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$JumpToV1, {
updatebs4TabItems(session, "item0", selected = "item1")
})
observeEvent(input$JumpToV2, {
updatebs4TabItems(session, "item0", selected = "item2")
})
}
shinyApp(ui, server)
You're close! Two things need adjusting. From the documentation, note that the selected argument in updatebs4TabItems takes an integer (the position of the selected tab), not a string (so not the id name you have). Also, the inputID argument for updatebs4TabItems will refer to the sidebarID for you, which you need to set. The below code should work how you want.
library(shiny)
library(bs4Dash)
ui <- bs4DashPage(
# Sidebar -------------------------------------------------------------
sidebar = bs4DashSidebar(
bs4SidebarMenu(
id = "sidebarID", #note the new ID here
bs4SidebarMenuItem(
"Welcome",
tabName = "item0"
),
bs4SidebarMenuItem(
"Page 1",
tabName = "item1"
),
bs4SidebarMenuItem(
"Page 2",
tabName = "item2"
)
)
),
# Body -------------------------------------------------------------
body = bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "item0",
fluidRow(
actionButton("JumpToV1", "Go to Page 1"),
actionButton("JumpToV2", "Go to Page 2")
)
),
bs4TabItem(
tabName = "item1",
fluidRow(
bs4Callout(
title = "This is Page 1",
elevation = 4,
status = "danger"
)
)
),
bs4TabItem(
tabName = "item2",
fluidRow(
bs4Callout(
title = "This is Page 2",
elevation = 4,
status = "danger")
)
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$JumpToV1, {
#changed ID and selected here and below
updatebs4TabItems(session, inputId = "sidebarID", selected = 2)
})
observeEvent(input$JumpToV2, {
updatebs4TabItems(session, inputId = "sidebarID", selected = 3)
})
}
shinyApp(ui, server)
Related
I want to show the controlbar (right sidebar) only for several tabs in the left sidebar.
library(shiny)
library(bs4Dash)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(
title = "My dashboard"
),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarMenu",
menuItem(
text = "Tab 1",
tabName = "tab1"
),
menuItem(
text = "Tab 2",
tabName = "tab2"
)
)
),
body = dashboardBody(),
controlbar = dashboardControlbar(),
title = "DashboardPage"
),
server = function(input, output) { }
)
I try to develop a shiny app where for some of the tabs a controlbar is necessary, for others the controlbar should show certain options and for others it is obvious at all. What is the most elegant way to ensure this? Should i "outsource" the appearance into seperate modules or are there other recommendations?
It is possible, and there are a lot of different ways to achieve this.
Different methods have their benefits and shortcomings.
I can demonstrate to basic Shiny methods for conditional UI elements that are used the most.
The common thing among the "easy" solutions to the conditional UI per tab problem is to evaluate somehow on which tab the users view currently is.
First method would be to check the Javascript context and adapt the UI using conditionalPanel:
shinyApp(
ui = dashboardPage(
header = dashboardHeader(
title = "My dashboard"
),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarMenu",
menuItem(
text = "Tab 1",
tabName = "tab1"
),
menuItem(
text = "Tab 2",
tabName = "tab2"
),
menuItem(
text = "Tab 3",
tabName = "tab3"
)
)
),
body = dashboardBody(),
controlbar = dashboardControlbar(
id= "controlbar",
collapsed = TRUE,
conditionalPanel(
condition = "input.sidebarMenu=='tab1'||input.sidebarMenu=='tab3'",
controlbarMenu(
controlbarItem(title = "Item1"),
controlbarItem(title = "Item2")
)
),
conditionalPanel(
condition = "input.sidebarMenu=='tab2'",
controlbarMenu(
controlbarItem(title = "Item3")
)
),
conditionalPanel(
condition = "input.sidebarMenu=='tab3'",
controlbarMenu(
controlbarItem(title = "Item4")
)
)
),
title = "DashboardPage"
),
server = function(input, output,session) { }
)
The benefit is clearly that this should render faster since it gets evaluated inside the UI (clientside). The downside is that we have to use Javascript (what we might dont want to do) and also we create logic in the UI function, making it more cluttered.
The next method would be to use R and render some parts of the UI in the Server function and send it to an output function in the UI
shinyApp(
ui = dashboardPage(
header = dashboardHeader(
title = "My dashboard"
),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarMenu",
menuItem(
text = "Tab 1",
tabName = "tab1"
),
menuItem(
text = "Tab 2",
tabName = "tab2"
),
menuItem(
text = "Tab 3",
tabName = "tab3"
)
)
),
body = dashboardBody(),
controlbar = dashboardControlbar(
id= "controlbar",
collapsed = TRUE,
sidebarMenuOutput("Menu")
),
title = "DashboardPage"
),
server = function(input, output,session) {
observeEvent(input$sidebarMenu, {
output$Menu <- renderMenu({
if(input$sidebarMenu=="tab1") {
controlbarMenu(
controlbarItem(
title = "Item1"
)
)
}else if(input$sidebarMenu=="tab2"){
controlbarMenu(
controlbarItem(
title = "Item2"
),
controlbarItem(
title = "Item2_2"
)
)
}else{
controlbarMenu()
}
})
})
}
)
The benefit is that we have the logic in the Server function, and our UI gets more concise. The downsight is that we add extra computational work to the server, which could be done on the clients side. We also will have to write some if else statments or map or apply and its not clear what amount of the UI should be rendered in the server function. Also it gets more complex if you want to add a feature, so often times you have rewrite this alot during development if your not careful and plan ahead for reactivity, etc.
Hi and thanks for reading me
I am working with an application that has a password layer and I would like to know how I could hide a tab item based on the person entering the application. So far it is what I have but I have not managed to make it work:
library(shinymanager)
library(shinyjs)
library(shiny)
library(shinydashboard)
credentials <- data.frame(
user = c("shiny", "shiny2"), # mandatory
password = c("111", "111"), # mandatory
start = c("2015-04-15"), # optinal (all others)
expire = c(NA, "2032-12-31"),
admin = c(FALSE, TRUE),
comment = "Simple and secure authentification mechanism
for single ‘Shiny’ applications.",
stringsAsFactors = FALSE,
moreInfo = c("someData1", "someData2"),
level = c(2, 0)
)
if (interactive()) {
header <- dashboardHeader()
sidebar <- dashboardSidebar(
shinyjs::useShinyjs(),
sidebarUserPanel("User Name",
subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"),
# Image file should be in www/ subdir
image = "userimage.png"
),
sidebarSearchForm(label = "Enter a number", "searchText", "searchButton"),
sidebarMenu(
# Setting id makes input$tabs give the tabName of currently-selected tab
id = "tabs",
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", icon = icon("th"), tabName = "widgets", badgeLabel = "new",
badgeColor = "green"),
menuItem("Charts", icon = icon("bar-chart-o"),
menuSubItem("Sub-item 1", tabName = "subitem1"),
menuSubItem("Sub-item 2", tabName = "subitem2")
)
)
)
body <- dashboardBody(
tabItems(
tabItem("dashboard",
div(p("Dashboard tab content"))
),
tabItem("widgets",
"Widgets tab content"
),
tabItem("subitem1",
"Sub-item 1 tab content"
),
tabItem("subitem2",
"Sub-item 2 tab content"
)
)
)
shinyApp(
ui = secure_app(dashboardPage(header, sidebar, body)),
server = function(input, output, session) {
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
# Create reactive values including all credentials
creds_reactive <- reactive({
reactiveValuesToList(res_auth)
})
observe({
req(creds_reactive())
if (!is.null(creds_reactive()$user) %in% c("shiny") ) shinyjs::hide("widgets")
})
}
)
}
Anyone have any ideas how to correct that?I can't get the tab item to hide when a certain user enters the application :(
I'd use renderMenu instead of hiding the menuItem - otherwise users not allowed to access the contents can simply change the style of the UI element in their browser as explained here (I assume the contents of your tabItems are also generated on the server side).
library(shinymanager)
library(shinyjs)
library(shiny)
library(shinydashboard)
credentials <- data.frame(
user = c("shiny", "shiny2"), # mandatory
password = c("111", "111"), # mandatory
start = c("2015-04-15"), # optinal (all others)
expire = c(NA, "2032-12-31"),
admin = c(FALSE, TRUE),
comment = "Simple and secure authentification mechanism
for single ‘Shiny’ applications.",
stringsAsFactors = FALSE,
moreInfo = c("someData1", "someData2"),
level = c(2, 0)
)
header <- dashboardHeader()
sidebar <- dashboardSidebar(
shinyjs::useShinyjs(),
sidebarUserPanel("User Name",
subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"),
# Image file should be in www/ subdir
image = "userimage.png"
),
sidebarSearchForm(label = "Enter a number", "searchText", "searchButton"),
sidebarMenu(
# Setting id makes input$tabs give the tabName of currently-selected tab
id = "tabs",
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItemOutput("widgetsOutput"),
menuItem("Charts", icon = icon("bar-chart-o"),
menuSubItem("Sub-item 1", tabName = "subitem1"),
menuSubItem("Sub-item 2", tabName = "subitem2")
)
)
)
body <- dashboardBody(
tabItems(
tabItem("dashboard",
div(p("Dashboard tab content"))
),
tabItem("widgets",
"Widgets tab content"
),
tabItem("subitem1",
"Sub-item 1 tab content"
),
tabItem("subitem2",
"Sub-item 2 tab content"
)
)
)
shinyApp(
ui = secure_app(dashboardPage(header, sidebar, body)),
server = function(input, output, session) {
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
# Create reactive values including all credentials
creds_reactive <- reactive({
reactiveValuesToList(res_auth)
})
output$widgetsOutput <- renderMenu({
if(creds_reactive()$user == "shiny"){
menuItem("Widgets", icon = icon("th"), tabName = "widgets", badgeLabel = "new", badgeColor = "green")
}
})
}
)
I would like to bookmark a double nested menusubitem in shinydashboard, however this is not working (see example below).
When you bookmark page 1, page 2 or page 3.1, then it is working smoothly. However, when you try to bookmark page 4.1.1, then it opens on page 1.
Does anyone have a clue how to solve this?
library(shiny)
library(shinydashboard)
ui <- function(request){
dashboardPage(
dashboardHeader(title = "Dashboard Demo")
, dashboardSidebar(
sidebarMenu(
# Setting id makes input$tabs give the tabName of currently-selected tab
id = "tabs"
, menuItem("Page 1", tabName = "page1", icon = NULL)
, menuItem("Page 2", tabName = "page2", icon = NULL)
, menuItem("Page 3", icon = NULL
, menuSubItem("Page 3.1", tabName = "page3_1", icon = NULL)
)
, menuItem("Page 4", icon = NULL
, menuItem("Page 4.1", icon = NULL
, menuSubItem("Page 4.1.1", tabName = "page4_1_1", icon = NULL)
)
)
)
)
, dashboardBody(
bookmarkButton()
, tabItems(
tabItem("page1", div(p(h2("Page 1"), "working", br(), "try to bookmark 4.1.1 and you will see it is not working")))
, tabItem("page2", div(p(h2("Page 2"), "working")))
, tabItem("page3_1", div(p(h2("Page 3.1"), "working")))
, tabItem("page4_1_1", div(p(h2("Page 4.1.1"), "not working with bookmark button")))
)
)
, title = "Dashboard example"
)
}
server <- function(input, output, session) {
}
enableBookmarking(store = "url")
shinyApp(ui = ui, server = 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)
I am adding clickable icons in my shiny app to show a popup information box. Please see the following screenshot and code example. My strategy is to wrap my text and the code for actionLink in the HTML function. This works well. However, the size of the icon is determined by the size of the associated. I would like to know if it is possible to make all the icons the same size, such as the smallest one associated with the selectInput?
The documentation (https://shiny.rstudio.com/reference/shiny/1.0.1/icon.html) mentioned that it is to set "fa-3x" in the icon function to make the size to be 3 times as normal. But in my case the size would sill be determined by the associated text and each text has a different size. So I guess this strategy would not work. It would be great if anyone can share their ideas or suggestions.
# Load the packages
library(shiny)
library(shinydashboard)
library(shinyalert)
# User Interface
ui <- dashboardPage(
header = dashboardHeader(title = ""),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem(
text = "Example",
tabName = "tab1"
)
)
),
body = dashboardBody(
# A call to use the shinyalert package
useShinyalert(),
tabItems(
tabItem(
tabName = "tab1",
h2(HTML("This is a title",
as.character(actionLink(inputId = "info1",
label = "",
icon = icon("info"))))),
fluidRow(
box(
title = HTML("This is the title of the box",
as.character(actionLink(inputId = "info2",
label = "",
icon = icon("info")))),
status = "primary", solidHeader = TRUE,
selectInput(inputId = "Select",
label = HTML("This is the title of the selectInput",
as.character(actionLink(inputId = "info3",
label = "",
icon = icon("info")))),
choices = 1:3)
)
)
)
)
)
)
server <- function(input, output, session){
observeEvent(input$info1, {
shinyalert(text = "Info 1", type = "info")
})
observeEvent(input$info2, {
shinyalert(text = "Info 2", type = "info")
})
observeEvent(input$info3, {
shinyalert(text = "Info 3", type = "info")
})
}
# Run the app
shinyApp(ui, server)
I'm not sure if I understand your question correctly but if you want the them all to have the same size you can adapt the font size for the icons like this:
# Load the packages
library(shiny)
library(shinydashboard)
library(shinyalert)
# User Interface
ui <- dashboardPage(
header = dashboardHeader(title = ""),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem(
text = "Example",
tabName = "tab1"
)
)
),
body = dashboardBody(
# A call to use the shinyalert package
useShinyalert(),
tabItems(
tabItem(
tabName = "tab1",
h2(HTML("This is a title", "<font size='3'>",
as.character(actionLink(inputId = "info1",
label = "",
icon = icon("info"))), "</font>")),
fluidRow(
box(
title = HTML("This is the title of the box", "<font size='3'>",
as.character(actionLink(inputId = "info2",
label = "",
icon = icon("info"))), "</font>"),
status = "primary", solidHeader = TRUE,
selectInput(inputId = "Select",
label = HTML("This is the title of the selectInput", "<font size='3'>", as.character(actionLink(inputId = "info3",
label = "",
icon = icon("info"))), "</font>"
),
choices = 1:3)
)
)
)
)
)
)
server <- function(input, output, session){
observeEvent(input$info1, {
shinyalert(text = "Info 1", type = "info")
})
observeEvent(input$info2, {
shinyalert(text = "Info 2", type = "info")
})
observeEvent(input$info3, {
shinyalert(text = "Info 3", type = "info")
})
}
# Run the app
shinyApp(ui, server)