You need to enable JavaScript to run this app.
优惠活动
大模型
产品
解决方案
定价
更多

如何在R的HH包中为Likert图正确设置分段百分比标签？

avatar
AI 小北
2026-6-18
问题描述

我用R的HH包可视化Likert数据，想在条形图的每个分段上添加百分比标签，但目前每个完整条形仅显示一个标签，且位置不在对应分段内。如何修改自定义的myPanel函数，让每个条形的4或5个分段都显示对应标签，且标签位于分段中心？

当前效果：每个条形仅显示一个百分比标签，位置偏离对应分段
期望效果：每个条形的所有非零分段都显示对应百分比标签，标签精准落在分段中心

当前代码 

library(HH)

myPanel <- function(x, y, subscripts, ...) {
    panel.likert(x, y, subscripts = subscripts, ...)
    cum_vals <- tapply(x[subscripts], INDEX = y[subscripts], FUN = cumsum)
    for (i in seq_along(cum_vals)) {
        panel.text(x = cum_vals[[i]] - x[subscripts][i] / 2,
                   y = as.numeric(y[subscripts][i]),
                   labels = paste0(round(x[subscripts][i], 1), "%"),
                   cex = 1, pos = 5)
    }
}

likert(type ~ . | Item, data = first_questions_data, layout = c(1, 10),
       scales = list(y = list(relation = "free")), between = list(y = .5),
       strip.left = FALSE, strip = strip.custom(bg = "gray97"),
       par.strip.text = list(cex = 1.1, lines = 1.2), ylab = NULL, cex = 1.2,
       ReferenceZero = 3, as.percent = TRUE, positive.order = TRUE,
       main = "As a result of the Dobbs decision I spend more time...",
       xlim = c(-100, -80, -60, -40, -20, 0, 20, 40, 60, 80, 100), 
       resize.height.tuning = 1, 
       rightAxis = FALSE, 
       col = c("#d8b365", "#ebd9b2", "#e5e5e5", "#acd9d5", "#5ab4ac"),
       panel = myPanel)

数据 

first_questions_data <- structure(list(Item = c("educating myself on abortion legislation.", 
"educating myself on abortion legislation.", "educating other providers on abortion legislation.", 
"educating other providers on abortion legislation.", "discussing abortion legislation with my patients.", 
"discussing abortion legislation with my patients.", "worrying about my patients.", 
"worrying about my patients.", "coordinating abortion care for my patients.", 
"coordinating abortion care for my patients.", "I have felt torn between providing information about abortion and complying with legislation.", 
"I have felt torn between providing information about abortion and complying with legislation.", 
"I have felt an increase in time pressure due to gestational age limitations.", 
"I have felt an increase in time pressure due to gestational age limitations.", 
"My patients have been negatively impacted.", "My patients have been negatively impacted.", 
"My job-related stress has increased.", "My job-related stress has increased.", 
"My job satisfaction has decreased.", "My job satisfaction has decreased."
), type = structure(c(1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 
1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L), levels = c("GCs in protective states", 
"GCs in restrictive states"), class = "factor"), `Strongly Disagree` = c(0, 
0, 0, 1.9, 7.1, 1.9, 35.7, 1.9, 71.4, 17.3, 71.4, 44.2, 42.9, 
9.6, 35.7, 1.9, 35.7, 9.6, 35.7, 17.3), `Somewhat Disagree` = c(28.6, 
1.9, 42.9, 15.4, 28.6, 1.9, 7.1, 7.7, 21.4, 13.5, 14.3, 15.4, 
14.3, 19.2, 7.1, 5.8, 28.6, 3.8, 28.6, 9.6), `Neither Agree nor Disagree` = c(0, 
15.4, 21.4, 11.5, 14.3, 9.6, 28.6, 3.8, 7.1, 19.2, 14.3, 17.3, 
14.3, 13.5, 21.4, 3.8, 21.4, 19.2, 28.6, 32.7), `Somewhat Agree` = c(57.1, 
25, 35.7, 30.8, 42.9, 28.8, 28.6, 26.9, 0, 9.6, 0, 9.6, 28.6, 
23.1, 21.4, 13.5, 14.3, 38.5, 7.1, 36.5), `Strongly Agree` = c(14.3, 
57.7, 0, 40.4, 7.1, 57.7, 0, 59.6, 0, 40.4, 0, 13.5, 0, 34.6, 
14.3, 75, 0, 28.8, 0, 3.8)), row.names = c(NA, -20L), class = c("tbl_df", 
"tbl", "data.frame"))
解决方案

