Theme for dashboardpage when nested within navbarpage
I created a R shiny app using dashboardpage but now I want to combine multiple dashboardpage app into a single app and was trying to using navbarpage to achieve this. It seems to work but adding navbarpage seems to completely change the style of the dashboardpage.
A minimum working example is below for a basic dashboardpage is below:
library(shiny)
library(shinydashboard)
ui <-
dashboardPage(
dashboardHeader(title = "dash board header"),
dashboardSidebar(
sidebarMenu(
actionButton("refreshBtn", "Refresh", icon = icon("refresh"), onclick = "refreshPage()"), # Refresh button
menuItem("Data Upload", tabName = "uploadView", icon = icon("file")),
menuItem("Averages", tabName = "Averages", icon = icon("list"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "uploadView",
fluidRow(
column(4,
fileInput("file1", "Choose CSV File 1",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
fileInput("file2", "Choose CSV file 1",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
hr(),
downloadButton("downloadData", "Download Data"),
checkboxGroupInput("SelectOption", label = "Select Box",
choices = c("Option 1", "Option 2"))
)
)
)
)
)
)
server <- function(input, output, session){ }
shinyApp(ui = ui, server = server)
which gives:
However, when I try to put it within a navbarpage, the formatting changes. I.e.,
ui <-
navbarPage(
"Test App",
tabPanel(
"Tab 1",
dashboardPage(
dashboardHeader(title = "dash board header"),
dashboardSidebar(
sidebarMenu(
actionButton("refreshBtn", "Refresh", icon = icon("refresh"), onclick = "refreshPage()"), # Refresh button
menuItem("Data Upload", tabName = "uploadView", icon = icon("file")),
menuItem("Averages", tabName = "Averages", icon = icon("list"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "uploadView",
fluidRow(
column(4,
fileInput("file1", "Choose CSV File 1",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
fileInput("file2", "Choose CSV file 1",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
hr(),
downloadButton("downloadData", "Download Data"),
checkboxGroupInput("SelectOption", label = "Select Box",
choices = c("Option 1", "Option 2"))
)
)
)
)
)
)
),
tabPanel(
"Tab 2",
dashboardPage(
dashboardHeader(title = "dash board header 2"),
dashboardSidebar(disable = TRUE),
dashboardBody(tabItem(tabName = "Test"))
)
)
)
server <- function(input, output, session){ }
shinyApp(ui = ui, server = server)
which gives:
Is there a way to change the formatting of the dashboard component to get back to the way it was in the original picture. I'm not sure if I am trying to do use shinydashboard and navbarpage in a way they weren't designed for. Suggestions for others of doing this would be welcome.
Update
I added a second example of how you can do this at the bottom.
If you want tabs-style navigation & keep dashboard, you could build the navigation.
You have to pay VERY close attention to what things are called and use a unique
idwhere that's an option. Everything needs to have unique names on the different dashboards. In my example code, there is already an error. I used the dashboard from your question as the first tab. Anytime any button is pressed, it thinks that the download data button is pressed. (e.g., the refresh button, the tabs, and any others among your pages)
Below is a working example of manual tabbing between dashboards.
I created two dashboards saved in objects db1 and db2. db1 is your initial dashboard.
db1 <- dashboardPage(
dashboardHeader(title = "dash board header"),
dashboardSidebar(
sidebarMenu(
actionButton("refreshBtn", "Refresh", icon = icon("refresh"), onclick = "refreshPage()"), # Refresh button
menuItem("Data Upload", tabName = "uploadView", icon = icon("file")),
menuItem("Averages", tabName = "Averages", icon = icon("list"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "uploadView",
fluidRow(
column(4,
fileInput("file1", "Choose CSV File 1",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
fileInput("file2", "Choose CSV file 1",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
hr(),
downloadButton("downloadData", "Download Data"),
checkboxGroupInput("SelectOption", label = "Select Box",
choices = c("Option 1", "Option 2"))
)
)
)
)
)
)
db2 <- dashboardPage(
dashboardHeader(title = "dash board header 2"),
dashboardSidebar(
sidebarMenu(
tags$div("not much to see here")
)
),
dashboardBody(
tags$div("Nothing to see here")
)
)
Within the UI, I created the navigation bar, buttons for tab control and added the dashboards.
For each dashboard or tab
- there's a
tags$buttonwithintags$nav(the use oftags$navis so that it inherits styles from your dashboard) - there's a
tags$divafter tags$nav
Note that in the buttons the text highlighted
tags$button(onclick = HTML("gimmeTab('Dashboard 1')"),...
MUST match what's assigned to id in the tags$div that holds the matching dashboard
tags$div(id = "Dashboard 1",...
Read through the comments in the code for more info and if you have any questions, let me know.
ui <-
fluidPage(
tags$head( # this removes a left and right margin
tags$style(HTML(
"body > div.container-fluid {
padding: 0;
margin: 0;
}"
)), # adds tabs' control
tags$script(HTML(
"function gimmeTab(chosenOne){
let i;
let x = document.getElementsByClassName('tabber');
for(i = 0; i < x.length; i++) {
x[i].style.display = 'none';
}
document.getElementById(chosenOne).style.display = 'block';
}"
))
),
tags$body( # 2 primary elements: navigation bar and that which it controls
tags$nav(class = "navbar navbar-static-top", role = "navigation",
# here a button for each dashboard; must have class = "navBtn"
# must have unique inner text: first is 'Dashboard 1'
tags$button(onclick = HTML("gimmeTab('Dashboard 1')"), "Dashboard 1", class = "navBtn"),
# unique text: 'Dashboard 2'
tags$button(onclick = "gimmeTab('Dashboard 2')", "Dashboard 2", class = "navBtn")
),
# for each unique dashboard
# a `tags$div` with class 'tabber'
# the tags span exactly as shown here
# id that matches button inner text EXACTLY
# content - the dashboard
tags$div(id = "Dashboard 1", class = "tabber",
tags$span(onclick = HTML("this.parentELement.style.display = 'none'")),
tags$h2("Dashboard 1"),
db1
),
tags$div(id = "Dashboard 2", class = "tabber",
tags$span(onclick = "this.parentELement.style.display = 'none'"),
tags$h2("Dashboard 2"),
db2
)
)
)
server <- function(input, output, session){ }
shinyApp(ui = ui, server = server)
Based on some of your comments, I thought I would give you another example of how you could do this.
Instead of buttons, this uses HREF (which is what navbar uses). This relies heavily on navbar's coding under the surface without hijacking the styles you're using in your dashboard. Please note the comments explaining what elements are doing what and the things you need to consider if or when you use it.
ui2 <-
fluidPage(
tags$head(
tags$style(
# in this call to tags$style
# the first chunk removes a left and right margin
# the second is the highlight color with mouse and selection
# the background color and (text) color what I picked (that I thought looked ok)
HTML(
"div.container-fluid {
padding: 0;
margin: 0;
}
.navbar-default .navbar-nav>.active>a,
.navbar-default .navbar-nav>.active>a:hover,
.navbar-default .navbar-nav>.active>a:focus{
background-color: #9EC6DE;
color: white;
}"
))
),
tags$body( # 2 primary elements: navigation bar and that which it controls
# navigation bar
tags$nav(class = "navbar navbar-default navbar-static-top container-fluid", role = "navigation",
style = htmltools::css(background.color = "#3c8dbc", color = "white"), # white text matching blue bg
tags$ul(class = "nav navbar-nav",
# this is the settings for the tabs: 1 for each dashboard; the HREF must match the ID in the next section (less the #)
# each dashboard needs it's own tags$li(tags$a...)
# in href = "#....." must match the id set in tags$div() with the dashboard
tags$li(class = 'active', # set as default tab
tags$a(href = "#dashboard-1", `data-toggle` = "tab", style = "color: white;", "Dashboard 1")),
# each of the remaining tabs are formatted like this (without the active designation)
tags$li(tags$a(href = "#dashboard-2", `data-toggle` = "tab", style = "color: white;", "Dashboard 2"))
)
),
# that which the navigation bar controls
tags$div(class = "container-fluid",
tags$div(class = "tab-content",
# this is where the dashboards are stored
# each dashboard needs its' own tags$div
# the 'active' tab above is the only div here with the class 'active'
# in id = "....." must match the href (less #) found in the tags$li()
# set as tab-pane and default tab with the class 'active'
tags$div(id = "dashboard-1", class = "tab-pane active",
db1
), # remaining NOT active tabs, one for each tags$li() above
tags$div(id = "dashboard-2", class = "tab-pane", db2)
)
)
)
)
server <- function(input, output, session){ }
shinyApp(ui = ui2, server = server)
- Retrieving expected data.frame for testthat expectation
- How to use an anonymous function with pipe operator?
- R passing RSelenium driver environment as function argument
- Keep file names merging list with lapply?
- replace strings that contains one another
- Stop parsing out zeros after decimals in ggplot2's annotate
- Plot data.tree coloring and labelling by level
- Extracting the date and time out of a date and time format
- How to reshape a dataframe into wide format with specified column pairs
- Show partial segments removed after limit scales for `geom_pointrange`
- Control ggplot2 legend look without affecting the plot
- Concatenate strings over all rows in a single column of a data frame
- Is there some way to keep variable names from.SD+.SDcols together with non .SD variable names in data.table?
- How to create mutually dependent checkbox columns in a DT table?
- A problem with an stacked, grouped and faceted graph y gg plot
- Installing R on Linux: configure: error: libcurl >= 7.28.0 library and headers are required with support for https
- Create a column conditional on multiple other character and numerical columns
- data.frame to array (2 columns)
- Changing options() in a function environment without changing options() in global environment in R?
- pivot(), group_by() and summarise() with nested data
- Why legend is not showing up in plot layout using patchwork in R?
- in dplyr::mutate, dplyr::starts_with works for .before but not .after?
- Finding optimal cut-off points for dividing a variable into equal groups considering ties in which quantiles do not work
- How to add a legend to hline?
- R Shiny Suppress slider handle for sliderInput until click
- brmultinom brglm2 vifs and dredge dont work
- R, how to get current time miliseconds, without extra information ? (Sys.time(), format("%X"))
- Installing multiple versions of R
- Command to see 'R' path that RStudio is using
- Fast pairwise longest common substring from start