R用小提琴图替换barplot中的一个条
R replace one bar in barplot with violin plot
我正在使用一组特定参数的条形图比较 3 个模型的结果。条形图是必要的,因为我只有两个模型的中位数和可信区间。我想用小提琴图替换或覆盖每组的第三条(显示每组 Model 3 参数的边际后验)。我很乐意使用 base R、ggplot 或任何其他有用的东西!
我目前尝试过的简化版本如下:
library(ggplot2)
library(plyr)
## Data
params <- paste0("param", 1:3)
medians <- data.frame(value = c(seq(0.1,0.6, by = 0.1), rep(0, 3)),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(paste0("param", 1:3), 3))
m3_posterior <- data.frame(value = runif(900, 0.2, 0.7),
model = "M3",
parameter = rep(params, each = 3))
m3_stats <- ddply(m3_posterior, .(parameter), summarize,
lower = quantile(value, 0.025),
upper = quantile(value, 0.975) )
confs <- data.frame(lower = c(seq(0.05, 0.55, by = 0.1), m3_stats$lower),
upper = c(seq(0.15, 0.65, by = 0.1), m3_stats$upper),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(params, 3))
## plotting code
transparent_theme <- theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank(),
axis.line = element_blank(),
panel.background = element_rect(fill = "transparent",colour = NA),
plot.background = element_rect(fill = "transparent",colour = NA))
print_list <- list()
for (param in 1 : length(params)) {
gg_medians <- subset(medians, parameter == params[param])
gg_confs <- subset(confs, parameter == params[param])
gg_post <- subset(m3_posterior, parameter == params[param])
p1 <- ggplot(gg_medians, aes(model, value)) +
geom_bar(stat="identity", fill = "white", colour = "black") +
geom_errorbar(data = gg_confs,
aes(y=upper, ymax=upper, ymin=lower)) +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param])
p2 <- ggplot(gg_post, aes(parameter, value)) +
geom_violin(width=1.5, fill = NA)+
transparent_theme +
geom_errorbar(data = subset(gg_confs, model == "M3"),
aes(y=upper, ymax=upper, ymin=lower)) +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param])
if (param > 1 ) {
p1 <- p1 + theme(axis.title.y=element_blank(),
axis.text.y=element_blank(),
axis.ticks.y=element_blank())
p2 <- p2 + theme(axis.title.y=element_blank(),
axis.text.y=element_blank(),
axis.ticks.y=element_blank())
}
p2_grob <- ggplotGrob(p2)
print_list[[param]] <- p1 + annotation_custom(grob = p2_grob,
xmin = 2.5, xmax = 3.5,
ymin = -0.0665, ymax = 1.061)
}
lay_out = function(...) {
x <- list(...)
n <- max(sapply(x, function(x) max(x[[2]])))
p <- max(sapply(x, function(x) max(x[[3]])))
grid::pushViewport(grid::viewport(layout = grid::grid.layout(n, p)))
for (i in seq_len(length(x))) {
print(x[[i]][[1]], vp = grid::viewport(
layout.pos.row = x[[i]][[2]],
layout.pos.col = x[[i]][[3]]))
}
}
lay_out(list(print_list[[1]], 1, 1),
list(print_list[[2]], 1, 2),
list(print_list[[3]], 1, 3))
我遇到的主要问题是:
将小提琴图 grob 与底层条形图对齐(我基本上使用猜测和检查数字)
保持每个图的绘图区域相同,同时第一个图只有一个 y 轴
您似乎希望 m3 中的两个误差线垂直和水平对齐。
水平对齐 - 您将各种轴元素设置为空白的方法不太奏效 - 轴中剩余一小部分 space。我发现从 p2 的 gtable select 绘图面板,然后将其插入 p1 更容易。
垂直对齐 - 将 ymin 和 ymax 设置为 -Inf 并且 Inf 应该负责垂直对齐,前提是两个图的限制相同。我已将小提琴图中误差线的颜色更改为红色,以便更容易看到对齐(或未对齐)。
使三个绘图面板的宽度相同 - 从 print_list[[1]] 中剥离轴 material,然后使三个面板的宽度为单位( 1, "npc").此外,您可以 select 来自 print_list[[2]] 和 print_list[[3]] 的绘图面板,因此无需将轴元素设置为空白。我发现使用 gtable 设置布局更容易。
此外,您会收到一条警告消息,因为 geom_errorbar 没有 y 美学。并且,在 m3 处,您会在 y=0 处得到一条线,因为条形高度设置为零。如果您不想要这条线,请将条形高度设置为 NA。
## Data
library(ggplot2)
library(plyr)
library(gtable)
library(grid)
params <- paste0("param", 1:3)
medians <- data.frame(value = c(seq(0.1,0.6, by = 0.1), rep(NA, 3)),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(paste0("param", 1:3), 3))
m3_posterior <- data.frame(value = runif(900, 0.2, 0.7),
model = "M3",
parameter = rep(params, each = 3))
m3_stats <- ddply(m3_posterior, .(parameter), summarize,
lower = quantile(value, 0.025),
upper = quantile(value, 0.975) )
confs <- data.frame(lower = c(seq(0.05, 0.55, by = 0.1), m3_stats$lower),
upper = c(seq(0.15, 0.65, by = 0.1), m3_stats$upper),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(params, 3))
print_list <- list()
for (param in 1 : length(params)) {
gg_medians <- subset(medians, parameter == params[param])
gg_confs <- subset(confs, parameter == params[param])
gg_post <- subset(m3_posterior, parameter == params[param])
p1 <- ggplot(gg_medians, aes(model)) +
geom_bar(aes(y = value), stat="identity", fill = "white", colour = "black") +
geom_errorbar(data = gg_confs,
aes(ymax=upper, ymin=lower)) +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param])
p2 <- ggplot(gg_post, aes(parameter)) +
geom_violin(aes(y = value), width=1.5, fill = NA) +
geom_errorbar(data = subset(gg_confs, model == "M3"),
aes(ymax=upper, ymin=lower), colour = "red") +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param]) +
theme_bw() +
theme(panel.grid = element_blank(),
panel.border = element_blank(),
panel.background = element_rect(fill = "transparent"))
p2_grob <- ggplotGrob(p2)
panel = gtable_filter(p2_grob, "panel") # Select plot panel from p2
print_list[[param]] <- p1 + annotation_custom(grob = panel,
xmin = 2.5, xmax = 3.5,
ymin = -Inf, ymax = Inf) # Put the panel it into p1
}
# From print_list:
# separate y-axis and panel columns in print_list[[1]]
# and get panel columns from print_list[[2]] and print_list[[3]]
g1 = ggplotGrob(print_list[[1]])
axis = g1[, 2:3] # Get the y axis
g1 = g1[, -c(1:3)] # Get the panel & columns to the right for param1
g2 = ggplotGrob(print_list[[2]])
g2 = g2[, -c(1:3)] # Get the panel & columns to the right for param2
g3 = ggplotGrob(print_list[[3]])
g3 = g3[, -c(1:3)] # Get the panel & columns to the right for param3
# Set up gtable 5 columns X 1 row
# 5 columns: left margin, width of y axis, width of three panels
# 1 row
gt = gtable(unit.c(unit(5.5, "pt"), sum(axis$widths), unit(c(1,1,1), "null")), unit(1, "null"))
# Populate the gtable, and draw the plot
gt = gtable_add_grob(gt, list(axis, g1, g2, g3), t = 1, l = 2:5)
grid.newpage()
grid.draw(gt)
我正在使用一组特定参数的条形图比较 3 个模型的结果。条形图是必要的,因为我只有两个模型的中位数和可信区间。我想用小提琴图替换或覆盖每组的第三条(显示每组 Model 3 参数的边际后验)。我很乐意使用 base R、ggplot 或任何其他有用的东西!
我目前尝试过的简化版本如下:
library(ggplot2)
library(plyr)
## Data
params <- paste0("param", 1:3)
medians <- data.frame(value = c(seq(0.1,0.6, by = 0.1), rep(0, 3)),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(paste0("param", 1:3), 3))
m3_posterior <- data.frame(value = runif(900, 0.2, 0.7),
model = "M3",
parameter = rep(params, each = 3))
m3_stats <- ddply(m3_posterior, .(parameter), summarize,
lower = quantile(value, 0.025),
upper = quantile(value, 0.975) )
confs <- data.frame(lower = c(seq(0.05, 0.55, by = 0.1), m3_stats$lower),
upper = c(seq(0.15, 0.65, by = 0.1), m3_stats$upper),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(params, 3))
## plotting code
transparent_theme <- theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank(),
axis.line = element_blank(),
panel.background = element_rect(fill = "transparent",colour = NA),
plot.background = element_rect(fill = "transparent",colour = NA))
print_list <- list()
for (param in 1 : length(params)) {
gg_medians <- subset(medians, parameter == params[param])
gg_confs <- subset(confs, parameter == params[param])
gg_post <- subset(m3_posterior, parameter == params[param])
p1 <- ggplot(gg_medians, aes(model, value)) +
geom_bar(stat="identity", fill = "white", colour = "black") +
geom_errorbar(data = gg_confs,
aes(y=upper, ymax=upper, ymin=lower)) +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param])
p2 <- ggplot(gg_post, aes(parameter, value)) +
geom_violin(width=1.5, fill = NA)+
transparent_theme +
geom_errorbar(data = subset(gg_confs, model == "M3"),
aes(y=upper, ymax=upper, ymin=lower)) +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param])
if (param > 1 ) {
p1 <- p1 + theme(axis.title.y=element_blank(),
axis.text.y=element_blank(),
axis.ticks.y=element_blank())
p2 <- p2 + theme(axis.title.y=element_blank(),
axis.text.y=element_blank(),
axis.ticks.y=element_blank())
}
p2_grob <- ggplotGrob(p2)
print_list[[param]] <- p1 + annotation_custom(grob = p2_grob,
xmin = 2.5, xmax = 3.5,
ymin = -0.0665, ymax = 1.061)
}
lay_out = function(...) {
x <- list(...)
n <- max(sapply(x, function(x) max(x[[2]])))
p <- max(sapply(x, function(x) max(x[[3]])))
grid::pushViewport(grid::viewport(layout = grid::grid.layout(n, p)))
for (i in seq_len(length(x))) {
print(x[[i]][[1]], vp = grid::viewport(
layout.pos.row = x[[i]][[2]],
layout.pos.col = x[[i]][[3]]))
}
}
lay_out(list(print_list[[1]], 1, 1),
list(print_list[[2]], 1, 2),
list(print_list[[3]], 1, 3))
我遇到的主要问题是:
将小提琴图 grob 与底层条形图对齐(我基本上使用猜测和检查数字)
保持每个图的绘图区域相同,同时第一个图只有一个 y 轴
您似乎希望 m3 中的两个误差线垂直和水平对齐。
水平对齐 - 您将各种轴元素设置为空白的方法不太奏效 - 轴中剩余一小部分 space。我发现从 p2 的 gtable select 绘图面板,然后将其插入 p1 更容易。
垂直对齐 - 将 ymin 和 ymax 设置为 -Inf 并且 Inf 应该负责垂直对齐,前提是两个图的限制相同。我已将小提琴图中误差线的颜色更改为红色,以便更容易看到对齐(或未对齐)。
使三个绘图面板的宽度相同 - 从 print_list[[1]] 中剥离轴 material,然后使三个面板的宽度为单位( 1, "npc").此外,您可以 select 来自 print_list[[2]] 和 print_list[[3]] 的绘图面板,因此无需将轴元素设置为空白。我发现使用 gtable 设置布局更容易。
此外,您会收到一条警告消息,因为 geom_errorbar 没有 y 美学。并且,在 m3 处,您会在 y=0 处得到一条线,因为条形高度设置为零。如果您不想要这条线,请将条形高度设置为 NA。
## Data
library(ggplot2)
library(plyr)
library(gtable)
library(grid)
params <- paste0("param", 1:3)
medians <- data.frame(value = c(seq(0.1,0.6, by = 0.1), rep(NA, 3)),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(paste0("param", 1:3), 3))
m3_posterior <- data.frame(value = runif(900, 0.2, 0.7),
model = "M3",
parameter = rep(params, each = 3))
m3_stats <- ddply(m3_posterior, .(parameter), summarize,
lower = quantile(value, 0.025),
upper = quantile(value, 0.975) )
confs <- data.frame(lower = c(seq(0.05, 0.55, by = 0.1), m3_stats$lower),
upper = c(seq(0.15, 0.65, by = 0.1), m3_stats$upper),
model = rep(c("M1", "M2", "M3"), each = 3),
parameter = rep(params, 3))
print_list <- list()
for (param in 1 : length(params)) {
gg_medians <- subset(medians, parameter == params[param])
gg_confs <- subset(confs, parameter == params[param])
gg_post <- subset(m3_posterior, parameter == params[param])
p1 <- ggplot(gg_medians, aes(model)) +
geom_bar(aes(y = value), stat="identity", fill = "white", colour = "black") +
geom_errorbar(data = gg_confs,
aes(ymax=upper, ymin=lower)) +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param])
p2 <- ggplot(gg_post, aes(parameter)) +
geom_violin(aes(y = value), width=1.5, fill = NA) +
geom_errorbar(data = subset(gg_confs, model == "M3"),
aes(ymax=upper, ymin=lower), colour = "red") +
scale_y_continuous(limits=c(0,1)) + labs(x=params[param]) +
theme_bw() +
theme(panel.grid = element_blank(),
panel.border = element_blank(),
panel.background = element_rect(fill = "transparent"))
p2_grob <- ggplotGrob(p2)
panel = gtable_filter(p2_grob, "panel") # Select plot panel from p2
print_list[[param]] <- p1 + annotation_custom(grob = panel,
xmin = 2.5, xmax = 3.5,
ymin = -Inf, ymax = Inf) # Put the panel it into p1
}
# From print_list:
# separate y-axis and panel columns in print_list[[1]]
# and get panel columns from print_list[[2]] and print_list[[3]]
g1 = ggplotGrob(print_list[[1]])
axis = g1[, 2:3] # Get the y axis
g1 = g1[, -c(1:3)] # Get the panel & columns to the right for param1
g2 = ggplotGrob(print_list[[2]])
g2 = g2[, -c(1:3)] # Get the panel & columns to the right for param2
g3 = ggplotGrob(print_list[[3]])
g3 = g3[, -c(1:3)] # Get the panel & columns to the right for param3
# Set up gtable 5 columns X 1 row
# 5 columns: left margin, width of y axis, width of three panels
# 1 row
gt = gtable(unit.c(unit(5.5, "pt"), sum(axis$widths), unit(c(1,1,1), "null")), unit(1, "null"))
# Populate the gtable, and draw the plot
gt = gtable_add_grob(gt, list(axis, g1, g2, g3), t = 1, l = 2:5)
grid.newpage()
grid.draw(gt)