如何在R自定义绘图函数中添加直方图与密度曲线

算力阿峰

2026-6-24

问题

我编写了一个名为raincloud_summary的R通用绘图函数，可生成小提琴图、箱线图并输出统计数据，但无法实现同时显示直方图与密度曲线的效果。以下是当前代码、示例用法、现有输出及期望效果：

当前代码

library(dplyr)
library(ggplot2)
library(ggridges)
library(PupillometryR)
library(tidyr)
library(moments)

raincloud_summary <- function(dataframe, variable, grouping_variable = NULL) {
  text_vjust = 1
  add_legend <- !is.null(grouping_variable) && grouping_variable %in% names(dataframe)
  
  if (!add_legend) {
    dataframe$grouping <- "Overall"
    grouping_variable <- "grouping"
  }
  
  lower_limit <- quantile(dataframe[[variable]], probs = 0.0, na.rm = T)
  upper_limit <- quantile(dataframe[[variable]], probs = 1.0, na.rm = T)
  
  p <- ggplot(dataframe, aes_string(y = variable, fill = grouping_variable, x = grouping_variable)) +
    geom_flat_violin(kernel = "gaussian", bw = "nrd0", position = position_nudge(x = 0.15, y = 0), adjust = 1, trim = F) +
    stat_boxplot(geom ='errorbar', width = 0.1) +
    geom_boxplot(width = 0.15, outlier.shape = 1, stat = "boxplot", show.legend = F) +
    stat_summary(fun = mean, geom = "point", shape = 18, size = 3, color = "white", show.legend = F) +
    scale_y_continuous(limits = c(lower_limit, upper_limit)) +
    theme_minimal() +
    theme(text = element_text(size=11),
          plot.title = element_text(hjust = 0.5),
          axis.text.x = if(add_legend) element_text(hjust = -1) else element_blank(),
          legend.position = if (add_legend) "right" else "none") +
    labs(fill = if (add_legend) grouping_variable else NULL, x = NULL) +
    ggtitle(variable) +
    scale_fill_brewer(palette = "Pastel1", guide = if (add_legend) "legend" else "none",
                      limits = rev(levels(factor(dataframe[[grouping_variable]]))))
  
  p <- p + coord_flip() +
    theme(axis.text.x = element_text(angle = 0, vjust = 0.5),
          axis.text.y = element_text(angle = 0, hjust = 1))
  
  group_stats <- dataframe %>%
    group_by(!!sym(grouping_variable)) %>%
    summarise(
      `Min.` = min(!!sym(variable), na.rm = T),
      `Q1` = quantile(!!sym(variable), probs = 0.25, na.rm = T),
      `Median (Q2)` = median(!!sym(variable), na.rm = T),
      Mean = mean(!!sym(variable), na.rm = T),
      `Q3` = quantile(!!sym(variable), probs = 0.75, na.rm = T),
      `Max.` = max(!!sym(variable), na.rm = T),
      IQR = IQR(!!sym(variable), na.rm = T),
      SD = sd(!!sym(variable), na.rm = T),
      Variance = var(!!sym(variable), na.rm = T),
      Skewness = skewness(!!sym(variable), na.rm = T),
      Kurtosis = kurtosis(!!sym(variable), na.rm = T),
      Count = n(),
      .groups = "drop"
    ) %>%
    pivot_longer(-grouping_variable, names_to = "stat", values_to = "value") %>%
    mutate(value = round(value, 2))
  print(group_stats)
  group_levels <- levels(factor(dataframe[[grouping_variable]]))
  x_positions <- setNames(seq_along(group_levels)-0.05, group_levels)
  for (group in group_levels) {
    left_labels <- group_stats %>%
      filter(!!sym(grouping_variable) == group, stat %in% c("Min.", "Q1", "Median (Q2)", "Mean", "Q3", "Max.")) %>%
      mutate(label = paste(stat, ": ", value, sep="")) %>%
      pull(label) %>%
      paste(collapse = "\n")
    
    right_labels <- group_stats %>%
      filter(!!sym(grouping_variable) == group, stat %in% c("IQR", "SD", "Variance", "Skewness", "Kurtosis", "Count")) %>%
      mutate(label = paste(stat, ": ", value, sep="")) %>%
      pull(label) %>%
      paste(collapse = "\n")
    
    gap <- (upper_limit - lower_limit) / 5
    p <- p + annotate("text", x = x_positions[group] + 1, y = lower_limit, label = left_labels,
                      hjust = 0, vjust = text_vjust, size = 3, parse = F)
    p <- p + annotate("text", x = x_positions[group] + 1, y = lower_limit + gap, label = right_labels,
                      hjust = 0, vjust = text_vjust, size = 3, parse = F)
  }
  
  dataframe$grouping <- NULL
  print(p)
  return(group_stats)
}

示例用法

data(iris)
raincloud_summary(iris, "Sepal.Width", "Species")

现有输出

期望效果（带直方图）

期望效果

解决方案

要在函数中添加直方图和密度曲线，需适配coord_flip()后的坐标逻辑，调整图层位置与美学映射。以下是修改后的完整函数：

library(dplyr)
library(ggplot2)
library(ggridges)
library(PupillometryR)
library(tidyr)
library(moments)

