How to change text colour of navbarPage links when hovered on (in shiny app)? - css

Here is the a redacted version of my shiny app:
ui <- tagList(
fluidPage(
titlePanel(""),
tags$head(tags$style(HTML(
"
.navbar-default {
color: red !important;'
}
"
))),
navbarPage(
windowTitle = "App Name",
theme = bs_theme(bootswatch = "flatly",
base_font = font_google("Lato"),
primary = "#333F50",
bg = "white",
fg = "#D67540"),
title = "I am the title",
selected = "Main Tab 1",
tabPanel(title = "Main Tab 1",
fluidPage(
sidebarLayout(
sidebarPanel(textInput(inputId = "text_input", label = "Enter text:")),
mainPanel(textOutput(outputId = "text_output"))
)
)
),
tabPanel(title = "Main Tab 2",
fluidPage(
fluidRow(
column(7,
navlistPanel(
tabPanel("Tab 1"),
tabPanel("Tab 2"),
tabPanel("Tab 3"),
widths = c(2, 10),
well = FALSE)
)))
)
)
)
)
server <- function(input, output){
output$text_output <- renderText(input$text_input)
}
shinyApp(ui, server)
This is what "Main Tab 1" looks like:
I would like to change the text colour of "Main Tab 1" and "Main Tab 2" from white to pink, and from teal green to red when the links are hovered/selected.
So far I've tried many variations of the following but without success:
.navbar-default {
color: red !important;
}
Does anyone know how to fix this?
Any help is much appreciated :)

We can do it with the following CSS code block:
library(bslib)
library(shiny)
ui <- tagList(
fluidPage(
titlePanel(""),
tags$head(tags$style(HTML(
"
.navbar-default {
color: red !important;'
}
.navbar-default .navbar-nav > .active > a,
.navbar-default .navbar-nav > li > a:hover {
color: red !important;
}
.navbar-default .navbar-nav > li > a {
color: pink !important;
}
"
))),
navbarPage(
windowTitle = "App Name",
theme = bs_theme(bootswatch = "flatly",
base_font = font_google("Lato"),
primary = "#333F50",
bg = "white",
fg = "#D67540"),
title = "I am the title",
selected = "Main Tab 1",
tabPanel(title = "Main Tab 1",
fluidPage(
sidebarLayout(
sidebarPanel(textInput(inputId = "text_input", label = "Enter text:")),
mainPanel(textOutput(outputId = "text_output"))
)
)
),
tabPanel(title = "Main Tab 2",
fluidPage(
fluidRow(
column(7,
navlistPanel(
tabPanel("Tab 1"),
tabPanel("Tab 2"),
tabPanel("Tab 3"),
widths = c(2, 10),
well = FALSE)
)))
)
)
)
)
server <- function(input, output){
output$text_output <- renderText(input$text_input)
}
shinyApp(ui, server)

Related

How to change the color of the label of inactive tabs in shiny

