如何使用R语言编写一个生成金字塔图形的函数，如下图
主要思想分成2步，1是先生成金字塔5个方框的的数据参数，2是绘图
先生成一些关键参数
l
r
evels = c("L1","L2","L3","L4","L5"),
palette = c("#8e24aa","#3f51b5","#2196f3","#4caf50","#fbc02d")
) {
tiers <- 5
H <- tiers * 1.0
BW <- 3.4
w_at <- function(y) (BW/2) * (1 - y / H)
y_breaks <- seq(0, H, length.out = tiers + 1)构建多边形（金字塔各层）
r
poly_list <- lapply(seq_len(tiers), function(i) {
ymin <- y_breaks[i]
ymax <- y_breaks[i + 1]
wt <- w_at(ymax)
wb <- w_at(ymin)
data.frame(
tier = i,
x = c(-wt, wt, wb, -wb),
y = c(ymax, ymax, ymin, ymin)
)
})
poly_df <- do.call(rbind, poly_list)标签位置数据框
r
lab_df <- data.frame(
tier = seq_len(tiers),
ymin = y_breaks[-(tiers + 1)],
ymax = y_breaks[-1]
)
lab_df $ y_mid <- (lab_df $ ymin + lab_df $ ymax) / 2
lab_df $ w_mid <- w_at(lab_df $ y_mid)
lab_df $ label <- rev(levels)
lab_df $ fill <- palette
#
lab_df $ label_x <- 0
# 自动换行
wrap_width <- 25
wrap_fun <- function(s, w) paste(strwrap(s, width = w), collapse = "\n")
lab_df $ label_wrapped <- vapply(lab_df $ label, wrap_fun, character(1), w = wrap_width)
# 合并填充色到多边形数据
poly_df <- merge(poly_df, transform(lab_df, tier = tier, fill = fill), by = "tier", sort = FALSE)最终得到如下绘图数据，可以加强你对ggplot2的绘图理解
有了绘图数据就可以绘图了，咱们把上面步骤打包成一个函数
r
library(ggplot2)
ggpyramid <- function(
levels = c("L1","L2","L3","L4","L5"),
palette = c("#8e24aa","#3f51b5","#2196f3","#4caf50","#fbc02d")
) {
tiers <- 5
H <- tiers * 1.0
BW <- 3.4
w_at <- function(y) (BW/2) * (1 - y / H)
y_breaks <- seq(0, H, length.out = tiers + 1)
# 构建多边形（金字塔各层）
poly_list <- lapply(seq_len(tiers), function(i) {
ymin <- y_breaks[i]
ymax <- y_breaks[i + 1]
wt <- w_at(ymax)
wb <- w_at(ymin)
data.frame(
tier = i,
x = c(-wt, wt, wb, -wb),
y = c(ymax, ymax, ymin, ymin)
)
})
poly_df <- do.call(rbind, poly_list)
# 标签位置数据框
lab_df <- data.frame(
tier = seq_len(tiers),
ymin = y_breaks[-(tiers + 1)],
ymax = y_breaks[-1]
)
lab_df $ y_mid <- (lab_df $ ymin + lab_df $ ymax) / 2
lab_df $ w_mid <- w_at(lab_df $ y_mid)
lab_df $ label <- rev(levels)
lab_df $ fill <- palette
#
lab_df $ label_x <- 0
# 自动换行
wrap_width <- 25
wrap_fun <- function(s, w) paste(strwrap(s, width = w), collapse = "\n")
lab_df $ label_wrapped <- vapply(lab_df $ label, wrap_fun, character(1), w = wrap_width)
# 合并填充色到多边形数据
poly_df <- merge(poly_df, transform(lab_df, tier = tier, fill = fill), by = "tier", sort = FALSE)
# 辅助函数：添加透明度
add_alpha <- function(col, alpha) {
rgb <- grDevices::col2rgb(col, TRUE) / 255
grDevices::rgb(rgb[1], rgb[2], rgb[3], alpha = alpha)
}
# 绘图
p <- ggplot() +
geom_polygon(
data = poly_df,
aes(x = x, y = y, group = tier, fill = I(fill)),
color = "white", linewidth = 1
) +
geom_label(
data = lab_df,
aes(x = label_x, y = y_mid, label = label_wrapped),
hjust = 0.5, # 中对齐
vjust = 0.5,
label.size = 0,
fill = add_alpha("white", 0.22),
label.padding = unit(6, "pt"),
size = 5,
lineheight = 1.05,
color = "black"
) +
coord_equal(
xlim = c(-BW/2 - 0.2, BW/2 + 0.5),
ylim = c(0, H),
expand = FALSE
) +
labs(
title = "公众号：零基础说科研",
subtitle = "天桥下的卖艺者",
x = NULL, y = NULL
) +
theme_void(base_size = 13) +
theme(
plot.title = element_text(face = "bold", size = 18, hjust = 0.5),
plot.subtitle = element_text(margin = margin(t = 4, b = 10), hjust = 0.5),
panel.background = element_rect(fill = "#e6f7ff", color = NA),
plot.background = element_rect(colour = "gray", fill = NA),
plot.margin = margin(20, 20, 20, 20)
)
p
}绘图
r
ggpyramid(
levels = c("1", "2", "3", "4", "5"),
palette = c("mediumpurple", "yellowgreen", "yellow", "gold", "red")
)
这样一个金字塔图形就绘制好了，还可以对很多参数调整，这个有什么用，其实没什么用，但是绘制图形能增强你对ggplot2的绘图原理的理解。
本期结束了，有点简单，主要是最近太忙了，目前正在编写竞争风险模型的加权算法的函数，支持各种加权包括nhanes，相信很快就可以和大家见面了