如何使用RShiny实现问卷自动计分及总分可视化

以下是可直接运行的调整后代码，已修复原代码的语法错误，完成计分逻辑开发，并新增了总分可视化效果，支持直观展示当前得分对应的焦虑严重程度。

rm(list = ls())
library(shiny)
library(tidyverse)
library(DT)

# 量表题目对应字段
fieldsAll <- c("nervous", "stop.worry", "worry", "relax", "restless", "annoyed", "afraid")
# 选项直接绑定分值，无需后续重编码
resp.options <- c('完全没有' = 0, '好几天' = 1, '超过一半天数' = 2, '几乎每天' = 3)
# GAD-7严重程度对照规则
gad_levels <- data.frame(
  level = c("无焦虑", "轻度焦虑", "中度焦虑", "重度焦虑"),
  min = c(0, 5, 10, 15),
  max = c(4, 9, 14, 21),
  color = c("#2ecc71", "#f1c40f", "#e67e22", "#e74c3c")
)

shinyApp(
  ui = fluidPage(
    titlePanel("广泛性焦虑障碍7项量表（GAD-7）"),
    fluidRow(
      column(6,
             selectInput("nervous", "过去两周内，你有多少时间受到以下问题困扰：感到紧张、焦虑？", 
                         resp.options),
             selectInput("stop.worry", "过去两周内，你有多少时间受到以下问题困扰：无法停止或控制担忧？", 
                         resp.options),
             selectInput("worry", "过去两周内，你有多少时间受到以下问题困扰：对各种事情过分担心？", 
                         resp.options),
             selectInput("relax", "过去两周内，你有多少时间受到以下问题困扰：无法放松？", 
                         resp.options)),
      column(6,
             selectInput("restless", "过去两周内，你有多少时间受到以下问题困扰：坐立不安，难以安静？", 
                         resp.options),
             selectInput("annoyed", "过去两周内，你有多少时间受到以下问题困扰：容易烦躁或易怒？", 
                         resp.options),
             selectInput("afraid", "过去两周内，你有多少时间受到以下问题困扰：感觉好像会发生不好的事情？", 
                         resp.options),
             plotOutput("score_plot", height = 300)
      ),
    ),
    fluidRow(
      actionButton("submit", "提交作答")
    ),
    fluidRow(
      DT::dataTableOutput("responses", width = "100%"), 
      tags$hr(),
    ),
    fluidRow(
      h3(textOutput("score_text"))
    )
  ),
  server = function(input, output, session) {
    # 存储历史作答数据
    responses <- reactiveVal(data.frame())
    # 存储当前用户得分
    current_score <- reactiveVal()
    
    # 提交后更新数据与得分
    observeEvent(input$submit, {
      # 收集当前作答
      new_data <- data.frame(t(sapply(fieldsAll, function(x) input[[x]])))
      colnames(new_data) <- c("感到紧张焦虑", "无法控制担忧", "过度担心各类事情", "无法放松", "坐立不安", "容易易怒", "害怕坏事发生")
      # 累计历史作答
      responses(rbind(responses(), new_data))
      # 计算当前总分
      current_score(sum(as.numeric(new_data[1,])))
    })
    
    # 展示作答记录
    output$responses <- DT::renderDataTable({
      req(responses())
      responses()
    },
    options=list(dom = 't', ordering = FALSE)
    )
    
    # 展示得分文字
    output$score_text <- renderText({
      req(current_score())
      # 匹配严重程度
      level <- gad_levels[gad_levels$min <= current_score() & gad_levels$max >= current_score(), "level"]
      paste0("你的总得分为：", current_score(), "，属于", level, "范围")
    })
    
    # 得分可视化
    output$score_plot <- renderPlot({
      req(current_score())
      ggplot(gad_levels) +
        geom_rect(aes(xmin = min, xmax = max + 1, ymin = 0, ymax = 1, fill = level), alpha = 0.7) +
        geom_vline(xintercept = current_score(), color = "red", linewidth = 2) +
        geom_text(aes(x = (min + max)/2, y = 0.5, label = paste0(level, "\n", min, "-", max, "分")), size = 4) +
        scale_fill_manual(values = gad_levels$color) +
        scale_x_continuous(breaks = 0:21, limits = c(0, 22)) +
        labs(x = "GAD-7总分", y = "") +
        theme_minimal() +
        theme(
          axis.text.y = element_blank(),
          axis.ticks.y = element_blank(),
          panel.grid = element_blank(),
          legend.position = "none"
        )
    })
  }
)

• 修复了原代码中函数括号不配对、DT包未声明、多次提交数据会被覆盖的问题
• 优化了计分逻辑：选项直接绑定分值，不需要额外重编码转换，计算效率更高
• 新增可视化效果：用不同颜色标识4个焦虑程度区间，用红色竖线标注当前得分位置，直观清晰
• 全部界面文本已翻译为中文，符合中文用户使用习惯，如需保留英文界面可直接替换对应文本即可

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