How to reactively change title of ShinyDashboard box in R?

Question

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

Answer 1

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

Answer 2

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)

Answer 3

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


    )
...