闪亮的仪表板框折叠

问题描述

library(shinydashboard)
library(shiny)
library(dplyr)
 

trtall <- rbind(rep("A",100),rep("B",rep("C",100))
trt <- sample(trtall,80)
agecat.temp <- c(rep("18-40",rep("> 40",100))
agecat <- sample(agecat.temp,80)
sex <- sample(rbind(rep("M",rep("F",100)),80)
race <- sample(rbind(rep("Asian",50),rep("Hispanic",rep("Other",50)),80)

df <- data.frame(trt,agecat,sex,race)

 
body <- dashboardBody(
  fluidRow(Box(width=12,collapsed=F,collapsible = T,title="Filters",solidHeader = T,status="primary",Box(width=5,height="220px",fluidRow(column(6,uIoUtput("uivr1")),column(6,uIoUtput("uivl1")))))))
 
ui <- dashboardPage(
  dashboardHeader(disable = T),dashboardSidebar(disable = T),body,skin = "green"
)

 server = function(input,output) {
  reacui1 <- reactiveVal()

   observeEvent(input$vr1,{
      reacui1(as.list(df %>% distinct(!!input$vr1) %>% arrange(!!input$vr1)))
  })

  output$uivr1 <- renderUI(varSelectInput(width = "200px","vr1",NULL,df))
  output$uivl1 <- renderUI(selectInput("vl1",width="200px",multiple=T,choices=reacui1()))
  
}

shinyApp(ui,server)

嗨，

我正在动态地尝试在闪亮的应用程序中创建 UI。逻辑工作正常，直到我在闪亮的仪表板中折叠框。

我执行了以下步骤并得到了意想不到的结果。

我在“vr1”中选择了“trt”，然后从“vl1”中选择了“A”。
我折叠了盒子。
然后打开盒子。
我在“vr1”中选择了“agecat” - 现在我仍然看到各种治疗（A、B、C），但在“40） >vl1"

你能帮忙吗。

解决方法

问题来自于 shown 事件没有传递给折叠框内框内的元素。

将此与此稍微更改的示例进行比较：

body <- dashboardBody(
  fluidRow(
    box(width = 12,collapsed = FALSE,collapsible = TRUE,title = "Filters",solidHeader = TRUE,status = "primary",# box(width=5,height="220px",status="primary",fluidRow(column(6,uiOutput("uivr1")),column(6,uiOutput("uivl1"))
        #     )
        )
    )
  )
)

并且您看到在这种情况下，第二个输入已正确更新。

您也可以使用您的示例，转到 JS 控制台并输入 $('.box').trigger('shown')，您将看到选择输入突然更新。

这意味着问题在于，shiny 仍然认为输入是隐藏的，并且由于隐藏的输入未更新，您会观察到这种行为。

但这告诉我们如何修复它：

解决方法是关闭 suspendWhenHidden 属性。将此添加到您的服务器：
```
  session$onFlushed(function() {
    outputOptions(output,"uivl1",suspendWhenHidden = FALSE)
  })
```
然而，这只是解决症状，而不是解决问题。

另一种方法是确保 shown.bs.collapse 事件也在框内的框上触发。为此，我们可以侦听 shown.bs.collapse 事件，一旦收到，请稍等（800 毫秒），以便该框完全可见，然后通知所有 shiny-bound-output 子项应该显示它们：

js <- "$(() => $('body').on('shown.bs.collapse','.box',function(evt) { 
      setTimeout(function(){
         $(evt.target).find('.shiny-bound-output').trigger('shown.bs.collapse');
      },800);
   }))"

body <- dashboardBody(
  tags$head(tags$script(HTML(js))),fluidRow(
    box(width = 12,box(width = 5,height = "220px",uiOutput("uivl1"))
            )
        )
    )
  )
)

顺便说一句，这已经被报告为错误：https://github.com/rstudio/shinydashboard/issues/234

r r renderui shiny shinydashboard