R Shiny Dashboard - uiOutput 未在选项卡项内呈现

如何解决R Shiny Dashboard - uiOutput 未在选项卡项内呈现

我正在构建一个闪亮的仪表板，并希望包含一个具有动态值范围的滑块。为此，我在服务器上生成 sliderInput 并用 renderUI/uIoUput 显示它。在下面的示例中，如果我只在一个 tabPanel 上包含滑块，则效果很好。但是，当我尝试将它添加到第二个 tabPanel 时，它无法呈现。

This post 描述了一个类似的问题，但解决方案 (suspendWhenHidden = FALSE) 对我不起作用。我也尝试了 this post 的解决方案，尽管那里的问题有些不同。

library(shinydashboard)
library(shiny)
ui <- dashboardPage(
  dashboardHeader(title = "Demo dashboard"),dashboardSidebar(
    sidebarMenu(
      menuItem("Overview",tabName = "overview",icon = icon("dashboard"))
    )
  ),dashboardBody(
    tabItems(
      tabItem(tabName = "overview",fluidRow(
          column(width = 6,tabBox(
             title = "Tab Box",width = "100%",id = "tabset1",height = "250px",tabPanel("Tab 1",img(src = "test_img.jpg",height="100%",width="100%",align="center"),# the slider is rendered properly if only included in a single tab
              uIoUtput("out_slider")
             ),tabPanel("Tab 2",# however,uncommenting below causes the slider to not render on *either* tab 
              #uIoUtput("out_slider")
             )
            )
          )
        )
      )
    )
  )
)


server <- function(input,output) {
  
  
  startDate <- as.Date("2019-01-01","%Y-%m-%d")
  endDate <- as.Date("2020-01-01","%Y-%m-%d")
  
  # from https://stackoverflow.com/q/36613018/11434833 ... does not seem to fix problem
  # output$out_slider <- renderUI({})
  # outputoptions(output,"out_slider",suspendWhenHidden = FALSE)
  
  output$out_slider <- renderUI({
    sliderInput("slider1",label = h3("Slider"),min = startDate,max = endDate,value = endDate,timeFormat="%e %b,%y")
  })
  
}

shinyApp(ui,server)

解决方法

正如YBS所说，ID存在冲突。 尝试创建如下所示的模块。

library(shinydashboard)
library(shiny)

slider<-function(id){
  ns<-NS(id)
  tagList(
    uiOutput(ns("out_slider"))
  )
}

sliderServer<-function(id,label,min,max,value,timeFormat="%e %b,%y"){
  moduleServer(
    id,function(input,output,session){
      output$out_slider <- renderUI({
        sliderInput("slider",%y")
      })
    }
  )
}


ui <- dashboardPage(
  dashboardHeader(title = "Demo dashboard"),dashboardSidebar(
    sidebarMenu(
      menuItem("Overview",tabName = "overview",icon = icon("dashboard"))
    )
  ),dashboardBody(
    tabItems(
      tabItem(tabName = "overview",fluidRow(
                column(width = 6,tabBox(
                         title = "Tab box",width = "100%",id = "tabset1",height = "250px",tabPanel("Tab 1",img(src = "test_img.jpg",height="100%",width="100%",align="center"),# the slider is rendered properly if only included in a single tab
                                  slider("tab1")
                         ),tabPanel("Tab 2",# however,uncommenting below causes the slider to not render on *either* tab 
                                  slider("tab2")
                         )
                       )
                )
              )
      )
    )
  )
)


server <- function(input,output) {
  
  
  startDate <- as.Date("2019-01-01","%Y-%m-%d")
  endDate <- as.Date("2020-01-01","%Y-%m-%d")
  
  sliderServer("tab1",label = h3("Slider"),min = as.Date("2019-01-01","%Y-%m-%d"),max = as.Date("2020-01-01",value = as.Date("2020-01-01",%y")
  
  sliderServer("tab2",%y")
  

  
}

shinyApp(ui,server)

如果你打算在sliderServer函数中传递反应值，请将它包装在observeEvent中。