How I can hide a tab with shinyjs? - r

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")
}
})
}
)

Related

URI routing for shinydashboard using shiny.router

Suppose you have a simple shinydashboard which contains links created with menuItem and pages created with tabItems:
library(shiny)
library(shinydashboard)
skin <- Sys.getenv("DASHBOARD_SKIN")
skin <- tolower(skin)
skin <- "blue"
## ui.R ##
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", icon = icon("th"), tabName = "widgets",
badgeLabel = "new", badgeColor = "green")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# Put them together into a dashboardPage
ui<-dashboardPage(
dashboardHeader(title = "Simple tabs"),
sidebar,
body
)
server <- function(input, output) {
}
shinyApp(ui, server)
Is it possible to create permalinks for the pages? e.g. the home page (tabName == "dashboard") has a URL of 127.0.0.1:1234/home and the widgets page is at 127.0.0.1:1234/widgets?
It seems that shiny doesn't have URL routing out of the box. shiny.router seems to be a possible alternative but I've found no easy ways to do this with shinydashboard i.e. with the use of menuItem and tabItem. I'm trying to avoid rewriting the app's UI to use something which is more tightly integrated with shiny.router (e.g. shiny.semantic)
Is it possible to keep the above shinydashboard code while implementing permalinks to the various different pages?
Here is how to use the below approach with shiny's tabPanel() function.
Workarounds not using library(shiny.router):
Edit - Alternative using clientData$url_search and mode = "push" for updateQueryString to push a new history entry onto the browser's history stack:
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
# http://127.0.0.1:6172/?tab=dashboard
# http://127.0.0.1:6172/?tab=widgets
observeEvent(getQueryString(session)$tab, {
currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
if(is.null(input$sidebarID) || !is.null(currentQueryString) && currentQueryString != input$sidebarID){
freezeReactiveValue(input, "sidebarID")
updateTabItems(session, "sidebarID", selected = currentQueryString)
}
}, priority = 1)
observeEvent(input$sidebarID, {
currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
pushQueryString <- paste0("?tab=", input$sidebarID)
if(is.null(currentQueryString) || currentQueryString != input$sidebarID){
freezeReactiveValue(input, "sidebarID")
updateQueryString(pushQueryString, mode = "push", session)
}
}, priority = 0)
}
shinyApp(ui, server, enableBookmarking = "disable")
Another Edit - using url_hash (uri fragments):
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
observeEvent(input$sidebarID, {
# http://127.0.0.1:6172/#dashboard
# http://127.0.0.1:6172/#widgets
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"#",
input$sidebarID
)
updateQueryString(newURL, mode = "replace", session)
})
observe({
currentTab <- sub("#", "", session$clientData$url_hash)
if(!is.null(currentTab)){
updateTabItems(session, "sidebarID", selected = currentTab)
}
})
}
shinyApp(ui, server, enableBookmarking = "disable")
Edit - using url_search: Actually we can do the same without bookmarking using getQueryString and updateTabItems:
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
observeEvent(input$sidebarID, {
# http://127.0.0.1:6172/?tab=dashboard
# http://127.0.0.1:6172/?tab=widgets
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"?tab=",
input$sidebarID
)
updateQueryString(newURL, mode = "replace", session)
})
observe({
currentTab <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
if(!is.null(currentTab)){
updateTabItems(session, "sidebarID", selected = currentTab)
}
})
}
shinyApp(ui, server, enableBookmarking = "disable")
Using bookmarks:
Not sure if you are interested in a workaround like this, but you could use shiny's bookmarking and updateQueryString to achive a similar behaviour:
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
header = dashboardHeader(title = "Simple tabs"),
sidebar = dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem(
"Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt")
),
menuItem(
"Widgets",
icon = icon("th"),
tabName = "widgets",
badgeLabel = "new",
badgeColor = "green"
)
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets tab content"))
))
)
}
server <- function(input, output, session) {
bookmarkingWhitelist <- c("sidebarID")
observe({
setBookmarkExclude(setdiff(names(input), bookmarkingWhitelist))
})
observeEvent(input$sidebarID, {
# http://127.0.0.1:6172/?_inputs_&sidebarID=%22dashboard%22
# http://127.0.0.1:6172/?_inputs_&sidebarID=%22widgets%22
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"?_inputs_&sidebarID=%22",
input$sidebarID,
"%22"
)
updateQueryString(newURL,
mode = "replace",
session)
})
}
shinyApp(ui, server, enableBookmarking = "url")
Some related links:
https://rstudio.github.io/shinydashboard/behavior.html#bookmarking
https://shiny.rstudio.com/reference/shiny/1.7.0/session.html
It is possible to restore a session, locally, in a Shiny app if the inputs have been previously written in a RDS file?
shinyjs - setBookmarkExclude for delay IDs
https://github.com/rstudio/shiny/issues/3546

