如何在R中优化区块图匹配示例风格？是否有更简便实现方式？

云上老周

2026-6-13

调整热力图风格贴近目标示例的方法及简化实现

我有如下R数据框：

basketball_stats <- data.frame(
  shots_taken = c(1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5),
  shots_made = c(1, 0, 2, 1, 0, 3, 2, 1, 0, 4, 3, 2, 1, 0, 5, 4, 3, 2, 1, 0),
  total_players = c(85, 15, 72, 21, 7, 58, 26, 13, 3, 42, 31, 18, 7, 2, 34, 28, 21, 12, 4, 1)
)

我想要制作的目标图表具备以下特征：

热力图形式，单元格颜色对应百分比数值
单元格内同时显示百分比和样本量（如"100%\n85"）
风格偏向商务简洁，坐标轴清晰，颜色渐变自然

我已经写出了基础实现代码，但图表风格和目标仍有差距：

library(ggplot2)
library(dplyr)
library(scales)

basketball_stats$percentage <- (basketball_stats$shots_made / basketball_stats$shots_taken) * 100

all_combinations <- expand.grid(
  shots_taken = 1:5,
  shots_made = 0:5
)
all_combinations <- all_combinations[all_combinations$shots_made <= all_combinations$shots_taken, ]

heatmap_data <- merge(all_combinations, basketball_stats, 
                     by = c("shots_taken", "shots_made"), 
                     all.x = TRUE)

heatmap_data$total_players[is.na(heatmap_data$total_players)] <- 0
heatmap_data$percentage[is.na(heatmap_data$percentage)] <- 0

heatmap_data$label <- ifelse(heatmap_data$total_players > 0,
                           paste0(round(heatmap_data$percentage, 1), "%\n(", heatmap_data$total_players, ")"),
                           "")

my_colors <- colorRampPalette(c("#FF6961", "#FFA500", "#FDFD96", "#77DD77"))(100)

ggplot(heatmap_data, aes(x = as.factor(shots_made), y = as.factor(shots_taken))) +
  geom_tile(aes(fill = percentage), color = "white", size = 0.5) +
  geom_text(aes(label = label), fontface = "bold") +
  scale_fill_gradientn(colors = my_colors, 
                     limits = c(0, 100),
                     name = "Shooting %") +
  labs(
    title = "Basketball Shooting Statistics",
    subtitle = "Percentage of shots made by number of attempts",
    x = "Shots Made",
    y = "Shots Taken"
  ) +
  theme_minimal() +
  theme(
    legend.position = "bottom",
    plot.title = element_text(hjust = 0.5, face = "bold"),
    plot.subtitle = element_text(hjust = 0.5),
    axis.text = element_text(face = "bold"),
    panel.grid = element_blank()
  )

风格调整建议

对比目标图表，可从以下维度优化：

颜色方案：替换当前暖色调渐变，使用蓝-红渐变（低百分比冷色，高百分比暖色），更贴合目标风格
单元格样式：增加边框厚度并改用灰色边框，让网格结构更清晰
文本排版：调整文本大小和行间距，避免内容拥挤，提升可读性
坐标轴排序：固定坐标轴级别顺序，确保y轴（出手次数）从低到高排列
图例优化：加宽横向图例，用百分比格式标注刻度，提升直观性
背景网格：保留浅色网格线作为参考，弱化纯空白背景的单调感

优化后的完整代码

library(ggplot2)
library(dplyr)
library(tidyr)
library(scales)

# 简化数据预处理：用complete替代expand.grid+merge，自动补全缺失组合
heatmap_data <- basketball_stats %>%
  mutate(percentage = (shots_made / shots_taken) * 100) %>%
  complete(shots_taken = 1:5, shots_made = 0:shots_taken, fill = list(total_players = 0, percentage = 0)) %>%
  mutate(
    label = ifelse(total_players > 0,
                   paste0(round(percentage, 1), "%\n", total_players),
                   ""),
    # 固定坐标轴顺序，避免排序混乱
    shots_taken = factor(shots_taken, levels = 1:5),
    shots_made = factor(shots_made, levels = 0:5)
  )

# 目标风格的蓝红渐变配色
my_colors <- colorRampPalette(c("#e6f7ff", "#1890ff", "#ff4d4f"))(100)

ggplot(heatmap_data, aes(x = shots_made, y = shots_taken)) +
  geom_tile(aes(fill = percentage), color = "#cccccc", size = 1) +
  geom_text(aes(label = label), size = 4, lineheight = 0.8) +
  scale_fill_gradientn(
    colors = my_colors,
    limits = c(0, 100),
    name = "投篮命中率",
    labels = percent_format(scale = 1)
  ) +
  labs(
    title = "篮球投篮统计",
    subtitle = "按出手次数分类的投篮命中率",
    x = "命中次数",
    y = "出手次数"
  ) +
  theme_minimal() +
  theme(
    legend.position = "bottom",
    legend.key.width = unit(2, "cm"),
    plot.title = element_text(hjust = 0.5, face = "bold", size = 14),
    plot.subtitle = element_text(hjust = 0.5, size = 12, color = "#666666"),
    axis.title = element_text(size = 11, color = "#333333"),
    axis.text = element_text(size = 10, face = "bold"),
    panel.grid.major = element_line(color = "#f0f0f0", size = 0.5)
  )

