代码之家 › 专栏 › 技术社区 › rk sha

闪亮的仪表板-带有菜单项的侧栏菜单

shinydashboard shiny r

rk sha · 技术社区 · 7 年前

mtcars 数据集和代码如下所示

data(mtcars)
ibrary(shiny)
library(shinydashboard)
library(dplyr)

 ui <- dashboardPage(
    dashboardHeader(title = "Dynamic sidebar"),
    dashboardSidebar(
      sidebarMenu(
        menuItem("Plots Menu", tabName = "plot_page", icon = icon("line-chart")),

        menuItem("Table Menu", tabName="intro_page", icon = icon("info"),
                 selectInput(inputId = "mcm", label = "Some label",
                             multiple = TRUE, choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)))

      ),
      sidebarMenuOutput("menu")
    ),
    dashboardBody(tabItems(
      tabItem(tabName = "plots", h2("Dashboard plots"),
              fluidRow(column(width = 12, class = "well",
                              h4("Boxplot"),
                              plotOutput("bxp")))
      ),
      tabItem(tabName = "dashboard", h2("Dashboard tab content"),
              dataTableOutput(outputId = "subdt"))
    )
    )
  )



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

    output$menu <- renderMenu({
      sidebarMenu(
        menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),

        menuItem("Table Menu", tabName="dashboard", icon = icon("calendar"))
      )
    })

    datsub <- reactive({
      mtcars %>%
          filter_at(vars("cyl"), all_vars(. %in% input$mcm))


    })

    output$subdt <- renderDataTable({
      datsub()
    })

    output$bxp <- renderPlot({

      hist(rnorm(100))


    }) 

  }

  shinyApp(ui, server)

2 回复 | 直到 7 年前

Ian Frantz 6 年前

我把代码放在一起。 -伊恩

data(mtcars)
library(shiny)
library(shinydashboard)
library(dplyr)

ui <- dashboardPage(
  dashboardHeader(title = "Dynamic sidebar"),
  dashboardSidebar(sidebarMenu(id = "menu", sidebarMenuOutput("menu"))),
  dashboardBody(tabItems
    (
    tabItem
      (tabName = "plots", h2("Dashboard plots"),
    fluidRow(column(width = 12, class = "well",
    h4("Boxplot"),
    plotOutput("bxp")))
    ),
    tabItem(tabName = "dashboard", h2("Dashboard tab content"),
    dataTableOutput(outputId = "subdt"))
  )
  )
)



server <- function(input, output, session) {
  output$menu <- renderMenu({
    sidebarMenu(
      menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
      menuItem("Table Menu", icon = icon("info"),
               menuSubItem(
                 "Dashboard", tabName = "dashboard", icon = icon("calendar")
               ),
               selectInput(
                 inputId = "mcm", label = "Some label", multiple = TRUE,
                 choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)
               )
      )
    )
  })

  datsub <- reactive({
    mtcars %>%
      filter_at(vars("cyl"), all_vars(. %in% input$mcm))
  })

  output$subdt <- renderDataTable({
    datsub()
  })

  output$bxp <- renderPlot({
    hist(rnorm(100))
  }) 

}

shinyApp(ui, server)

Kevin Arseneau 7 年前

您可以同时运行标准侧栏和反应侧栏选项。如果你需要一个反应式的边栏,只需把内容放在 server 函数并用 sidebarMenuOutput 在里面 ui .

`ui.R`

dashboardSidebar(sidebarMenu(id = "menu", sidebarMenuOutput("menu")))

`server.R`

output$menu <- renderMenu({
    sidebarMenu(
      menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
      menuItem("Table Menu", icon = icon("info"),
               menuSubItem(
                 "Dashboard", tabName = "dashboard", icon = icon("calendar")
               ),
               selectInput(
                 inputId = "mcm", label = "Some label", multiple = TRUE,
                 choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)
               )
      )
    )
  })