Link to a tab from dashboardBody

I am trying to have an action button within the Body of a tab (called "Widgets" in code) link to a different tab (called "data_table" in code). I know how to do this if the tab that I want to connect to, "data_table", is one of the menuItems that appears on the sidebarMenu. However, I do not wish for a link to the "data_table" tab to appear in the sidebar. I am stuck. I would have thought I need an "observeEvent"-type command which links the action button to the "data_table" tab. But I don't know what that is. Advice welcome. The code shows the UI side of things.
ui <- dashboardPage(
dashboardHeader(title = "My query"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets",
h2("Widgets"),
actionButton(inputId="seedata", label = "See data")),
tabItem(tabName = "data_table",
h2("Table with the data"))
)
)
)
server <- function(input, output, session) { }
shinyApp(ui, server)
Perhaps you are looking for something like this.
ui <- dashboardPage(
dashboardHeader(title = "My query"),
dashboardSidebar(
sidebarMenu(# Setting id makes input$tabs give the tabName of currently-selected tab
id = "tabs",
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content")),
tabItem(tabName = "widgets", h2("Widgets"),
fluidRow(
tabBox(id = "tabset1", height = "850px", width=12, title = "My Data",
### The id lets us use input$tabset1 on the server to find the current tab
tabPanel("Table with the data", value="tab1", " ",
actionButton(inputId="seedata", label = "See data"),
uiOutput("dataTable")
),
tabPanel("Display Data Table", value="tab2", " ",
#uiOutput("someoutput")
DT::dataTableOutput("testtable")
)
)
)
))
)
)
server <- function(input, output, session) {
output$dataTable <- renderUI({
tagList(
div(style="display: block; height: 350px; width: 5px;",HTML("<br>")),
actionBttn(inputId="datatable",
label="Data Table",
style = "simple",
color = "success",
size = "md",
block = FALSE,
no_outline = TRUE
))
})
observeEvent(input$datatable, {
updateTabItems(session, "tabs", "widgets")
if (input$datatable == 0){
return()
}else{
## perform other tasks if necessary
output$testtable <- DT::renderDataTable(
mtcars,
class = "display nowrap compact", # style
filter = "top", # location of column filters
options = list( # options
scrollX = TRUE # allow user to scroll wide tables horizontally
)
)
}
})
observeEvent(input$datatable, {
updateTabsetPanel(session, "tabset1",
selected = "tab2")
})
}
shinyApp(ui, server)

Jumping to Tab Items using an ActionButton in R Shiny

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)

Why can't I go back to a previously viewed page in shiny?