raincloud_summary <- function(dataframe, variable, grouping_variable = NULL, hist_bins = 15) {
  text_vjust = 1
  add_legend <- !is.null(grouping_variable) && grouping_variable %in% names(dataframe)
  
  if (!add_legend) {
    dataframe$grouping <- "Overall"
    grouping_variable <- "grouping"
  }
  
  lower_limit <- quantile(dataframe[[variable]], probs = 0.0, na.rm = T)
  upper_limit <- quantile(dataframe[[variable]], probs = 1.0, na.rm = T)
  
  p <- ggplot(dataframe, aes_string(y = variable, fill = grouping_variable, x = grouping_variable)) +
    # 添加直方图（适配翻转后的坐标，用密度刻度对齐小提琴图）
    geom_histogram(aes_string(x = variable, y = "..density.."), 
                   bins = hist_bins, alpha = 0.3, 
                   position = position_nudge(y = -0.2), show.legend = F) +
    # 添加密度曲线
    geom_density(aes_string(x = variable), color = "black", size = 0.5, 
                 position = position_nudge(y = -0.2), show.legend = F) +
    # 原有小提琴图
    geom_flat_violin(kernel = "gaussian", bw = "nrd0", position = position_nudge(x = 0.15, y = 0), adjust = 1, trim = F) +
    stat_boxplot(geom ='errorbar', width = 0.1) +
    geom_boxplot(width = 0.15, outlier.shape = 1, stat = "boxplot", show.legend = F) +
    stat_summary(fun = mean, geom = "point", shape = 18, size = 3, color = "white", show.legend = F) +
    scale_y_continuous(limits = c(lower_limit, upper_limit)) +
    theme_minimal() +
    theme(text = element_text(size=11),
          plot.title = element_text(hjust = 0.5),
          axis.text.x = if(add_legend) element_text(hjust = -1) else element_blank(),
          legend.position = if (add_legend) "right" else "none") +
    labs(fill = if (add_legend) grouping_variable else NULL, x = NULL) +
    ggtitle(variable) +
    scale_fill_brewer(palette = "Pastel1", guide = if (add_legend) "legend" else "none",
                      limits = rev(levels(factor(dataframe[[grouping_variable]]))))
  
  p <- p + coord_flip() +
    theme(axis.text.x = element_text(angle = 0, vjust = 0.5),
          axis.text.y = element_text(angle = 0, hjust = 1))
  
  group_stats <- dataframe %>%
    group_by(!!sym(grouping_variable)) %>%
    summarise(
      `Min.` = min(!!sym(variable), na.rm = T),
      `Q1` = quantile(!!sym(variable), probs = 0.25, na.rm = T),
      `Median (Q2)` = median(!!sym(variable), na.rm = T),
      Mean = mean(!!sym(variable), na.rm = T),
      `Q3` = quantile(!!sym(variable), probs = 0.75, na.rm = T),
      `Max.` = max(!!sym(variable), na.rm = T),
      IQR = IQR(!!sym(variable), na.rm = T),
      SD = sd(!!sym(variable), na.rm = T),
      Variance = var(!!sym(variable), na.rm = T),
      Skewness = skewness(!!sym(variable), na.rm = T),
      Kurtosis = kurtosis(!!sym(variable), na.rm = T),
      Count = n(),
      .groups = "drop"
    ) %>%
    pivot_longer(-grouping_variable, names_to = "stat", values_to = "value") %>%
    mutate(value = round(value, 2))
  print(group_stats)
  group_levels <- levels(factor(dataframe[[grouping_variable]]))
  x_positions <- setNames(seq_along(group_levels)-0.05, group_levels)
  for (group in group_levels) {
    left_labels <- group_stats %>%
      filter(!!sym(grouping_variable) == group, stat %in% c("Min.", "Q1", "Median (Q2)", "Mean", "Q3", "Max.")) %>%
      mutate(label = paste(stat, ": ", value, sep="")) %>%
      pull(label) %>%
      paste(collapse = "\n")
    
    right_labels <- group_stats %>%
      filter(!!sym(grouping_variable) == group, stat %in% c("IQR", "SD", "Variance", "Skewness", "Kurtosis", "Count")) %>%
      mutate(label = paste(stat, ": ", value, sep="")) %>%
      pull(label) %>%
      paste(collapse = "\n")
    
    gap <- (upper_limit - lower_limit) / 5
    p <- p + annotate("text", x = x_positions[group] + 1, y = lower_limit, label = left_labels,
                      hjust = 0, vjust = text_vjust, size = 3, parse = F)
    p <- p + annotate("text", x = x_positions[group] + 1, y = lower_limit + gap, label = right_labels,
                      hjust = 0, vjust = text_vjust, size = 3, parse = F)
  }
  
  dataframe$grouping <- NULL
  print(p)
  return(group_stats)
}

修改说明

新增直方图与密度曲线：通过geom_histogram和geom_density实现，使用..density..刻度让直方图与小提琴图的密度分布对齐，position_nudge(y = -0.2)将其偏移到箱线图左侧（适配coord_flip()后的坐标）
新增参数hist_bins：允许自定义直方图的分箱数量，提升灵活性
图层顺序优化：将直方图放在最底层，避免遮挡小提琴图、箱线图等核心元素
保留原有功能：统计数据输出、图例逻辑、标注文本等原有功能完全保留

使用效果

运行原示例代码raincloud_summary(iris, "Sepal.Width", "Species")，即可得到包含直方图、密度曲线、小提琴图、箱线图的组合图表，与期望效果一致。

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

如何在R自定义绘图函数中添加直方图与密度曲线

问题 #

当前代码 #

示例用法 #

现有输出 #

期望效果（带直方图） #

解决方案 #

修改说明 #

使用效果 #

问题