如何让ggridges脊线图高度与数据点数量/频率成正比？

架构老林

2026-6-12

问题描述

我用ggridges包绘制了展示各数据子集密度的脊线图，但希望调整为每条脊线高度与对应子集的数据点数量成正比。了解到旧版本ggridges支持按计数缩放，但当前版本该功能已移除，我无法实现这个需求，特此求助。

示例数据

df_sample <- tibble::tibble(
  avg_body_mass = c(50, 60, 64, 70, 72, 80, 90, 120, 130, 140, 150, 160, 170, 175, 189, 190, 193, 200, 234, 235, 290, 260),
  binSpecies = rep("T.killia", 22),
  Sex = rep(c("Female","Male"), each = 11)
)

# 野生参考值
wild_female_avg <- 70
wild_male_avg   <- 130

原有绘图代码

library(ggplot2)
library(dplyr)
library(ggridges)

plot_body_mass_ridgeline <- function(file_female, file_male,
                                     wild_female_avg, wild_male_avg) {
  
  # 1. 读取Excel文件
  df_f <- read_excel(file_female) %>%
    mutate(Sex = "Female", wild_ref = wild_female_avg)
  df_m <- read_excel(file_male) %>%
    mutate(Sex = "Male", wild_ref = wild_male_avg)
  
  # 2. 合并数据
  df <- bind_rows(df_f, df_m)
  
  # 3. 分类体重偏差
  df <- df %>%
    mutate(ratio = avg_body_mass / wild_ref,
           category = case_when(
             ratio < 0.75                     ~ "Underweight",
             ratio >= 0.75 & ratio <= 1.25    ~ "Healthy BM",
             ratio >  1.25 & ratio <= 1.50    ~ "Overweight",
             ratio >  1.50 & ratio <= 1.75    ~ "Obese",
             ratio >  1.75                    ~ "Morbidly obese"
           ),
           category = factor(category, 
                             levels = c("Underweight",
                                        "Healthy BM",
                                        "Overweight",
                                        "Obese",
                                        "Morbidly obese")))
  
  # 4. 获取物种名称
  species <- unique(df$binSpecies)
  plot_title <- paste(species)
  
  # 5. 统计每组样本量
  counts <- df %>%
    group_by(Sex, category) %>%
    summarise(n = n(), .groups = "drop")
  print(counts)
  
  # 6. 绘制脊线图
  p <- ggplot(df, aes(x = avg_body_mass, y = category, fill = category)) +
    stat_density_ridges(alpha = 0.7, scale = 2, quantile_lines = TRUE, quantiles = 2, rel_min_height = 0.0125, color = "black") +
    geom_point(position = position_jitter(height = 0.1), size = 1.5, alpha = 0.7) +
    facet_grid(Sex ~ ., scales = "free_y", switch = "y") +
    labs(
      title = plot_title,
      x = "Body Mass (Kg)",
      y = ""
    ) +
    scale_fill_manual(values = c(
      "Underweight" = "steelblue",
      "Healthy BM" = "green2",
      "Overweight" = "gold",
      "Obese" = "darkorange",
      "Morbidly obese" = "brown"
    )) +
    theme_minimal(base_size = 14) +
    theme(
      legend.position = "bottom",
      axis.text.x = element_text(face = "bold"),
      strip.placement = "outside",
      strip.text.y.left = element_text(size = 14, face = "bold")
    )
  
  # 7. 添加样本量标注
  dens_peaks <- df %>%
    group_by(Sex, category) %>%
    summarise(xpos = median(avg_body_mass), .groups = "drop") %>%
    left_join(counts, by = c("Sex", "category"))
  
  p <- p + 
    geom_text(data = dens_peaks,
              aes(x = xpos, y = category, label = paste0("N = ", n)),
              inherit.aes = FALSE,
              vjust = 2, hjust = -0.25, size = 4, fontface = "bold")
  
  # 8. 添加野生平均值参考线
  wild_df <- tibble(
    Sex = c("Female", "Male"),
    wild_ref = c(wild_female_avg, wild_male_avg)
  )
  
  p <- p +
    geom_vline(data = wild_df, aes(xintercept = wild_ref),
               linetype = "dashed", color = "black", size = 1)+
    scale_x_continuous(
      breaks = seq(0, 300, by = 20)
    )
  
  print(p)
}

