Параметр фильтрации на боковой панели

Question

В приведенном ниже примере кода (ui.R) мы можем добавить опцию фильтрации на самой боковой панели. Например, если вы щелкнете «Панель инструментов» на боковой панели, параметр фильтрации должен быть ниже, чем

Ui.R

library(shinydashboard)


ui = sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets",
             badgeLabel = "new", badgeColor = "green")
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "dashboard",
            h2("Dashboard tab content")
    ),

    tabItem(tabName = "widgets",
            h2("Widgets tab content")
    )
  )
)

# Put them together into a dashboardPage
dashboardPage(
  dashboardHeader(title = "Simple tabs"),
  sidebar,
  body
)

Answer 1

Есть так много вещей, которые вы можете сделать. Посмотрите два примера сценариев ниже, чтобы получить некоторые идеи относительно того, что возможно с фильтрами в Блестящем мире.

Фильтр со списком:

library(shiny)
library(dplyr)

data(tips, package = "reshape2")
filter_vars <- c("sex", "smoker", "day", "time")

ui <- fluidPage(
  lapply(filter_vars, function(var) {
    selectInput(var, var, unique(tips[[var]]), multiple = TRUE)
  }),
  tableOutput("table")
)

server <- function(input, output, session) {
  my_filter <- function(data, var) {
    if (length(input[[var]]) == 0) return(data)
    data %>% subset(data[[var]] %in% input[[var]])
  }  

  subsettedData <- reactive({
    tips %>% my_filter("sex") %>% my_filter("smoker") %>% 
      my_filter("day") %>% my_filter("time")
  })

  observeEvent(subsettedData(), {
    lapply(filter_vars, function(var) {
      selections <- unique(subsettedData()[[var]])
      if (length(input[[var]]) == 0)
        updateSelectInput(session, var, choices = selections)
    })
  })   

  output$table <- renderTable({ subsettedData() })
}

shinyApp(ui, server)

Фильтр при вводе:

library(shinydashboard)
library(DT)

df <- mtcars

header <- dashboardHeader(
  title = "Test"
)

sidebar <- dashboardSidebar(
)

body <- dashboardBody(
  box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)

# UI
ui <- dashboardPage(header, sidebar, body)

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

  output$df = DT::renderDataTable(df, rownames = FALSE,
                                  options = list(
                                    autoWidth = TRUE,
                                    columnDefs = list(list(width = '10px', targets = c(1,3)))))
}

# Shiny dashboard
shiny::shinyApp(ui, server)