如何在R Markdown中创建过滤器实现交互式Dashboard及钻取功能

问题分析 #

原代码存在以下关键问题导致交互失效：

• 所有下拉选择框使用相同id="my_dropdown"，输入冲突导致Shiny无法识别不同筛选条件
• 响应式数据filtered_dat仅处理Program筛选，未关联College和Department输入
• 图表直接调用原始数据集dat，未使用实时过滤的响应式数据
• 第一个Program选择框参数错误：用choice替代了正确的choices

修正后的完整代码 #

---
title: "Accreditation Dashboard"
output: 
  flexdashboard::flex_dashboard:
    orientation: rows
    vertical_layout: fill
    
---

```{r setup, include=FALSE}
library(flexdashboard)
library(knitr)
library(DT)
library(rpivotTable)
library(ggplot2)
library(plotly)
library(dplyr)
library(openintro)
library(highcharter)
library(shiny)
library(shinydashboard)

# 读取数据（路径请根据实际情况调整）
dat <- read.csv("C://Users//Head-SoftwareUn//Desktop//Yinka//accreditation.csv")
# 清理列名空格（原数据DEPT列名带空格，统一处理）
colnames(dat) <- trimws(colnames(dat))

# 响应式过滤数据：处理三个筛选条件
filtered_dat <- reactive({
  temp_dat <- dat
  
  # 过滤Program：选择非默认项时生效
  if(input$program_select != "-Select Program-"){
    temp_dat <- temp_dat %>% filter(PROGRAMME == input$program_select)
  }
  
  # 过滤College：选择非默认项时生效
  if(input$college_select != "-Select College-"){
    temp_dat <- temp_dat %>% filter(COL == input$college_select)
  }
  
  # 过滤Department：选择非默认项时生效
  if(input$dept_select != "-Select Department-"){
    temp_dat <- temp_dat %>% filter(DEPT == input$dept_select)
  }
  
  return(temp_dat)
})

mycolors <- c("blue","yellow","darkgreen","darkorange")    

column {.sidebar data-width=200} #

# 三个下拉框使用唯一ID，避免冲突
selectInput("program_select", "PROGRAM:", 
            choices = c("-Select Program-", unique(dat$PROGRAMME)))
selectInput("college_select", "COLLEGE:", 
            choices = c("-Select College-", unique(dat$COL)))
selectInput("dept_select", "DEPARTMENT:", 
            choices = c("-Select Department-", unique(dat$DEPT)))    

统计概览 #

# 动态更新数值框，显示筛选后项目总数
renderValueBox({
  valueBox(nrow(filtered_dat()), subtitle = "筛选后项目总数")
})    

Column {data-width=450} #

认证状态分布（饼图） #

renderPlotly({
  table_dat <- table(filtered_dat()$ACCREDITATION.STATUS)
  plot_ly(labels = names(table_dat), values = table_dat, type = "pie", hole=0.4,
          textinfo = "label+percent", insidetextorientation = "radial") %>%
    layout(title = "认证状态占比")
})    

NUC下次访问统计 #

renderPlotly({
  # 假设数据包含NUC_NEXT_VISIT列，可根据实际情况调整
  if("NUC_NEXT_VISIT" %in% colnames(filtered_dat())){
    visit_dat <- table(filtered_dat()$NUC_NEXT_VISIT)
    plot_ly(x = names(visit_dat), y = visit_dat, type = "bar", color = names(visit_dat)) %>%
      layout(title = "NUC下次访问年份分布", xaxis = list(title = "访问年份"), yaxis = list(title = "数量"))
  } else {
    plot_ly() %>% layout(title = "数据中无NUC下次访问列")
  }
})

Row {data-width=500} #

认证年限与状态分布（分组柱状图） #

renderPlotly({
  grouped_dat <- filtered_dat() %>%
    group_by(ACCREDITATION.YEARS, ACCREDITATION.STATUS) %>%
    summarize(count = n(), .groups = "drop")
  
  plot_ly(grouped_dat, x = ~ACCREDITATION.YEARS, y = ~count, color = ~ACCREDITATION.STATUS, type = "bar") %>%
    layout(barmode = "group", xaxis= list(title="认证年限"), yaxis= list(title= "数量"),
           title = "各认证年限下的状态分布")
})    

Row {data-width=500} #

认证年限占比趋势（折线图） #

renderPlotly({
  dat1 <- filtered_dat() %>%
    group_by(ACCREDITATION.YEARS, ACCREDITATION.STATUS) %>%
    summarize(Percent = n() / nrow(filtered_dat()), .groups = "drop")
  
  plot_ly(dat1, x = ~ACCREDITATION.YEARS, y = ~Percent, color = ~ACCREDITATION.STATUS,
          type = "scatter", mode = "lines+markers") %>%
    layout(title = "认证年限占比趋势", xaxis = list(title = "认证年限"), yaxis = list(title = "占比"))
})

钻取功能实现（Highcharts示例） #

在仪表盘新增层级钻取图表，支持Program→College→Department→认证状态的点击钻取：

# 可添加到Program页面或新增页面
### 层级钻取图表
renderHighchart({
  # 第一层：Program级别数据
  level1 <- dat %>%
    group_by(PROGRAMME) %>%
    summarize(count = n(), .groups = "drop") %>%
    mutate(name = PROGRAMME, y = count, drilldown = PROGRAMME)
  
  # 第二层：College级别数据（按Program分组）
  level2_list <- lapply(unique(dat$PROGRAMME), function(p) {
    sub_dat <- dat %>% filter(PROGRAMME == p) %>%
      group_by(COL) %>%
      summarize(count = n(), .groups = "drop") %>%
      mutate(name = COL, y = count, drilldown = paste0(p, "_", COL))
    list(id = p, data = sub_dat %>% select(name, y, drilldown))
  })
  
  # 第三层：Department级别数据（按Program+College分组）
  level3_list <- lapply(unique(dat$PROGRAMME), function(p) {
    lapply(unique(dat$COL[dat$PROGRAMME == p]), function(c) {
      sub_dat <- dat %>% filter(PROGRAMME == p, COL == c) %>%
        group_by(DEPT) %>%
        summarize(count = n(), .groups = "drop") %>%
        mutate(name = DEPT, y = count, drilldown = paste0(p, "_", c, "_", DEPT))
      list(id = paste0(p, "_", c), data = sub_dat %>% select(name, y, drilldown))
    })
  }) %>% unlist(recursive = FALSE)
  
  # 第四层：认证状态数据（按Program+College+Department分组）
  level4_list <- lapply(unique(dat$PROGRAMME), function(p) {
    lapply(unique(dat$COL[dat$PROGRAMME == p]), function(c) {
      lapply(unique(dat$DEPT[dat$PROGRAMME == p & dat$COL == c]), function(d) {
        sub_dat <- dat %>% filter(PROGRAMME == p, COL == c, DEPT == d) %>%
          group_by(ACCREDITATION.STATUS) %>%
          summarize(count = n(), .groups = "drop") %>%
          mutate(name = ACCREDITATION.STATUS, y = count)
        list(id = paste0(p, "_", c, "_", d), data = sub_dat %>% select(name, y))
      })
    })
  }) %>% unlist(recursive = FALSE)
  
  # 组合所有钻取层级数据
  drilldown_data <- c(level2_list, level3_list, level4_list)
  
  # 生成Highcharts钻取图表
  highchart() %>%
    hc_chart(type = "column") %>%
    hc_title(text = "项目-学院-系部-认证状态层级钻取") %>%
    hc_xAxis(type = "category") %>%
    hc_legend(enabled = FALSE) %>%
    hc_plotOptions(series = list(borderWidth = 0, dataLabels = list(enabled = TRUE))) %>%
    hc_series(list(
      name = "数量",
      colorByPoint = TRUE,
      data = level1 %>% select(name, y, drilldown)
    )) %>%
    hc_drilldown(
      allowPointDrilldown = TRUE,
      series = drilldown_data
    )
})

## 关键修改说明
1. **唯一输入ID**：三个下拉框分别使用`program_select`、`college_select`、`dept_select`，避免输入冲突
2. **响应式数据逻辑**：完善`filtered_dat`，根据每个下拉框的选择（排除默认项）逐步过滤数据
3. **动态渲染**：所有图表用`renderPlotly`/`renderHighchart`包裹，调用`filtered_dat()`获取实时过滤数据
4. **钻取功能**：基于Highcharts的钻取API，构建四层数据层级，实现点击钻取到下一级明细

内容的提问来源于stack exchange，提问作者adeagbo62