'How to reactively change title of ShinyDashboard box in R?
My code looks like below where user can select location from sidebarpanel and based on user selection data is displayed in mainpanel. Next, I would like to dynamically change the title of the plot based on user selection. For example, If user selects location1 then the tile of Plot should display "Loc1"(Below image highlights the place where, I need to change my title) .I am not sure how to achieve this in ShinyDashboard
Please provide explanation with code.
Code:
library(shiny)
library(shinydashboard)
resetForm<-function(session){
updateSelectInput(session,"slct1",selected = ' ')
}
ui<-dashboardPage(
dashboardHeader(title="System Tracker"),
dashboardSidebar(
selectInput('slct1',"Select Location",choices = c(" ",d$Locations)),
actionButton('clear',"Reset Form"),
h4("Powered by:"),
tags$img(src='baka.png',height=50,width=50)
),
dashboardBody(
#fluidRow(
# box( DT::dataTableOutput("mytable")),
# box(plotlyOutput('out'))
conditionalPanel(
#Uses a Javascript formatted condition
condition="input.slct1 !== ' '",
box( DT::dataTableOutput("mytable")),
box(plotlyOutput('out'),status = 'warning',solidHeader = T)
)
)
)
server<-function(input, output,session) {
output$mytable = DT::renderDataTable({
req(input$slct1)
d %>%
filter(Locations==input$slct1)
})
output$out<-renderPlotly({
req(input$slct1)
data_filter<-dd %>%
filter(Locations==input$slct1)
req(nrow(data_filter)>0) #https://stackoverflow.com/questions/51427189/facet-grid-in-shiny-flexdashboard-giving-error-faceting-variables-must-have-at
ggplotly(ggplot(data_filter, aes(Systems,frequency,fill=year)) +
geom_col(position = 'stack')+geom_text(aes(label=label), position = position_stack(vjust = .5)))#+
#facet_grid(.~Locations, space= "free_x", scales = "free_x"))
})
observeEvent(input$clear,{
req(input$slct1)
resetForm(session)
})
}
shinyApp(ui, server)
Data:
structure(list(Systems = c("Sys1", "Sys1", "Sys2", "Sys3", "Sys4",
"Sys6", "Sys7"), Locations = c("loc1", "loc1", "loc1", "loc2",
"loc2", "loc3", "loc1"), year = structure(c(2L, 1L, 1L, 1L, 1L,
3L, 3L), .Label = c("2019", "2018", "0"), class = "factor"),
frequency = c(1L, 2L, 1L, 1L, 1L, 0L, 0L), freq_cal = c(33.33,
66.67, 100, 100, 100, 0, 0), label = c("33.33%", "66.67%",
"100.00%", "100.00%", "100.00%", "0.00%", "0.00%")), row.names = c(NA,
-7L), class = "data.frame")
Solution 1:[1]
You can achieve this with a combination of uiOutput and renderUI, by moving box() function from the UI into the server as follows,
library(shiny)
library(plotly)
library(shinydashboard)
d = structure(list(Systems = c("Sys1", "Sys1", "Sys2", "Sys3", "Sys4",
"Sys6", "Sys7"), Locations = c("loc1", "loc1", "loc1", "loc2",
"loc2", "loc3", "loc1"), year = structure(c(2L, 1L, 1L, 1L, 1L,
3L, 3L), .Label = c("2019", "2018", "0"), class = "factor"),
frequency = c(1L, 2L, 1L, 1L, 1L, 0L, 0L), freq_cal = c(33.33,
66.67, 100, 100, 100, 0, 0), label = c("33.33%", "66.67%",
"100.00%", "100.00%", "100.00%", "0.00%", "0.00%")), row.names = c(NA,
-7L), class = "data.frame")
ui<-dashboardPage(
dashboardHeader(title="System Tracker"),
dashboardSidebar(
selectInput('slct1',"Select Location",choices = c(" ",d$Locations)),
actionButton('clear',"Reset Form"),
h4("Powered by:"),
tags$img(src='baka.png',height=50,width=50)
),
dashboardBody(
#fluidRow(
# box( DT::dataTableOutput("mytable")),
# box(plotlyOutput('out'))
conditionalPanel(
#Uses a Javascript formatted condition
condition="input.slct1 !== ' '",
box(DT::dataTableOutput("mytable")),
uiOutput("placeholder")
)
)
)
server<-function(input, output,session) {
output$placeholder = renderUI({
req(input$slct1)
box(title = input$slct1,plotlyOutput('out'),status = 'warning',solidHeader = T)
})
output$mytable = DT::renderDataTable({
req(input$slct1)
d %>%
filter(Locations==input$slct1)
})
output$out<-renderPlotly({
req(input$slct1)
data_filter<-d %>%
filter(Locations==input$slct1)
req(nrow(data_filter)>0)
ggplotly(ggplot(data_filter, aes(Systems,frequency,fill=year)) +
geom_col(position = 'stack')+geom_text(aes(label=label), position = position_stack(vjust = .5)))#+
#facet_grid(.~Locations, space= "free_x", scales = "free_x"))
})
observeEvent(input$clear,{
req(input$slct1)
updateSelectInput(session,"slct1",selected = ' ')
})
}
shinyApp(ui, server)
Solution 2:[2]
Ok so you need to do the rendering of the box on the server side and push that over to the ui
try adding following part in your server
...
output$box_test <- renderUI({
req(input$slct1)
box(title = input$slct1, status = "primary",solidHeader = TRUE)
})
...
and following in your ui
...
dashboardBody(
#fluidRow(
# box( DT::dataTableOutput("mytable")),
# box(plotlyOutput('out'))
conditionalPanel(
#Uses a Javascript formatted condition
condition="input.slct1 !== ' '",
box( DT::dataTableOutput("mytable")),
box(plotlyOutput('out'),status = 'warning',solidHeader = T)
),
uiOutput("box_test")
)
...
Solution 3:[3]
This post dates back a bit but I've found a way of doing this without putting the box in the server part if somebody is ever interesed ! The trick is to create a renderUI only for the box title. It actually works to feed in a uiOutput in the box(title = ...) argument.
With the correct solution provided by @Sada93 above, you simply need to replace
uiOutput("placeholder")
by
box(title = uiOutput("placeholder"), plotlyOutput('out'), status = 'warning',solidHeader = T)
and
output$placeholder = renderUI({
req(input$slct1)
box(title = input$slct1,plotlyOutput('out'),status = 'warning',solidHeader = T)
})
by
output$placeholder = renderUI({
req(input$slct1)
paste("Pasting something before the input$slct1 value :", input$slct1)
})
Hope it helps :) ! Cheers
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | Sada93 |
| Solution 2 | |
| Solution 3 | Eduperron |