光沢のあるドロップダウンボタンエラー

Question

私は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) 

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