当前图表

当前脊线图

解决方案

ggridges新版移除了直接按计数缩放的功能，但可以通过手动计算密度并按样本量调整高度实现需求。核心逻辑是：先计算每个子集的密度曲线，将密度值乘以样本量（或缩放后的样本量），再用geom_ridgeline绘图。

具体修改步骤

1. 预计算带计数缩放的密度数据

在原有代码中添加以下代码，计算每个Sex+category分组的密度，并按样本量缩放：

# 新增：计算带计数缩放的密度
dens_data <- df %>%
  group_by(Sex, category) %>%
  group_modify(function(.x, .y) {
    n <- nrow(.x)
    # 计算密度，adjust参数可调整曲线平滑度
    dens <- density(.x$avg_body_mass, adjust = 1, na.rm = TRUE)
    # 缩放密度：密度值*样本量，再用scaling_factor控制整体高度比例
    scaling_factor <- max(dens$y * n) * 0.15
    tibble(
      x = dens$x,
      y_scaled = dens$y * n / scaling_factor,
      category = .y$category,
      Sex = .y$Sex
    )
  }) %>%
  ungroup()

2. 替换脊线图层

把原来的stat_density_ridges替换为geom_ridgeline，使用预计算的y_scaled控制脊线高度：

# 修改绘图部分：替换stat_density_ridges为geom_ridgeline
p <- ggplot() +
  # 使用预计算的密度数据绘制脊线
  geom_ridgeline(data = dens_data, 
                 aes(x = x, y = category, height = y_scaled, fill = category),
                 alpha = 0.7, color = "black") +
  # 保留散点图层
  geom_point(data = df, aes(x = avg_body_mass, y = category),
             position = position_jitter(height = 0.1), size = 1.5, alpha = 0.7) +
  # 后续facet、labs、scale、theme等代码保持不变
  facet_grid(Sex ~ ., scales = "free_y", switch = "y") +
  labs(
    title = plot_title,
    x = "Body Mass (Kg)",
    y = ""
  ) +
  scale_fill_manual(values = c(
    "Underweight" = "steelblue",
    "Healthy BM" = "green2",
    "Overweight" = "gold",
    "Obese" = "darkorange",
    "Morbidly obese" = "brown"
  )) +
  theme_minimal(base_size = 14) +
  theme(
    legend.position = "bottom",
    axis.text.x = element_text(face = "bold"),
    strip.placement = "outside",
    strip.text.y.left = element_text(size = 14, face = "bold")
  )

3. 调整脊线高度比例

如果脊线高度差距过大或过小，可修改scaling_factor：

若想全局统一缩放，可先计算所有分组的最大缩放密度，再设置系数：

max_global_density <- dens_data %>% pull(y_scaled) %>% max()
scaling_factor <- max_global_density * 0.2

若想固定高度比例，直接设置数值（如scaling_factor = 5）。

完整修改后的代码

library(ggplot2)
library(dplyr)
library(ggridges)
library(readxl)
library(writexl)