Here is an example of an app with 3 tabs:
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.tabset .nav-tabs .nav-link:not(.active) {
color: purple;
}
"))
),
tabsetPanel(
tabPanel("Tab 1",
h1("This is Tab 1")
),
tabPanel("Tab 2",
h1("This is Tab 2")
),
tabPanel("Tab 3",
h1("This is Tab 3")
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
By default the inactive tabs have their labels with a blue font. I need them to be purple
I see no arguments that allow me to change this default behaviour
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.tabbable > .nav > li > a {color:purple}
.tabbable > .nav > li[class=active] > a {color:black}
"))
),
tabsetPanel(
tabPanel("Tab 1",
h1("This is Tab 1")
),
tabPanel("Tab 2",
h1("This is Tab 2")
),
tabPanel("Tab 3",
h1("This is Tab 3")
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)

Show output of dashboardBody when rightSidebarTabContent id selected in shinyDashboard

How I am able to show the output of dashboardBody when the id of rightSidebarTabContent selected. If id = "tab_1", selected, show the verbatimTextOutput("tab1") and so on. I used shinyjs::show and shinyjs::hide, but it's not working. Any suggestion?
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(
enable_rightsidebar = TRUE,
rightSidebarIcon = "gears"
),
sidebar = dashboardSidebar(),
rightsidebar = rightSidebar(
id = "right_sidebar",
background = "dark",
rightSidebarTabContent(
id = "tab_1",
title = "Tab 1",
icon = "desktop",
active = TRUE,
sliderInput(
"obs",
"Number of observations:",
min = 0, max = 1000, value = 500
)
),
rightSidebarTabContent(
id = "tab_2",
title = "Tab 2",
textInput("caption", "Caption", "Data Summary")
),
rightSidebarTabContent(
id = "tab_3",
icon = "paint-brush",
title = "Tab 3",
numericInput("obs", "Observations:", 10, min = 1, max = 100)
)
),
dashboardBody(
div(id = "tab1_out", verbatimTextOutput("tab1")),
div(id = "tab2_out", verbatimTextOutput("tab2")),
div(id = "tab3_out", verbatimTextOutput("tab3"))
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
"tab1"
})
output$tab2 <- renderPrint({
"tab2"
})
output$tab3 <- renderPrint({
"Tab3"
})
observeEvent(input$right_sidebar,{
if(input$right_sidebar == "tab_1"){
shinyjs::show("tab1_out")
shinyjs::hide("tab2_out")
shinyjs::hide("tab3_out")
}else if(input$right_sidebar == "tab_2"){
shinyjs::hide("tab1_out")
shinyjs::show("tab2_out")
shinyjs::hide("tab3_out")
}else{
shinyjs::hide("tab1_out")
shinyjs::hide("tab2_out")
shinyjs::show("tab3_out")
}
})
}
shinyApp(ui, server)
I am not sure that you can hide and show the body content from right sidebar. However, you can control the outputs in display page. The code below shows that the body content is still controlled by left sidebar, but the plot display can be changed from the right sidebar. For each tabPanel, you can either choose to have a right sidebar or not.
library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinydashboardPlus)
library(ggplot2)
header <- dashboardHeaderPlus(
enable_rightsidebar = TRUE,
rightSidebarIcon = "gears"
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Section A", tabName = "Section_A", icon = icon("map")),
menuItem("Section B", tabName = "Section_B", icon = icon("chart-line")),
menuItem("Section C", tabName = "Section_C", icon = icon( "gears")),
id = "nav"
)
)
rightsidebar <- rightSidebar(
shiny::tags$head(shiny::tags$style(shiny::HTML(
".control-sidebar-tabs {display:none;}
.tabbable > .nav > li > a:hover {background-color: #333e43; color:white}
.tabbable > .nav > li[class=active] > a {background-color: #222d32; color:white}"))),
# '{display:none;}' removes empty space at top of rightsidebar
background = "dark",
uiOutput("side_bar"),
title = "Right Sidebar"
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = "Section_A",
p("Some content for section A"),
tabPanel(id = "tab_1o", "Tab 1 for Section A", verbatimTextOutput("tab1"), plotOutput("plot1")),
),
tabItem(
tabName = "Section_B",
p("Some content for section B"),
tabPanel(id = "tab_2o", "Tab 2 for Section B", verbatimTextOutput("tab2"), DTOutput("data2") ),
),
tabItem(
tabName = "Section_C",
p("Some content for section C"),
tabPanel(id = "tab_3o", "Tab 3 for Section C", verbatimTextOutput("tab3"), plotOutput("plot3"))
)
),
tags$script(
'$("a[data-toggle=\'tab\']").click(function(){
Shiny.setInputValue("tabactive", $(this).data("value"))
})'
)
)
ui <- tags$body(class="skin-blue sidebar-mini control-sidebar-open", dashboardPagePlus( ## keep the right sidebar open permanently
#ui <- dashboardPagePlus(
shinyjs::useShinyjs(),
header = header,
sidebar = sidebar,
body = body,
rightsidebar = rightsidebar
)
)
server <- function(input, output) {
output$tab1 <- renderPrint({
"tab1"
})
output$plot1 <- renderPlot({
set.seed(122)
histdata <- rnorm(500)
data <- histdata[seq_len(req(input$obs1))]
hist(data)
})
output$tab2 <- renderPrint({
"tab2"
})
output$plot2 <- renderPlot(qplot(rnorm(500),fill=I("green"),binwidth=0.2,title="plotgraph2"))
output$data2 <- renderDT(datatable(iris))
output$tab3 <- renderPrint({
"Tab3"
})
output$plot3 <- renderPlot(qplot(rnorm(req(input$obs3)),fill=I("blue"),binwidth=0.2,title="plotgraph3"))
observe({
if (req(input$nav) == "Section_A"){
message("tab_1 has been selected")
#shinyjs::addClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
shinyjs::removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
output$side_bar <- renderUI({
rightSidebarTabContent(
id = "tab_1",
title = "Right sidebar for Section A ",
icon = "desktop",
#active = TRUE,
sliderInput(
"obs1",
"Number of observations:",
min = 0, max = 1000, value = 500
)
)
})
}
if (req(input$nav) == "Section_B"){
message("tab_2 has been selected")
#shinyjs::addClass(selector = "aside.control-sidebar", class = "control-sidebar-open") ## to add right sidebar
shinyjs::removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open") ## remove right sidebar
output$side_bar <- renderUI({
rightSidebarTabContent(
id = "tab_2",
title = "Right sidebar for Section B ",
textInput("caption", "Caption", "Data Summary")
)
})
}
if (req(input$nav) == "Section_C"){
message("tab_3 has been selected")
#shinyjs::addClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
shinyjs::removeClass(selector = "aside.control-sidebar", class = "control-sidebar-open")
output$side_bar <- renderUI({
rightSidebarTabContent(
id = "tab_3",
icon = "paint-brush",
title = "Right sidebar for Section C",
numericInput("obs3", "Observations:", 400, min = 1, max = 1000)
)
})
}
})
}
shinyApp(ui, server)

enable tab with multiple input and disable tab with one input

i am working on an application where a user selects a single input the tab gets disabled and if user selects more than one input it gets enabled. can anyone help me with this . i have posted the reproducible example .
library(shiny)
library(shinyjs)
shinyApp(
ui = fluidPage(
useShinyjs(),
selectizeInput("foo", "Show tab2",selected = NULL,choices=c("a","b","c","d"), multiple = TRUE),
tabsetPanel(
id = "navbar",
tabPanel(title = "tab1",
value = "tab1",
h1("Tab 1")
),
tabPanel(title = "tab2",
value = "tab2",
h1("Tab 2")
),
tabPanel(title = "tab10",
value = "ta10",
h1("Tab 10")
),
tabPanel(title = "tab99",
value = "tab99",
h1("Tab 99")
),
tabPanel(title = "tab19",
value = "tab19",
h1("Tab 19")
),
tabPanel(title = "tab09",
value = "tab09",
h1("Tab 09")
),
tabPanel(title = "tab3",
id="pqr",
value = "tab3",
h1("Tab 3")
)
)
),
server = function(input, output) {
observe({
toggle(condition = input$foo, selector = "#navbar li a[data- value=tab3]")
})
Using #Dean Attali answer's here and based on the length of selected choices we can do:
library(shiny)
library(shinyjs)
jscode <- '
shinyjs.init = function() {
$(".nav").on("click", ".disabled", function (e) {
e.preventDefault();
return false;
});
}'
css <- '
.disabled {
background: #eee !important;
cursor: default !important;
color: black !important;
}'
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jscode, functions = "init"),
tags$style(css),
selectizeInput("foo", "Show tab2",selected = NULL,choices=c("a","b","c","d"), multiple = TRUE),
tabsetPanel(
id = "navbar",
tabPanel(title = "tab1",
value = "tab1",
h1("Tab 1")
),
tabPanel(title = "tab2",
value = "tab2",
h1("Tab 2")
),
tabPanel(title = "tab3",
id="pqr",
value = "tab3",
h1("Tab 3")
)
)
),
server = function(input, output) {
observe(print(length(input$foo)==1))
observe({
toggleClass(selector = "#navbar li a[data-value=tab3]", class = "disabled",
condition = length(input$foo)==1)
})})
library(shiny)
library(shinyjs)
jscode <- "
shinyjs.disableTab = function(name) {
var tab = $('.nav li a[data-value=' + name + ']');
tab.bind('click.tab', function(e) {
e.preventDefault();
return false;
});
tab.addClass('disabled');
}
shinyjs.enableTab = function(name) {
var tab = $('.nav li a[data-value=' + name + ']');
tab.unbind('click.tab');
tab.removeClass('disabled');
}"
css <- "
.nav li a.disabled {
background-color: #aaa !important;
color: #333 !important;
cursor: not-allowed !important;
border-color: #aaa !important;
}"
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jscode),
inlineCSS(css),
selectizeInput("foo", "Show tab2",selected = NULL,choices=c("a","b","c","d"), multiple = TRUE),
tabsetPanel(
id = "navbar",
tabPanel(title = "tab1",
value = "tab1",
h1("Tab 1")
),
tabPanel(title = "tab2",
value = "tab2",
h1("Tab 2")
),
tabPanel(title = "tab10",
value = "ta10",
h1("Tab 10")
),
tabPanel(title = "tab99",
value = "tab99",
h1("Tab 99")
),
tabPanel(title = "tab19",
value = "tab19",
h1("Tab 19")
),
tabPanel(title = "tab09",
value = "tab09",
h1("Tab 09")
),
tabPanel(title = "tab3",
id="pqr",
value = "tab3",
h1("Tab 3")
)
)
),
server = function(input, output) {
value <- reactive(input$foo)
observeEvent(value(), {
if(length(value())==1){
js$disableTab('tab3')
}
if(length(value())>=2){
js$enableTab('tab3')
}
})
}
)

