I am creating a dashboard using Shinydashboard package, where I need to change the background color based on the selected Tab. I have tried the following code, but it is not working as intended.
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- dashboardPage(dashboardHeader(dropdownMenuOutput("notificationMenu")),
dashboardSidebar(sidebarMenu(menuItem("Page 1", tabName = "page1"),
menuItem("Page 2", tabName = "page2"))),
dashboardBody(tags$style(".content {background-color: #f7f7f7;
.content-wrapper .tab-pane .shiny-tab-page1 {background-color: #000000;
}
"),
tabItems(
tabItem(tabName = "page1", h4("This is Page 1")),
tabItem(tabName = "page2",
textInput("text", "Enter News:", "New News."),
actionButton("save", "Save")))))
server <- function(input, output, session){
raw_news <- reactiveValues()
# Intial Header News: 1 Message from Admin
raw_news$news <- data_frame(from = "Admin", text = "this is a message")
# The notifications in header
output$notificationMenu <- renderMenu({
raw_news <- raw_news$news
dropdownMenu(
messageItem(raw_news$from[1], raw_news$text[1])
)
})
# save a new notification
observeEvent(input$save, {
raw_news$news <- data.frame(from = "User", text = input$text)
})
}
shinyApp(ui = ui, server = server)
Any help will be appreciated.
One possible solution would be to render a style tag, dependent on the selected tab. Note that in order to do so, the sidebarmenu needs an id. Below is a working example, hope this helps!
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(dropdownMenuOutput("notificationMenu")),
dashboardSidebar(sidebarMenu(id='sidebar',
menuItem("Page 1", tabName = "page1"),
menuItem("Page 2", tabName = "page2")),
uiOutput('style_tag')),
dashboardBody(
tabItems(
tabItem(tabName = "page1", h4("Blue!",style='color:white')),
tabItem(tabName = "page2", h4('Red!'))
))
)
server <- function(input, output, session){
output$style_tag <- renderUI({
if(input$sidebar=='page1')
return(tags$head(tags$style(HTML('.content-wrapper {background-color:blue;}'))))
if(input$sidebar=='page2')
return(tags$head(tags$style(HTML('.content-wrapper {background-color:red;}'))))
})
}
shinyApp(ui = ui, server = server)
Related
right now when the user runs the app, the desired website/dashboard body is displayed, however, I want the desired website/body to display ONLY when the user selects "Control Chart" from "Tab 1" in the sidebar menu. This is because I will have multiple sidebar tabs, when depending on the website the user selects, the embedded website should automatically change. When the user initially runs the app, the dashboard body should be blank. Only when they select Tab 1 -> Cell Culture -> Control Chart should they see the google homepage.
Please help!
ui <-
dashboardPage(
skin = "black",
dashboardHeader(title = "Dashboard ", titleWidth = 450),
dashboardSidebar(sidebarMenu(
menuItem(
"Tab 1",
tabName = "tab 1",
icon = icon("medicine"),
menuItem("Cell Culture",
menuItem("Control Chart"))
)
)),
dashboardBody(mainPanel(fluidRow(htmlOutput("frame"))
),
))
server = function(input, output, session) {
observe({
test <<- paste0("https://google.com") #sample url
})
output$frame <- renderUI({
input$Member
my_test <- tags$iframe(src = test,
height = 800,
width = 800)
print(my_test)
my_test
})
}
shinyApp(ui, server)
You can define a blank tab as the first menuItem, and then you should be able to select the appropriate menuItem to display the desired objects. Also, you should define tabName to ensure that the appropriate objects are displayed and tie it to them in dashboardBody as shown below. Try this
ui <-
dashboardPage(
skin = "black",
dashboardHeader(title = "Dashboard ", titleWidth = 450),
dashboardSidebar(sidebarMenu(
menuItem("",tabName="home"),
menuItem(
"Tab 1",
tabName = "tab 1",
icon = icon("medicine"),
menuItem("Cell Culture",
menuItem("Control Chart", tabName = "mytab"))
)
)),
dashboardBody(mainPanel(
tabItems(
tabItem(tabName = "home"),
tabItem(tabName = "mytab",
fluidRow(plotOutput("plot1"), htmlOutput("frame"))
)
)
),
))
server = function(input, output, session) {
#observe({
# test <- paste0("https://google.com") #sample url
#})
output$plot1 <- renderPlot(plot(cars))
url <- a("Google Homepage", href="https://www.google.com/")
output$frame <- renderUI({
#input$Member
my_test <- tags$iframe(href = url,
height = 800,
width = 800)
print(my_test)
print("Hello!")
my_test
})
}
shinyApp(ui, server)
I want the embedded website to show on the right of the sidebar menu, but the embedded website is showing within the sidebar menu. When the user presses control chart under Cell Culture, the embedded website should show clearly to the right. Here is an image of my issue ]1
How can I fix this error?
Here is my code:
library(shiny)
library(shinydashboard)
ui <-
dashboardPage(skin="black",
dashboardHeader(title = "CPV Dashboard ", titleWidth = 450),
dashboardSidebar(
sidebarMenu(
menuItem("Tab 1", tabName = "tab 1", icon = icon("medicine"),
menuItem("Cell Culture",
menuItem("Control Chart", mainPanel(fluidRow(
htmlOutput("frame")))))))
),
dashboardBody())
server = function(input, output, session){
observe({
test <<- paste0("https://google.com") #sample url
})
output$frame <- renderUI({
input$Member
my_test <- tags$iframe(src=test, height=800, width=800)
print(my_test)
my_test
})
}
shinyApp(ui, server)
I think you need the dashBoardBody inside the dashboardPage.
As far as I can see your current code isn't doing that.
library(shiny)
library(shinydashboard)
ui <-
dashboardPage(
skin = "black",
dashboardHeader(title = "CPV Dashboard ", titleWidth = 450),
dashboardSidebar(sidebarMenu(
menuItem(
"Tab 1",
tabName = "tab 1",
icon = icon("medicine"),
menuItem("Cell Culture",
menuItem("Control Chart"))
)
)),
dashboardBody(mainPanel(fluidRow(htmlOutput("frame"))
),
))
server = function(input, output, session) {
observe({
test <<- paste0("https://google.com") #sample url
})
output$frame <- renderUI({
input$Member
my_test <- tags$iframe(src = test,
height = 800,
width = 800)
print(my_test)
my_test
})
}
shinyApp(ui, server)
library(shiny)
library(tidyverse)
library(leaflet)
library(shinydashboard)
library(RColorBrewer)
library(viridis)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")
),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
# Boxes need to be put in a row (or column)
tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
box(plotOutput("plot1", height = 250)),
box(
title = "Controls",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
)
),
# Second tab content
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
)
server <- function(input, output) {
set.seed(122)
histdata <- rnorm(500)
output$plot1 <- renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
}
shinyApp(ui, server)
The above example, the output renders when the tabs dashboard and widgets are clicked seperately. In the dashboard tab, i have my slider input in the body.
Now when I change my slider to have it at the sidebar:
library(shiny)
library(tidyverse)
library(leaflet)
library(shinydashboard)
library(RColorBrewer)
library(viridis)
library(shinyWidgets)
ui = dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
sidebarMenu(
id = "sidebarmenu",
menuItem("menuItem1",
tabName = "tab1",
sliderInput("slider", "Number of observations:", 1, 100, 50)
)
,
menuItem("menuItem2", tabName = "tab2")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "tab1",
tableOutput("myTable"),
),
tabItem(tabName = "tab2",
h2("Placeholder Cloud"),
plotOutput("myPlot"))
)
)
)
server <- function(input, output, session) {
tableData = reactiveVal(data.frame(x = 1:10, y = LETTERS[1:10]))
plotData = reactiveVal()
observeEvent(input$sidebarmenu, {
if(input$sidebarmenu == "tab2"){
#Code for tab 2
req(is.null(plotData()))
print("Tab 2 code is run")
plotData(runif(100))
}
})
output$myTable = renderTable({
tableData()
})
set.seed(122)
histdata <- rnorm(500)
output$myPlot = renderPlot({
data <- histdata[seq_len(input$slider)]
hist(data)
})
}
shinyApp(ui, server)
Problem here:
1) The text placeholder cloud, initially only rendered when the tab menuItem2 is clicked, now gets rendered together with the histogram which was supposed to render only when i clicked menuItem1
2) clicking on menuItem2 does not do anything. I would like to have tab2 when clicked, show a scatterplot as seen in this below block of code.
i.e., i would like to "integrate the below 3rd block of code" into the 2nd, the above so when i run the second block of code, when i click tab1, the input for the slider appears and renders the histogram. when i click tab2, the scatterplot will be rendered
library(shiny)
library(tidyverse)
library(leaflet)
library(shinydashboard)
library(RColorBrewer)
library(viridis)
library(shinyWidgets)
ui = dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
sidebarMenu(
id = "sidebarmenu",
menuItem("menuItem1",
tabName = "tab1")
,
menuItem("menuItem2", tabName = "tab2")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "tab1",
tableOutput("myTable")),
tabItem(tabName = "tab2",
h2("Placeholder Cloud"),
plotOutput("myPlot"))
)
)
)
server <- function(input, output, session) {
tableData = reactiveVal(data.frame(x = 1:10, y = LETTERS[1:10]))
plotData = reactiveVal()
observeEvent(input$sidebarmenu, {
if(input$sidebarmenu == "tab2"){
#Code for tab 2
req(is.null(plotData()))
print("Tab 2 code is run")
plotData(runif(100))
}
})
output$myTable = renderTable({
tableData()
})
output$myPlot = renderPlot({
plot(plotData())
})
}
shinyApp(ui, server)
Any help is appreciated.I am new to Shiny.
for your 2nd part you said "clicking on menuItem2 does not do anything."... but you don't have any action for menuItem2 see
menuItem("menuItem2", tabName = "tab2")
Background
Within a modular1 Shiny application, I would like to load module only when menu item on shinydashboard is clicked. If the menu item is not accessed I wouldn't like to load the module.
Basic application
app.R
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
callModule(sampleModuleServer, "sampleModule")
output$menu <- renderMenu({
sidebarMenu(
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
sample_module.R
sampleModuleServer <- function(input, output, session) {
output$plot1 <- renderPlot({
plot(mtcars)
})
}
sampleModuleUI <- function(id) {
ns <- NS(id)
plotOutput(ns("plot1"))
}
Desired implementation
The desired implementation would load sample_module only when the relevant menu item is clicked. On the lines of 2:
Don't call callModule from inside observeEvent; keep it at the top level. Take the reactive expression that's returned, and use eventReactive to wrap it in the button click. And use the eventReactive from your outputs, etc.
x <- callModule(...)
y <- eventReactive(input$go, x())
output$tbl <- DT::renderDataTable(y())
Attempt
app.R (modified)
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
eventReactive(eventExpr = input$tab_two,
valueExpr = callModule(sampleModuleServer, "sampleModule")
)
output$menu <- renderMenu({
sidebarMenu(
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
Problem
Application runs but the module does not load. Questions:
How to correctly call eventReactive on dashboard menu item? The tab_item does not seem to have id parameter is tabName equivalent in that context?
The linked discussion refers to refreshing one table. I'm trying to figure out example that will work with modules containing numerous interface element and elaborate server calls.
Clicking on Menu item 2 should display the content from the sample_module.R file.
1 Modularizing Shiny app code
2 Google groups: activate module with actionButton
Update
I've tried explicitly forcing module into application environment load using the following syntax:
eventReactive(eventExpr = input$tab_two,
valueExpr = callModule(sampleModuleServer, "sampleModule"),
domain = MainAppDomain
)
where
MainAppDomain <- getDefaultReactiveDomain()
Edit: Dropping Joe Cheng's top level statement:
# Libs
library(shiny)
library(shinydashboard)
# Source module
source("sample_module.R")
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenuOutput("menu")),
dashboardBody(tabItems(
tabItem(tabName = "tab_one", h1("Tab One")),
tabItem(tabName = "tab_two", sampleModuleUI("sampleModule"))
))
)
server <- function(input, output) {
observeEvent(input$tabs,{
if(input$tabs=="tab_two"){
callModule(sampleModuleServer, "sampleModule")
}
}, ignoreNULL = TRUE, ignoreInit = TRUE)
output$menu <- renderMenu({
sidebarMenu(id = "tabs",
menuItem(
"Menu item 1",
icon = icon("calendar"),
tabName = "tab_one"
),
menuItem(
"Menu item 2",
icon = icon("globe"),
tabName = "tab_two"
)
)
})
}
shinyApp(ui, server)
Furthermore, your sidebarMenu needs an id to access the selected tabs; please see the shinydashboard documentation.
I am working on something where I need a floating button in shinydashboard. Below is a code to get a floating button using shinyMaterial package.
library(shiny)
library(shinymaterial)
# Wrap shinymaterial apps in material_page
ui <- material_page(title = "Basic Page",
tags$h1("Page Content"),
material_floating_button(
input_id = "example_floating_button",
icon = "live_help",
depth = 5,
color = "red lighten-3"
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
When I am trying to use the floating button from shinymaterial library in shinydashboard, it doesn't work. Any help is appreciated, all I want if a floating button on every page..using any library.
library(shiny)
library(shinydashboard)
library(dplyr)
library("shinymaterial")
ui <- dashboardPage(
dashboardHeader(dropdownMenuOutput("notificationMenu")),
dashboardSidebar(sidebarMenu(menuItem("Page 1", tabName = "page1"),
menuItem("Page 2", tabName = "page2"))),
dashboardBody(tabItems(
tabItem(tabName = "page1", h4("This is Page 1"),
material_floating_button(
input_id = "example_floating_button",
icon = "live_help",
depth = 5,
color = "red lighten-3"
)),
tabItem(tabName = "page2",
textInput("text", "Enter News:", "New News."),
actionButton("save", "Save"))
)))
server <- function(input, output, session){
raw_news <- reactiveValues()
# Intial Header News: 1 Message from Admin
raw_news$news <- data_frame(from = "Admin", text = "this is a message")
# The notifications in header
output$notificationMenu <- renderMenu({
raw_news <- raw_news$news
dropdownMenu(
messageItem(raw_news$from[1], raw_news$text[1])
)
})
# save a new notification
observeEvent(input$save, {
raw_news$news <- data.frame(from = "User", text = input$text)
})
}
shinyApp(ui = ui, server = server)
Just use an actionButton in a fixedPanel instead.
tabItem(tabName = "page1", h4("This is Page 1"),
fixedPanel(
actionButton("test", label = "test"),
right = 10,
bottom = 10
)
),