原myPanel函数的问题在于：用tapply按y分组计算累积值时，未正确遍历每个分段的正负值，循环逻辑仅处理了单一组的部分数据，导致标签缺失、位置错误。修改后的函数需实现：

  • 区分正负方向的分段（Likert图以ReferenceZero为界，左侧为负向选项，右侧为正向）
  • 计算每个分段的中心位置作为标签坐标
  • 过滤百分比为0的标签（避免无效显示）
  • 根据分段位置调整标签对齐方式（左侧分段标签靠右，右侧靠左）

修改后的myPanel函数 

myPanel <- function(x, y, subscripts, ...) {
    # 先绘制Likert条形
    panel.likert(x, y, subscripts = subscripts, ...)
    
    # 获取当前面板的x和y值
    x_vals <- x[subscripts]
    y_vals <- y[subscripts]
    
    # 按y分组处理每个条形的分段
    y_groups <- unique(y_vals)
    for (y_val in y_groups) {
        # 提取当前y对应的所有x值（即该条形的所有分段）
        group_x <- x_vals[y_vals == y_val]
        # 过滤掉0值的分段
        non_zero_idx <- group_x != 0
        group_x <- group_x[non_zero_idx]
        
        if (length(group_x) == 0) next
        
        # 计算累积位置：负向分段从左到右累加，正向分段从右到左累加
        cum_pos <- ifelse(group_x < 0, 
                          cumsum(group_x) - group_x/2,  # 负向分段的中心位置
                          -cumsum(-group_x) + group_x/2) # 正向分段的中心位置
        
        # 生成标签
        labels <- paste0(round(abs(group_x), 1), "%")
        # 确定标签对齐：负向分段右对齐，正向分段左对齐
        pos_vec <- ifelse(group_x < 0, 4, 2)
        
        # 绘制标签
        panel.text(x = cum_pos,
                   y = as.numeric(y_val),
                   labels = labels,
                   cex = 1,
                   pos = pos_vec)
    }
}
完整运行代码

将修改后的myPanel函数替换原代码，运行以下脚本即可得到期望效果：

library(HH)