Add conditionalPanel to multiple navbarMenus in shiny

I have created a shiny application with multiple navbarMenus and tabPanels. Each navBarMenu has separate conditionalPanels. When I add a second navBarMenu in the code snippet below, the conditionalPanel doesn't seem to work for the tabPanels as all input appear on all tabPanels. Not sure what I'm doing wrong.
ui <- shinyUI(tagList(
shinythemes::themeSelector(),
tags$head(
tags$style(HTML("
.shiny-output-error-validation {
color: green;
}
"))
),
navbarPage(title = "Test App",
navbarMenu("nav bar 1", icon = icon("line-chart"),
"menu 1",
"--------",
tabPanel("Tab1",
tabPanel("panel 1", icon = icon("line-chart"),
pageWithSidebar(
headerPanel(""),
sidebarPanel(tags$head(
tags$style(type="text/css", "select { max-width: 400px; }"),
tags$style(type="text/css", ".span4 { max-width: 400px; }"),
tags$style(type="text/css", ".well { max-width: 400px; }"),
tags$style(type="text/css", '#leftPanel { width:200px; float:left;}')
),
conditionalPanel(condition="input.conditionedPanels==1",
dateRangeInput("daterange1", "Select Date Range:", start = "2017-01-01", end = Sys.Date(), width = "100%")
),
conditionalPanel(condition="input.conditionedPanels==2",
dateRangeInput("daterange2", "Select Date Range:", start = "2017-01-01", end = Sys.Date(), width = "100%"),
selectInput("inputw1", "Select cols:", choices = c("col1","col2","col3"), selected = "col1", multiple = FALSE, width = "100%")
),
conditionalPanel(condition="input.conditionedPanels==3"
)
),
mainPanel(
tabsetPanel(id = "conditionedPanels",
tabPanel("tab 1", value = 1, icon = icon("table"),
br(),
h3("Data Table")
),
tabPanel("tab 2", value=2, icon = icon("line-chart"),
column(width = 5, leafletOutput("map1")
)
),
tabPanel("tab 3", value=3 , icon = icon("table"),
tinyMCE('editor1', 'Click to edit text')
)
)
)
)
)
)
),
navbarMenu("nav bar 2", icon = icon("line-chart"),
"menu 1",
"--------",
tabPanel("Tab1",
tabPanel("panel 2", icon = icon("line-chart"),
pageWithSidebar(
headerPanel(""),
sidebarPanel(tags$head(
tags$style(type="text/css", "select { max-width: 400px; }"),
tags$style(type="text/css", ".span4 { max-width: 400px; }"),
tags$style(type="text/css", ".well { max-width: 400px; }"),
tags$style(type="text/css", '#leftPanel { width:200px; float:left;}')
),
conditionalPanel(condition="input.conditionedPanels==4",
dateRangeInput("daterange3", "Select Date Range:", start = "2014-01-01", end = Sys.Date(), width = "100%")
),
conditionalPanel(condition="input.conditionedPanels==5",
dateRangeInput("daterange4", "Select Date Range:", start = "2014-01-01", end = Sys.Date(), width = "100%"),
selectInput("inputw2", "Select cols:", choices = c("col4","col5","col6"), selected = "col1", multiple = FALSE, width = "100%")
),
conditionalPanel(condition="input.conditionedPanels==6"
)
),
mainPanel(
tabsetPanel(id = "conditionedPanels",
tabPanel("tab 1", value = 4, icon = icon("table"),
br(),
h3("Data Table")
),
tabPanel("tab 2", value=5, icon = icon("line-chart"),
column(width = 5, leafletOutput("map1")
)
),
tabPanel("tab 3", value=6 , icon = icon("table"),
tinyMCE('editor2', 'Click to edit text')
)
)
)
)
)
)
)
)
)
)
server <- function(input, output, session){
}
shinyApp(ui, server)
I appreciate any help I can get with fixing my code.
This issue is not because of second navBarMenu it is because the you have two output element with the same name in the two tabs i.e. leafletOutput("map1"). You are not allowed to give the two output elements the same name.
So changing leafletOutput("map1") to leafletOutput("map2") for second tabsetPanel fixes the issue you reported.
The second problem that you will encounter after fixing this issue is that both your tabsetPanel have the same id i.e. conditionedPanels which will cause only your first tabsetPanel to make your conditionalPanel work properly. To fix this issue you have to change the id of your one tabsetPanel.
I have changed the value of your leafletOutput and tabsetPanel id in your code to get the desired output.
library(shiny)
library(leaflet)
library(shinyMCE)
ui <- shinyUI(tagList(
shinythemes::themeSelector(),
tags$head(
tags$style(HTML("
.shiny-output-error-validation {
color: green;
}
"))
),
navbarPage(title = "Test App",
navbarMenu("nav bar 1", icon = icon("line-chart"),
"menu 1",
"--------",
tabPanel("Tab1",
tabPanel("panel 1", icon = icon("line-chart"),
pageWithSidebar(
headerPanel(""),
sidebarPanel(tags$head(
tags$style(type="text/css", "select { max-width: 400px; }"),
tags$style(type="text/css", ".span4 { max-width: 400px; }"),
tags$style(type="text/css", ".well { max-width: 400px; }"),
tags$style(type="text/css", '#leftPanel { width:200px; float:left;}')
),
conditionalPanel(condition="input.conditionedPanels==1",
dateRangeInput("daterange1", "Select Date Range:", start = "2017-01-01", end = Sys.Date(), width = "100%")
),
conditionalPanel(condition="input.conditionedPanels==2",
dateRangeInput("daterange2", "Select Date Range:", start = "2017-01-01", end = Sys.Date(), width = "100%"),
selectInput("inputw1", "Select cols:", choices = c("col1","col2","col3"), selected = "col1", multiple = FALSE, width = "100%")
),
conditionalPanel(condition="input.conditionedPanels==3"
)
),
mainPanel(
tabsetPanel(id = "conditionedPanels",
tabPanel("tab 1", value = 1, icon = icon("table"),
br(),
h3("Data Table")
),
tabPanel("tab 2", value=2, icon = icon("line-chart"),
column(width = 5, leafletOutput("map1")
)
),
tabPanel("tab 3", value=3 , icon = icon("table"),
tinyMCE('editor1', 'Click to edit text')
)
)
)
)
)
)
),
navbarMenu("nav bar 2", icon = icon("line-chart"),
"menu 1",
"--------",
tabPanel("Tab1",
tabPanel("panel 2", icon = icon("line-chart"),
pageWithSidebar(
headerPanel(""),
sidebarPanel(tags$head(
tags$style(type="text/css", "select { max-width: 400px; }"),
tags$style(type="text/css", ".span4 { max-width: 400px; }"),
tags$style(type="text/css", ".well { max-width: 400px; }"),
tags$style(type="text/css", '#leftPanel { width:200px; float:left;}')
),
conditionalPanel(condition="input.conditionedPanels1==4",
dateRangeInput("daterange3", "Select Date Range:", start = "2014-01-01", end = Sys.Date(), width = "100%")
),
conditionalPanel(condition="input.conditionedPanels1==5",
dateRangeInput("daterange4", "Select Date Range:", start = "2014-01-01", end = Sys.Date(), width = "100%"),
selectInput("inputw2", "Select cols:", choices = c("col4","col5","col6"), selected = "col1", multiple = FALSE, width = "100%")
),
conditionalPanel(condition="input.conditionedPanels1==6"
)
),
mainPanel(
tabsetPanel(id = "conditionedPanels1",
tabPanel("tab 1", value = 4, icon = icon("table"),
br(),
h3("Data Table")
),
tabPanel("tab 2", value=5, icon = icon("line-chart"),
column(width = 5, leafletOutput("map2")
)
),
tabPanel("tab 3", value=6 , icon = icon("table"),
tinyMCE('editor2', 'Click to edit text')
)
)
)
)
)
)
)
)
)
)
server <- function(input, output, session){ }
shinyApp(ui, server)
Hope it helps!

How to combine top navigation (navbarPage) and a sidebar menu (sidebarMenu) in shiny

I have a shiny app (using navbarPage) with many tabs and would like to add a sidebarMenu that can be seen no matter which tab is selected. The input values in the sidebar have an impact on the content of all tabs.
Additionally, it should be possible to hide the sidebarMenu as it is in a shinydashboard.
I see two possible ways:
(A) Using shinydashboard and somehow adding a top navigation bar or
(B) using navbarPage and somehow adding a sidebar menu that can be hidden.
(A) Using shinydashboard, the closest to what I want is this (simplified MWE):
library("shiny")
library("shinydashboard")
cases <- list(A=seq(50,500, length.out=10), B=seq(1000,10000, length.out=10))
ui <- dashboardPage(
dashboardHeader(title = "dash w/ navbarMenu"),
dashboardSidebar(selectizeInput('case', 'Pick a case', selected="A", choices = c("A", "B"), multiple = FALSE), numericInput('num', 'Number', min = 1, max = 10, value = 1, step = 1)),
dashboardBody(
tabsetPanel(
tabPanel(h4("Perspective 1"),
tabsetPanel(
tabPanel("Subtab 1.1", plotOutput("plot11")),
tabPanel("Subtab 1.2")
)),
tabPanel(h4("Perspective 2"),
tabsetPanel(
tabPanel("Subtab 2.1"),
tabPanel("Subtab 2.2")
))
)
)
)
server <- function(input, output) {
output$plot11 <- renderPlot({
hist(rnorm(cases[[input$case]][input$num]))
})
}
shinyApp(ui, server)
which is ugly because the navigation bar menu are tabsets which are not part of the menu. What I want is:
Based on this post, I guess it's not possible to include "Perspective 1" and "Perspective 2" tabs in the top menu at all, thus using shinydashboard seems not feasible.
(B) Using navbarPage, I tried using navlistPanel() but I didn't succeed to
(1) make it behave like a sidebarMenu, i.e. be overall visible on the left side of the page and
(2) add hide functionality. Here is my try:
library("shiny")
cases <- list(A=seq(50,500, length.out=10),
B=seq(1000,10000, length.out=10))
ui <- navbarPage(title = "nav w/ sidebarMenu",
tabPanel(h4("Perspective 1"),
tabsetPanel(
tabPanel("Subtab 1.1",
plotOutput("plot11")),
tabPanel("Subtab 1.2")
)),
tabPanel(h4("Perspective 2"),
tabsetPanel(
tabPanel("Subtab 2.1"),
tabPanel("Subtab 2.2")
)),
navlistPanel(widths = c(2, 2), "SidebarMenu",
tabPanel(selectizeInput('case', 'Pick a case', selected="A", choices = c("A", "B"), multiple = FALSE)),
tabPanel(numericInput('num', 'Number', min = 1, max = 10, value = 1, step = 1))
)
)
server <- function(input, output) {
output$plot11 <- renderPlot({
hist(rnorm(cases[[input$case]][input$num]))
})
}
shinyApp(ui, server)
Again, what I want is:
I know, there is flexDashboard. It does not solve the problem for three reasons:
(1) I think it is not possible to hide the sidebar menu, as it is a column and not a real sidebar menu,
(2) it is not reactive which I require in my app,
(3) I think dataTables don't work, which I also need.
Besides, I'd prefer to not have to change the code to Rmarkdown syntax.
Preferably, I'd use a navbarPage and add a sidebarMenu, because my app is already built using navbarPage.
You could use sidebarLayout and do something like this:
ui <- fluidPage(sidebarLayout(
sidebarPanel(navlistPanel(
widths = c(12, 12), "SidebarMenu",
tabPanel(selectizeInput('case', 'Pick a case', selected="A", choices = c("A", "B"), multiple = FALSE)),
tabPanel(numericInput('num', 'Number', min = 1, max = 10, value = 1, step = 1))
)),
mainPanel(navbarPage(title = "nav w/ sidebarMenu",
tabPanel(h4("Perspective 1"),
tabsetPanel(
tabPanel("Subtab 1.1",
plotOutput("plot11")),
tabPanel("Subtab 1.2")
)),
tabPanel(h4("Perspective 2"),
tabsetPanel(
tabPanel("Subtab 2.1"),
tabPanel("Subtab 2.2")
)))
)
))
You get something like this:
Another option would be using fluidRow function. Something like this:
ui <- fluidPage(
fluidRow(
column(3, navlistPanel(
widths = c(12, 12), "SidebarMenu",
tabPanel(selectizeInput('case', 'Pick a case', selected="A", choices = c("A", "B"), multiple = FALSE)),
tabPanel(numericInput('num', 'Number', min = 1, max = 10, value = 1, step = 1))
)),
column(9, navbarPage(title = "nav w/ sidebarMenu",
tabPanel(h4("Perspective 1"),
tabsetPanel(
tabPanel("Subtab 1.1",
plotOutput("plot11")),
tabPanel("Subtab 1.2")
)),
tabPanel(h4("Perspective 2"),
tabsetPanel(
tabPanel("Subtab 2.1"),
tabPanel("Subtab 2.2")
))))
)
)
To get this:
Hope it helps!
This is now possible using bootstraplib
Github Request to implement this:
https://github.com/rstudio/bootstraplib/issues/76
min reprex:
# package load ------------------------------------------------------------
library(shiny)
library(bootstraplib)
# boot dash layout funs ---------------------------------------------------
boot_side_layout <- function(...) {
div(class = "d-flex wrapper", ...)
}
boot_sidebar <- function(...) {
div(
class = "bg-light border-right sidebar-wrapper",
div(class = "list-group list-group-flush", ...)
)
}
boot_main <- function(...) {
div(
class = "page-content-wrapper",
div(class = "container-fluid", ...)
)
}
# title -------------------------------------------------------------------
html_title <-
'<span class="logo">
<div style="display:inline-block;">
<img src="https://jeroen.github.io/images/Rlogo.png" height="35"/>
<b>my company name</b> a subtitle of application or dashboard
</div>
</span>'
# css ---------------------------------------------------------------------
css_def <- "
body {
overflow-x: hidden;
}
.container-fluid, .container-sm, .container-md, .container-lg, .container-xl {
padding-left: 0px;
}
.sidebar-wrapper {
min-height: 100vh;
margin-left: -15rem;
padding-left: 15px;
padding-right: 15px;
-webkit-transition: margin .25s ease-out;
-moz-transition: margin .25s ease-out;
-o-transition: margin .25s ease-out;
transition: margin .25s ease-out;
}
.sidebar-wrapper .list-group {
width: 15rem;
}
.page-content-wrapper {
min-width: 100vw;
padding: 20px;
}
.wrapper.toggled .sidebar-wrapper {
margin-left: 0;
}
.sidebar-wrapper, .page-content-wrapper {
padding-top: 20px;
}
.navbar{
margin-bottom: 0px;
}
#media (max-width: 768px) {
.sidebar-wrapper {
padding-right: 0px;
padding-left: 0px;
}
}
#media (min-width: 768px) {
.sidebar-wrapper {
margin-left: 0;
}
.page-content-wrapper {
min-width: 0;
width: 100%;
}
.wrapper.toggled .sidebar-wrapper {
margin-left: -15rem;
}
}
"
# app ---------------------------------------------------------------------
ui <- tagList(
tags$head(tags$style(HTML(css_def))),
bootstrap(),
navbarPage(
collapsible = TRUE,
title = HTML(html_title),
tabPanel(
"Tab 1",
boot_side_layout(
boot_sidebar(
sliderInput(
inputId = "bins",
label = "Number of bins:",
min = 1,
max = 50,
value = 30
)
),
boot_main(
fluidRow(column(6, h1("Plot 1")), column(6, h1("Plot 2"))),
fluidRow(
column(6, plotOutput(outputId = "distPlot")),
column(6, plotOutput(outputId = "distPlot2"))
)
)
)
),
tabPanel(
"Tab 2",
boot_side_layout(
boot_sidebar(h1("sidebar input")),
boot_main(h1("main output"))
)
)
)
)
server <- function(input, output) {
output$distPlot <- renderPlot({
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x,
breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times"
)
})
output$distPlot2 <- renderPlot({
x <- faithful$waiting
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x,
breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times"
)
})
}
shinyApp(ui, server)

Resources