闪亮的下拉按钮错误答案

【问题标题】：shiny dropdown button error闪亮的下拉按钮错误
【发布时间】：2017-11-24 18:03:09
【问题描述】：

我一直在我的shiny 应用程序中使用dropdown function found here。但是，当我尝试在使用 navbarMenu/tabPanelui 布局的应用程序中使用它时，我注意到异常行为。一旦您选择了包含下拉菜单的选项卡，下面的应用将不允许您从一个选项卡切换到另一个选项卡。

library(shiny)

dropdownButton <- function(label = "",
                           status = c("default", "primary", "success", "info",
                                      "warning", "danger"),
                           ...,
                           width = NULL) {
    status <- match.arg(status)
    # dropdown button content
    html_ul <- list(
        class = "dropdown-menu",
        style = if (!is.null(width))
            paste0("width: ", validateCssUnit(width), ";"),
        lapply(
            X = list(...),
            FUN = tags$li,
            style = "margin-left: 10px; margin-right: 10px;"
        )
    )
    # dropdown button apparence
    html_button <- list(
        class = paste0("btn btn-", status, " dropdown-toggle"),
        type = "button",
        `data-toggle` = "dropdown"
    )
    html_button <- c(html_button, list(label))
    html_button <- c(html_button, list(tags$span(class = "caret")))
    # final result
    tags$div(
        class = "dropdown",
        do.call(tags$button, html_button),
        do.call(tags$ul, html_ul),
        tags$script(
            "$('.dropdown-menu').click(function(e) {
            e.stopPropagation();
});"
        )
    )
}


ui <- fluidPage(
    navbarPage("This is an App", 
               tabPanel("Start Here - Page 0"), 
               navbarMenu("This is Page 1", 
                          tabPanel("p1 t1", 
                                   uiOutput("p1t1_out"), 
                                   checkboxInput("test", "here")), 
                          tabPanel("p2 t2")), 
               navbarMenu("This is Page 2",
                          tabPanel("p2 t1"), 
                          tabPanel("p2 t2"))))


server <- function(input, output, session) {

    output$p1t1_out <- renderUI({
        dropdownButton(
            label = "Select Here",
            status = "default",
            width = 300,
            actionButton(inputId = "p1t1_all", label = "(Un)select All"),
            checkboxGroupInput(
                inputId = "p1t1_choice",
                label = "select vars",
                choices = as.list(names(mtcars)),
                selected = as.list(names(mtcars))
            )
        )
    })
    # Select all / Unselect all 
    observeEvent(input$p1t1_all, {
        if (is.null(input$p1t1_choice)) {
            updateCheckboxGroupInput(
                session = session,
                inputId = "p1t1_choice",
                selected = as.list(names(mtcars))
            )
        } else {
            updateCheckboxGroupInput(
                session = session,
                inputId = "p1t1_choice",
                selected = ""
            )
        }
    })
}

shinyApp(ui, server)

【问题讨论】：

好的，我很确定任何完全阅读过question I have already linked to in my question 的人都会知道这一点，但该功能现在是shinyWidgets 包的一部分。使用该函数作为该包的一部分可以解决此问题。我会把它留在这里，以防其他人无法阅读完整的回复。

标签： r shiny

【解决方案1】：

根据我的评论，这可以通过加载 shinyWidgets 包然后添加 circle = FALSE 来完成，如果您希望您的按钮被标记。

library(shiny)
library(shinyWidgets)

ui <- fluidPage(
    navbarPage("This is an App", 
               tabPanel("Start Here - Page 0"), 
               navbarMenu("This is Page 1", 
                          tabPanel("p1 t1", 
                                   uiOutput("p1t1_out"), 
                                   checkboxInput("test", "here")), 
                          tabPanel("p2 t2")), 
               navbarMenu("This is Page 2",
                          tabPanel("p2 t1"), 
                          tabPanel("p2 t2"))))


server <- function(input, output, session) {

    output$p1t1_out <- renderUI({
        dropdownButton(
            circle = FALSE,
            label = "Select Here",
            status = "default",
            width = 300,
            actionButton(inputId = "p1t1_all", label = "(Un)select All"),
            checkboxGroupInput(
                inputId = "p1t1_choice",
                label = "select vars",
                choices = as.list(names(mtcars)),
                selected = as.list(names(mtcars))
            )
        )
    })
    # Select all / Unselect all 
    observeEvent(input$p1t1_all, {
        if (is.null(input$p1t1_choice)) {
            updateCheckboxGroupInput(
                session = session,
                inputId = "p1t1_choice",
                selected = as.list(names(mtcars))
            )
        } else {
            updateCheckboxGroupInput(
                session = session,
                inputId = "p1t1_choice",
                selected = ""
            )
        }
    })
}

shinyApp(ui, server)

【讨论】：