I would like to know why when a open a page (a1) in my shiny app and then I open another page (for example a2) then I can't come back to a1?
To reproduce my example please follow these steps:
click on a2
click on b1
click on c1
click on c8
click on c1 again
I would expect to see the content of c1 again ("example of text 2"), but clicking c1 again appears to do nothing.
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(
tags$head(tags$style(
HTML('.content-wrapper { height: 1500px !important;}')
)),
hr(),
sidebarMenu(
id = "tabs",
menuItem(
"a1",
tabName = "principal",
icon = icon("pagelines"),
selected = TRUE
),
menuItem(
"a2",
icon = icon("chart-bar"),
menuSubItem("b1", tabName = "identificacion", icon = icon("angle-right")),
menuSubItem("b2", tabName = "comunicacion", icon = icon("angle-right")),
menuSubItem("b3", tabName = "medicamentos", icon = icon("angle-right")),
menuSubItem("b4", tabName = "cirugias", icon = icon("angle-right")),
menuSubItem("b5", tabName = "infecciones", icon = icon("angle-right")),
menuSubItem("b6", tabName = "caidas", icon = icon("angle-right"))
),
menuItem("a3", tabName = "procesos", icon = icon("chart-bar")),
menuItem("a4", tabName = "tiempos", icon = icon("chart-bar")),
menuItem("a5", tabName = "manual", icon = icon("mortar-board")),
menuItem("a6", tabName = "acerca", icon = icon("question"))
),
width = 285,
hr(),
conditionalPanel("input.tabs=='identificacion'",
fluidRow(
column(1),
column(
10,
menuItem(
"c1",
tabName = "admision_iden",
icon = icon("chart-line"),
selected = FALSE
),
menuItem(
"c8",
tabName = "uci_iden",
icon = icon("chart-line"),
selected = FALSE
)
)
))
)
body <- dashboardBody(tabItems(
tabItem(tabName = "principal",
withMathJax(), ("example of text")),
tabItem(tabName = "admision_iden", titlePanel("example1"), "example of text 2"),
tabItem(tabName = "uci_iden", titlePanel("example 2"), "example of text 3")
))
ui <- dashboardPage(dashboardHeader(title = "Indic", titleWidth = 285),
sidebar,
body)
server <- function(input, output) {}
runApp(list(ui = ui, server = server))
Your additional menus are rendered outside sidebarMenu, so when selected, their ids are not recorded in the input variable input$tabs (which is what the app is monitoring). Including the menus inside sidebarMenu allows the tabItems to track the menuItems, but also breaks the reactivity, i.e., when input$tabs == 'uci_iden' the additional menus disappear (because input$tabs != 'identificacion').
One way to achieve the behavior you want (possibly not the best way) is to render the additional menus through the server using renderUI. Note that we still have to include the additional menus inside sidebarMenu and monitor them through input$tabs. To make sure they stick around when input$tabs != 'identificacion', we can include their ids in the condition. When neither of identification, uni_iden or admision_iden are selected, we render an empty div.
Updated code:
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(
tags$head(tags$style(
HTML('.content-wrapper { height: 1500px !important;}')
)),
hr(),
sidebarMenu(
id = "tabs",
menuItem(
"a1",
tabName = "principal",
icon = icon("pagelines"),
selected = TRUE
),
menuItem(
"a2",
icon = icon("chart-bar"),
menuSubItem("b1", tabName = "identificacion", icon = icon("angle-right")),
menuSubItem("b2", tabName = "comunicacion", icon = icon("angle-right")),
menuSubItem("b3", tabName = "medicamentos", icon = icon("angle-right")),
menuSubItem("b4", tabName = "cirugias", icon = icon("angle-right")),
menuSubItem("b5", tabName = "infecciones", icon = icon("angle-right")),
menuSubItem("b6", tabName = "caidas", icon = icon("angle-right"))
),
menuItem("a3", tabName = "procesos", icon = icon("chart-bar")),
menuItem("a4", tabName = "tiempos", icon = icon("chart-bar")),
menuItem("a5", tabName = "manual", icon = icon("mortar-board")),
menuItem("a6", tabName = "acerca", icon = icon("question")),
width = 285,
hr(),
uiOutput("more_menus")
)
)
body <- dashboardBody(tabItems(
tabItem(tabName = "principal",
withMathJax(), ("example of text")),
tabItem(tabName = "admision_iden", titlePanel("example1"), "example of text 2"),
tabItem(tabName = "uci_iden", titlePanel("example 2"), "example of text 3")
))
ui <- dashboardPage(dashboardHeader(title = "Indic", titleWidth = 285),
sidebar,
body)
server <- function(input, output) {
make_menus <- reactive({
if (req(input$tabs) %in% c("identificacion", "admision_iden", "uci_iden")) {
fluidRow(column(1),
column(
10,
menuItem(
"c1",
tabName = "admision_iden",
icon = icon("chart-line"),
selected = FALSE
),
menuItem(
"c8",
tabName = "uci_iden",
icon = icon("chart-line"),
selected = FALSE
)
))
} else {
div()
}
})
output$more_menus <- renderUI({ make_menus() })
}
runApp(list(ui = ui, server = server))

Word-wrapping or new line in shinydashboard title

I'm using a shinydashboard but when the title is too long it fails to wrap the lines. I have tried using <br/> to accomplish this, but it doesn't work even with HTML() around it in this context.
I know I can make the title space wider with titleWidth, but that does not look as good in many cases.
What would be the simplest way to achieve this?
Here's an example:
library(shiny)
library(shinydashboard)
## Only run this example in interactive R sessions
if (interactive()) {
header <- dashboardHeader(title = "This title is just way too long")
sidebar <- dashboardSidebar(
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 = dashboardPage(header, sidebar, body),
server = function(input, output) { }
)
}
The goal is to apply word-wrapping so that we can read the entire title (which says "This title is just way too long").
header <- dashboardHeader(title = h4(HTML("This title<br/>is just way too long")))
shinyApp(
ui = dashboardPage(header, sidebar, body),
server = function(input, output) { }
)

Resources