R闪亮的仪表板主体依赖于闪亮的子项选择

Question

这是一种创建闪亮的observeEvent依赖于闪亮的子项选择的方法吗？

在下面的可再现示例中，我想在单击子菜单1时自动执行按钮1，并在单击子菜单2时自动执行按钮3。

library(shinydashboard)
library(shiny)


ui <- dashboardPage(
 dashboardHeader(title = "Dynamic sidebar"),
 dashboardSidebar(
   sidebarMenuOutput("menu")
 ),
dashboardBody(heigth = 800,  tabItems(
                                     tabItem(tabName = "submenu_1",
                                             fluidRow(
                                               actionButton(inputId = "button_1",label = "Button 1",  icon = icon("fa"),width = '417px'),
                                               actionButton(inputId = "button_2",label = "Button 2",  icon = icon("fa"),width = '417px')
                                             )
                                     ),
                                       tabItem(tabName = "submenu_2",
                                               fluidRow(
                                                 actionButton(inputId = "button_3",label = "Button 3",  icon = icon("fa"),width = '417px'),
                                                 actionButton(inputId = "button_4",label = "Button 4",  icon = icon("fa"),width = '417px')
                                               )
                                       )

                        ),
            textOutput("text")
            )
)


server <- function(input, output) {
output$menu <- renderMenu({
sidebarMenu(
  menuItem("Menu item 1", 
           menuSubItem('Submenu 1',tabName = 'submenu_1',icon = icon('line-chart')),
           menuSubItem('Submenu 2',tabName = 'submenu_2',icon = icon('line-chart'))
           )
)
})


 observeEvent(input$button_1,{output$text <- renderText("Buutton 1 must be selected by default on Submenu 1")})
 observeEvent(input$button_2,{output$text <- renderText("You have selected button 2")})
 observeEvent(input$button_3,{output$text <- renderText("Buutton 3 must be selected by default on Submenu 2 ")})
 observeEvent(input$button_4,{output$text <- renderText("You have selected button 4")})
}

shinyApp(ui, server)

提前致谢！

Answer 1

那是你需要的吗？

你可以在id中添加一个sidebarMenu参数，然后添加一个由observeEvent触发的input$sidebarmenu对象

library(shinydashboard)
library(shiny)


ui <- dashboardPage(
  dashboardHeader(title = "Dynamic sidebar"),
  dashboardSidebar(
    sidebarMenuOutput("menu")
  ),
  dashboardBody(heigth = 800,  tabItems(
    tabItem(tabName = "submenu_1",
            fluidRow(
              actionButton(inputId = "button_1",label = "Button 1",  icon = icon("fa"),width = '417px'),
              actionButton(inputId = "button_2",label = "Button 2",  icon = icon("fa"),width = '417px')
            )
    ),
    tabItem(tabName = "submenu_2",
            fluidRow(
              actionButton(inputId = "button_3",label = "Button 3",  icon = icon("fa"),width = '417px'),
              actionButton(inputId = "button_4",label = "Button 4",  icon = icon("fa"),width = '417px')
            )
    )

  ),
  textOutput("text")
  )
)


server <- function(input, output) {
  output$menu <- renderMenu({
    sidebarMenu(id = "sidebarmenu",
      menuItem("Menu item 1", 
               menuSubItem('Submenu 1',tabName = 'submenu_1',icon = icon('line-chart')),
               menuSubItem('Submenu 2',tabName = 'submenu_2',icon = icon('line-chart'))
      )
    )
  })

  observeEvent(input$sidebarmenu,{
    output$text <- renderText({
      if(input$sidebarmenu=="submenu_1"){
        "Buutton 1 must be selected by default on Submenu 1"
      }else if(input$sidebarmenu=="submenu_2"){
        "Buutton 3 must be selected by default on Submenu 2 "
      }
    })
  })

  observeEvent(input$button_1,{
    output$text <- renderText("Buutton 1 must be selected by default on Submenu 1")
  })
  observeEvent(input$button_2,{
    output$text <- renderText("You have selected button 2")
  })
  observeEvent(input$button_3,{
    output$text <- renderText("Buutton 3 must be selected by default on Submenu 2 ")
  })
  observeEvent(input$button_4,{
    output$text <- renderText("You have selected button 4")
  })

}

shinyApp(ui, server)

Answer 2

诀窍是在UI部分设置参数id。

下面的代码完成了这项工作：

library(shinydashboard)
library(shiny)


ui <- dashboardPage(
    dashboardHeader(title = "Dynamic sidebar"),
    dashboardSidebar(
        sidebarMenu(id="tabs",
            sidebarMenuOutput("menu")
        )
    ),
    dashboardBody(heigth = 800,  tabItems(
        tabItem(tabName = "submenu_1",
                fluidRow(
                    actionButton(inputId = "button_1",label = "Button 1",  icon = icon("fa"),width = '417px'),
                    actionButton(inputId = "button_2",label = "Button 2",  icon = icon("fa"),width = '417px')
                )
        ),
        tabItem(tabName = "submenu_2",
                fluidRow(
                    actionButton(inputId = "button_3",label = "Button 3",  icon = icon("fa"),width = '417px'),
                    actionButton(inputId = "button_4",label = "Button 4",  icon = icon("fa"),width = '417px')
                )
        )

    ),
    textOutput("text")
    )
)


server <- function(input, output) {
    output$menu <- renderMenu({
        sidebarMenu(
            menuItem("Menu item 1", 
                     menuSubItem('Submenu 1',tabName = 'submenu_1',icon = icon('line-chart')),
                     menuSubItem('Submenu 2',tabName = 'submenu_2',icon = icon('line-chart'))
            )
        )
    })

    observeEvent(input$tabs, {
        req(input$tabs)
        if (input$tabs == "submenu_1") {
            # Do whatever you want when submenu_1 is selected
            print("submenu_1 selected")
        } else if (input$tabs == "submenu_2") {
            # Do whatever you want when submenu_2 is selected 
            print("submenu_2 selected")
        }
    })
    observeEvent(input$button_1,{output$text <- renderText("Buutton 1 must be selected by default on Submenu 1")})
    observeEvent(input$button_2,{output$text <- renderText("You have selected button 2")})
    observeEvent(input$button_3,{output$text <- renderText("Buutton 3 must be selected by default on Submenu 2 ")})
    observeEvent(input$button_4,{output$text <- renderText("You have selected button 4")})
}

shinyApp(ui, server)