# 加载数据
first_questions_data <- structure(list(Item = c("educating myself on abortion legislation.", 
"educating myself on abortion legislation.", "educating other providers on abortion legislation.", 
"educating other providers on abortion legislation.", "discussing abortion legislation with my patients.", 
"discussing abortion legislation with my patients.", "worrying about my patients.", 
"worrying about my patients.", "coordinating abortion care for my patients.", 
"coordinating abortion care for my patients.", "I have felt torn between providing information about abortion and complying with legislation.", 
"I have felt torn between providing information about abortion and complying with legislation.", 
"I have felt an increase in time pressure due to gestational age limitations.", 
"I have felt an increase in time pressure due to gestational age limitations.", 
"My patients have been negatively impacted.", "My patients have been negatively impacted.", 
"My job-related stress has increased.", "My job-related stress has increased.", 
"My job satisfaction has decreased.", "My job satisfaction has decreased."
), type = structure(c(1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 
1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L), levels = c("GCs in protective states", 
"GCs in restrictive states"), class = "factor"), `Strongly Disagree` = c(0, 
0, 0, 1.9, 7.1, 1.9, 35.7, 1.9, 71.4, 17.3, 71.4, 44.2, 42.9, 
9.6, 35.7, 1.9, 35.7, 9.6, 35.7, 17.3), `Somewhat Disagree` = c(28.6, 
1.9, 42.9, 15.4, 28.6, 1.9, 7.1, 7.7, 21.4, 13.5, 14.3, 15.4, 
14.3, 19.2, 7.1, 5.8, 28.6, 3.8, 28.6, 9.6), `Neither Agree nor Disagree` = c(0, 
15.4, 21.4, 11.5, 14.3, 9.6, 28.6, 3.8, 7.1, 19.2, 14.3, 17.3, 
14.3, 13.5, 21.4, 3.8, 21.4, 19.2, 28.6, 32.7), `Somewhat Agree` = c(57.1, 
25, 35.7, 30.8, 42.9, 28.8, 28.6, 26.9, 0, 9.6, 0, 9.6, 28.6, 
23.1, 21.4, 13.5, 14.3, 38.5, 7.1, 36.5), `Strongly Agree` = c(14.3, 
57.7, 0, 40.4, 7.1, 57.7, 0, 59.6, 0, 40.4, 0, 13.5, 0, 34.6, 
14.3, 75, 0, 28.8, 0, 3.8)), row.names = c(NA, -20L), class = c("tbl_df", 
"tbl", "data.frame"))

# 修改后的自定义面板函数
myPanel <- function(x, y, subscripts, ...) {
    panel.likert(x, y, subscripts = subscripts, ...)
    
    x_vals <- x[subscripts]
    y_vals <- y[subscripts]
    
    y_groups <- unique(y_vals)
    for (y_val in y_groups) {
        group_x <- x_vals[y_vals == y_val]
        non_zero_idx <- group_x != 0
        group_x <- group_x[non_zero_idx]
        
        if (length(group_x) == 0) next
        
        cum_pos <- ifelse(group_x < 0, 
                          cumsum(group_x) - group_x/2,
                          -cumsum(-group_x) + group_x/2)
        
        labels <- paste0(round(abs(group_x), 1), "%")
        pos_vec <- ifelse(group_x < 0, 4, 2)
        
        panel.text(x = cum_pos,
                   y = as.numeric(y_val),
                   labels = labels,
                   cex = 1,
                   pos = pos_vec)
    }
}

# 绘制Likert图
likert(type ~ . | Item, data = first_questions_data, layout = c(1, 10),
       scales = list(y = list(relation = "free")), between = list(y = .5),
       strip.left = FALSE, strip = strip.custom(bg = "gray97"),
       par.strip.text = list(cex = 1.1, lines = 1.2), ylab = NULL, cex = 1.2,
       ReferenceZero = 3, as.percent = TRUE, positive.order = TRUE,
       main = "多布斯裁决后，我在以下方面花费更多时间...",
       xlim = c(-100, -80, -60, -40, -20, 0, 20, 40, 60, 80, 100), 
       resize.height.tuning = 1, 
       rightAxis = FALSE, 
       col = c("#d8b365", "#ebd9b2", "#e5e5e5", "#acd9d5", "#5ab4ac"),
       panel = myPanel)

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

相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级，最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分)， 限时 9.9 元起

产品介绍相关文档
相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级，最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分)， 限时 9.9 元起

产品介绍相关文档
火山引擎 最新活动
全面开放
Doubao-Seedance-2.5全新模型升级

模型再升级,30秒超长叙事, 模态参考扩容

HOT
方舟Codingplan

模型自由，工具不限，最新支持 Deepseek-V4 系列、GLM-5.3 系列

HOT
方舟Agent plan

超全模态模型 × Harness 升级，最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列

HOT
新用户特惠专场

大模型19元起，Al应用9.9元畅享，新人首购爆款尽享优惠

最近更新时间：2026.06.18 18:32:02