Как реактивно изменить заголовок окна ShinyDashboard в R?

Мой код выглядит так, как показано ниже, где пользователь может выбрать местоположение из sidebarpanel, и на основе данных выбора пользователя отображается в mainpanel. Затем я хотел бы динамически изменять title графика в зависимости от выбора пользователя. Например, если пользователь выбирает location1, тогда на плитке Plot должно отображаться «Loc1» (изображение ниже выделяет место, где мне нужно изменить заголовок). Я не уверен, как этого добиться в ShinyDashboard

Пожалуйста, предоставьте объяснение с кодом.

введите здесь описание изображения

Код:

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)

Данные:

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

person biggboss2019    schedule 02.08.2019    source источник


Ответы (2)


Вы можете добиться этого с помощью комбинации uiOutput и renderUI, переместив функцию box() из пользовательского интерфейса на сервер следующим образом:

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)
person Sada93    schedule 02.08.2019
comment
Что, если я хочу отобразить текст, например «Выбранное местоположение:», а затем «Выбранное местоположение»? - person biggboss2019; 03.08.2019
comment
Используйте 1_ - person Sada93; 03.08.2019
comment
Куда пойти шуд паста (...)? перед коробкой? Извините, я немного новичок в ShinyDashBord - person biggboss2019; 03.08.2019
comment
Идеально. Спасибо! - person biggboss2019; 03.08.2019

Хорошо, поэтому вам нужно выполнить рендеринг окна на стороне сервера и передать его в пользовательский интерфейс.

попробуйте добавить следующую часть в свой server

...
  output$box_test <- renderUI({
    req(input$slct1)
    box(title = input$slct1, status = "primary",solidHeader = TRUE)
  })

...  

и в своем 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")


    )
...
person CER    schedule 02.08.2019
comment
Я хотел бы видеть что-то подобное, как показано здесь, в разделе первых полей - rstudio.github.io/ shinydashboard / structure.html - person biggboss2019; 03.08.2019
comment
Я думаю, что @ Sada93 дал свой ответ несколькими секундами ранее, так что честь ему - person CER; 03.08.2019
comment
Отличный подход с вашей стороны, ребята !! Спасибо за ваше время и усилия! Вот почему мне так нравится. Узнал что-то новое сегодня :) - person biggboss2019; 03.08.2019