plot_body_mass_ridgeline <- function(file_female, file_male,
                                     wild_female_avg, wild_male_avg) {
  
  # 1. 读取Excel文件
  df_f <- read_excel(file_female) %>%
    mutate(Sex = "Female", wild_ref = wild_female_avg)
  df_m <- read_excel(file_male) %>%
    mutate(Sex = "Male", wild_ref = wild_male_avg)
  
  # 2. 合并数据
  df <- bind_rows(df_f, df_m)
  
  # 3. 分类体重偏差
  df <- df %>%
    mutate(ratio = avg_body_mass / wild_ref,
           category = case_when(
             ratio < 0.75                     ~ "Underweight",
             ratio >= 0.75 & ratio <= 1.25    ~ "Healthy BM",
             ratio >  1.25 & ratio <= 1.50    ~ "Overweight",
             ratio >  1.50 & ratio <= 1.75    ~ "Obese",
             ratio >  1.75                    ~ "Morbidly obese"
           ),
           category = factor(category, 
                             levels = c("Underweight",
                                        "Healthy BM",
                                        "Overweight",
                                        "Obese",
                                        "Morbidly obese")))
  
  # 4. 获取物种名称
  species <- unique(df$binSpecies)
  plot_title <- paste(species)
  
  # 5. 统计每组样本量
  counts <- df %>%
    group_by(Sex, category) %>%
    summarise(n = n(), .groups = "drop")
  print(counts)
  
  # --------------------------新增：计算带计数缩放的密度--------------------------
  dens_data <- df %>%
    group_by(Sex, category) %>%
    group_modify(function(.x, .y) {
      n <- nrow(.x)
      dens <- density(.x$avg_body_mass, adjust = 1, na.rm = TRUE)
      scaling_factor <- max(dens$y * n) * 0.15
      tibble(
        x = dens$x,
        y_scaled = dens$y * n / scaling_factor,
        category = .y$category,
        Sex = .y$Sex
      )
    }) %>%
    ungroup()
  # -----------------------------------------------------------------------------
  
  # 6. 绘制脊线图
  p <- ggplot() +
    geom_ridgeline(data = dens_data, 
                   aes(x = x, y = category, height = y_scaled, fill = category),
                   alpha = 0.7, color = "black") +
    geom_point(data = df, aes(x = avg_body_mass, y = category),
               position = position_jitter(height = 0.1), size = 1.5, alpha = 0.7) +
    facet_grid(Sex ~ ., scales = "free_y", switch = "y") +
    labs(
      title = plot_title,
      x = "Body Mass (Kg)",
      y = ""
    ) +
    scale_fill_manual(values = c(
      "Underweight" = "steelblue",
      "Healthy BM" = "green2",
      "Overweight" = "gold",
      "Obese" = "darkorange",
      "Morbidly obese" = "brown"
    )) +
    theme_minimal(base_size = 14) +
    theme(
      legend.position = "bottom",
      axis.text.x = element_text(face = "bold"),
      strip.placement = "outside",
      strip.text.y.left = element_text(size = 14, face = "bold")
    )
  
  # 7. 添加样本量标注
  dens_peaks <- df %>%
    group_by(Sex, category) %>%
    summarise(xpos = median(avg_body_mass), .groups = "drop") %>%
    left_join(counts, by = c("Sex", "category"))
  
  p <- p + 
    geom_text(data = dens_peaks,
              aes(x = xpos, y = category, label = paste0("N = ", n)),
              inherit.aes = FALSE,
              vjust = 2, hjust = -0.25, size = 4, fontface = "bold")
  
  # 8. 添加野生平均值参考线
  wild_df <- tibble(
    Sex = c("Female", "Male"),
    wild_ref = c(wild_female_avg, wild_male_avg)
  )
  
  p <- p +
    geom_vline(data = wild_df, aes(xintercept = wild_ref),
               linetype = "dashed", color = "black", size = 1)+
    scale_x_continuous(
      breaks = seq(0, 300, by = 20)
    )
  
  print(p)
}

测试调用

# 保存样本数据为临时Excel文件
writexl::write_xlsx(filter(df_sample, Sex=="Female"), "temp_female.xlsx")
writexl::write_xlsx(filter(df_sample, Sex=="Male"), "temp_male.xlsx")

# 调用函数
plot_body_mass_ridgeline("temp_female.xlsx", "temp_male.xlsx", 70, 130)

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

如何让ggridges脊线图高度与数据点数量/频率成正比？

示例数据 #

原有绘图代码 #

当前图表 #

具体修改步骤 #

1. 预计算带计数缩放的密度数据 #

2. 替换脊线图层 #

3. 调整脊线高度比例 #

完整修改后的代码 #

测试调用 #