更简便的实现方法

上述代码用tidyr::complete替代了expand.grid+merge的组合，简化了缺失值补全逻辑，代码更简洁易读。如果处理的是分箱后的区间数据（如你提供的SQL生成的分类），可按以下流程快速实现：

用generate_sql生成SQL查询获取分箱统计数据
用sort_range_categories对区间类别排序
结合format_large_numbers格式化大数值标签
直接调用ggplot绘制热力图

示例代码（针对分箱数据）：

# 假设已获取分箱统计数据框realistic_summary
realistic_summary <- realistic_summary %>%
  mutate(
    # 对区间类别进行排序
    var1_category = factor(var1_category, levels = sort_range_categories(unique(var1_category))),
    var2_category = factor(var2_category, levels = sort_range_categories(unique(var2_category))),
    # 格式化单元格标签
    label = paste0(round(percentage_with_1, 1), "%\n", format_large_numbers(people_with_1), "/", format_large_numbers(total_people))
  )

ggplot(realistic_summary, aes(x = var1_category, y = var2_category, fill = percentage_with_1)) +
  geom_tile(color = "#cccccc", size = 1) +
  geom_text(aes(label = label), size = 3.5, lineheight = 0.8) +
  scale_fill_gradientn(colors = c("#e6f7ff", "#1890ff", "#ff4d4f"), name = "占比") +
  scale_y_discrete(labels = function(x) gsub("(\\d+)000-(\\d+)999", "\\1k-\\2k", x)) +
  labs(title = "Indicator=1的占比统计", x = "Var1", y = "Var2") +
  theme_minimal() +
  theme(
    legend.position = "bottom",
    legend.key.width = unit(2, "cm"),
    plot.title = element_text(hjust = 0.5, face = "bold"),
    axis.text = element_text(face = "bold")
  )

辅助工具代码（中文注释版）

# 生成用于分箱统计的SQL查询语句
generate_sql <- function(table_name, var1_name, var2_name, var3_name, year_name, var1_ranges, var2_ranges, year_range) {
  options(scipen=999)
  
  # 生成单个变量的CASE分箱逻辑
  create_case <- function(var_name, ranges) {
    lines <- c()
    for (i in 1:(length(ranges) - 1)) {
      lower <- ranges[i]
      upper <- ranges[i+1]
      if (lower == upper) {
        lines <- c(lines, paste0("    WHEN ", var_name, " = ", lower, " THEN '", lower, "'"))
      } else {
        lines <- c(lines, paste0("    WHEN ", var_name, " >= ", lower, " AND ", var_name, " < ", upper, " THEN '", lower, "-", upper-1, "'"))
      }
    }
    lines <- c(lines, paste0("    WHEN ", var_name, " >= ", ranges[length(ranges)], " THEN '", ranges[length(ranges)], "+'"))
    paste(c(paste0("  CASE"), lines, "    ELSE 'Other'", paste0("  END AS ", var_name, "_category")), collapse = "\n")
  }
  
  paste0(
    "WITH categorized_data AS (\n",
    "  SELECT name, ", var3_name, ",\n",
    create_case(var1_name, var1_ranges), ",\n",
    create_case(var2_name, var2_ranges), "\n",
    "  FROM ", table_name, "\n",
    "  WHERE (var_a = 1 OR var_b = 1 OR var_c = 1) AND ", year_name, " IN (", paste(year_range, collapse = ", "), ") AND ", var1_name, " IS NOT NULL AND ", var2_name, " IS NOT NULL\n",
    ")\n",
    "SELECT ", var1_name, "_category, ", var2_name, "_category, COUNT(*) as total_people, SUM(", var3_name, ") as people_with_1, 100.0 * SUM(", var3_name, ") / COUNT(*) as percentage_with_1\n",
    "FROM categorized_data\n",
    "GROUP BY ", var1_name, "_category, ", var2_name, "_category\n",
    "ORDER BY ", var1_name, "_category, ", var2_name, "_category;"
  )
}

# 示例调用
var1_ranges <- c(0, 0, 10, 20, 100000)
var2_ranges <- c(0, 5, 10, 15)
year_range <- c(2001, 2002, 2003)
cat(generate_sql("mydf", "var1", "var2", "indicator", "my_year", var1_ranges, var2_ranges, year_range))

# 对分箱后的区间类别进行排序
sort_range_categories <- function(categories) {
  first_numbers <- sapply(categories, function(x) {
    if (grepl("\\+", x)) {
      as.numeric(gsub("(\\d+)\\+.*", "\\1", x))
    } else if (grepl("-", x)) {
      as.numeric(gsub("(\\d+)-.*", "\\1", x))
    } else {
      as.numeric(x)
    }
  })
  
  categories[order(first_numbers)]
}

# 格式化大数值为k/M单位
format_large_numbers <- function(x) {
  ifelse(x >= 1e6, paste0(round(x/1e6, 1), "M"),
         ifelse(x >= 1e3, paste0(round(x/1e3, 1), "k"), x))
}

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

如何在R中优化区块图匹配示例风格？是否有更简便实现方式？

风格调整建议 #

优化后的完整代码 #

更简便的实现方法 #

辅助工具代码（中文注释版） #

风格调整建议

优化后的完整代码

更简便的实现方法

辅助工具代码（中文注释版）