如何在R中为排序测验实现含部分学分的评分

问题背景 #

手里有一份包含23道排序题的数据集，受访者需将指定步骤按正确顺序排列，数据从Qualtrics导出，格式如下：

ResponseID  | Step1| Step2 |Step3|.....|Step22|Step23
p1          | 1    | 2     | 3   |.....|22     |23 
p2          | 2    | 3     | 4   |.....|23     |1 
p3          | 2    | 23    | 7   |.....|12     |17 

正确顺序为1至23依次排列，即第N个位置（StepN）的正确值为N。原本采用逐位置判断的R代码评分，只有完全匹配才得1分，否则0分：

dissdata <- dissdata %>%
  mutate(retention1score = ifelse(dissdata$Q9.2_1 == 1, 1, 0) +
                          ifelse(dissdata$Q9.2_2 == 2, 1, 0) +
                          ifelse(dissdata$Q9.2_3 == 3, 1, 0) +
                          # ... 省略中间20个判断
                          ifelse(dissdata$Q9.2_23 == 23, 1, 0))

这种方式无法区分整体偏移的作答（如示例中的p2）和完全错误的作答（如p3），两者得分均为0，需实现支持部分学分的评分逻辑，对偏移步数少、存在连续正确片段的作答给予对应分数。

实现思路（参考「排序题部分学分程序化评分」逻辑） #

核心思路是通过两种维度量化作答正确性：

1. 相邻关系匹配：统计作答中符合正确相邻顺序（如x紧跟x+1）的片段数量，每段匹配得对应分数
2. 位置偏移距离：对每个元素，计算其作答位置与正确位置的绝对差，按偏移距离阶梯式给分

R代码实现 #

方法1：基于相邻正确关系评分 #

该方法能有效区分整体偏移的作答（如p2的相邻关系完全正确，得分接近满分）和完全混乱的作答：

library(dplyr)
library(purrr)

# 提取所有排序题列（假设列名是Q9.2_1到Q9.2_23）
sort_cols <- paste0("Q9.2_", 1:23)

# 定义函数：计算相邻匹配得分
calculate_adjacent_score <- function(response_vec) {
  # 生成正确的相邻对：(1,2),(2,3)...(22,23)
  correct_pairs <- data.frame(left = 1:22, right = 2:23)
  # 生成受访者作答的相邻对
  response_pairs <- data.frame(left = response_vec[-23], right = response_vec[-1])
  # 统计匹配的相邻对数量
  sum(apply(response_pairs, 1, function(x) x[1] == correct_pairs$left & x[2] == correct_pairs$right))
}

# 计算得分并添加到数据集
dissdata <- dissdata %>%
  mutate(adjacent_score = pmap_int(across(all_of(sort_cols)), ~calculate_adjacent_score(c(...))))

# 将相邻得分转换为0-23的满分区间（最多22个相邻对，按比例换算）
dissdata <- dissdata %>%
  mutate(retention1score = adjacent_score * (23/22))

方法2：基于位置偏移的阶梯式评分 #

该方法对接近正确位置的元素给予部分学分，细化单个元素的作答质量：

# 定义函数：计算偏移距离得分
calculate_offset_score <- function(response_vec) {
  # 遍历每个元素，计算其作答位置与正确位置的偏移
  offset_scores <- map_dbl(1:23, function(x) {
    # 找到元素x在作答中的位置
    answer_pos <- which(response_vec == x)
    # 计算偏移量
    offset <- abs(answer_pos - x)
    # 阶梯式给分
    case_when(
      offset == 0 ~ 1,    # 完全正确
      offset == 1 ~ 0.8,  # 偏移1步
      offset == 2 ~ 0.5,  # 偏移2步
      offset == 3 ~ 0.2,  # 偏移3步
      TRUE ~ 0            # 偏移超过3步不得分
    )
  })
  sum(offset_scores)
}

# 计算偏移得分并添加到数据集
dissdata <- dissdata %>%
  mutate(offset_score = pmap_dbl(across(all_of(sort_cols)), ~calculate_offset_score(c(...))))

方法3：综合两种逻辑的加权评分 #

可根据需求组合两种得分，兼顾整体顺序合理性和单个元素的准确性：

dissdata <- dissdata %>%
  # 自定义权重，比如偏移得分占60%，相邻得分占40%
  mutate(retention1score = 0.6 * offset_score + 0.4 * adjacent_score)

说明 #

• 相邻匹配分适合评估整体顺序的合理性，整体偏移的作答能获得较高分数
• 偏移距离分适合评估单个元素的位置准确性，对接近正确位置的作答给予学分
• 可根据题目要求调整阶梯分数、权重比例，比如偏移1步给0.9分，偏移2步给0.7分等

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