这个策略包括根据感兴趣的列(在此示例中为“label”)将数据框拆分,然后为每个数据框制作一个图。最后,使用
arrangeGrob
将它们组合在一起。
library(stringr)
library(ggplot2)
library(scales)
library(stringi)
library(grid)
library(gridExtra)
windowsFonts(CourierNew=windowsFont("Courier New"))
{
label<- c(rep("Myocardial infarction",3),rep("other",2),rep("other2",2))
agegroup <- c("X1","X20","X3", "X4", "X5","X6", "X7")
mean <- c(1.09,1.22,1.15,1.13,10.10,1.19, 1.12)
lower <- c(1.07,1.19,1.13,1.11,9.01, 1, 1.07)
upper <- c(1.11,1.24,1.18,1.15,11.20,1.40, 1.17)
data<-data.frame(label=label,agegroup=agegroup,mean=mean,lower=lower,upper=upper)
data<-data.frame(data, lapply(data[3:5], function(x) x<-format(round(x,2),nsmall=2) ), stringsAsFactors = F )
out <- split( data , f = data$label )
out<-lapply(out, function(x) x<-x[,2:(ncol(x)) ])
lapply(seq_along(out), function(i){
out[[i]]$`Adjusted hazard Ratio`<<-paste0(out[[i]]$mean.1," (",out[[i]]$lower.1," to ",
out[[i]]$upper.1,")") })
mycols<-c(1,8)
title<-make.title.legend(out[[1]][mycols])
lnewlabel<-lapply(out, function(x) make.legend.withstats(x[mycols],title))
plots<-list()
intermargin<- -0.6
plots[1]<-list(plotfunctionfirst(out[[1]], lnewlabel[[1]], intermargin ) )
if (length(out)>2){
plots[2:(length(out)-1)]<-mapply(plotfunction2, df=out[2:(length(out)-1)], mylab= lnewlabel[2:(length(out)-1)],
intermargin=intermargin,SIMPLIFY = F)
}
plots[length(out)]<-list(plotfunctionlast(out[[length(out)]], lnewlabel[[length(out)]], intermargin) )
gtlist <- lapply(plots, function(x) ggplot_gtable(ggplot_build(x)) )
poslist<-lapply(seq_along(gtlist), function(x) grep(5,gtlist[[x]]$layout$r) )
for (i in 1:length(gtlist)){
gtlist[[i]]$layout$r[poslist[[i]]]<-4
gtlist[[i]]$layout$r[-poslist[[i]]]<-3
gtlist[[i]]$layout$l[-poslist[[i]]]<-3
gtlist[[i]]$layout$clip[gtlist[[i]]$layout$name == "panel"] <- "off"
}
title.grobs <- lapply(names(out), function(x) grid::textGrob(
label = x, x = unit(0, "lines"), y = unit(0, "lines"),
hjust = 0, vjust = 0, gp = grid::gpar(fontsize = 14)) )
gtlist2<-mapply(function(x, titles2) arrangeGrob(x, top = titles2), x=gtlist, titles2= title.grobs,
SIMPLIFY = F)
hei<-unlist(lapply(out, function(x) nrow(x) ) )
gridExtra::grid.arrange(
gridExtra::arrangeGrob(grobs=gtlist2, ncol=1,heights= hei, top= "Adjusted hazard Ratio\n (95% CI)" ),
bottom=grid::textGrob("", gp=grid::gpar(cex=3) ) )
}
{
make.legend.withstats <- function(data,namecol) {
nchar1<-nchar(as.character(data[,1]))
nchar2<-nchar(colnames(data)[1])
maxlen<-max(c(nchar1,nchar2))
data[,1]<-sprintf(paste0("%-",maxlen,"s"), data[,1])
data[,ncol(data)+1]<-paste(data[,1],data[,2],sep=" ")
ncharmin2<-min(nchar(data[,2]))
y<- ncharmin2-1
nchara1<-nchar(data[,ncol(data)] )
init1<-min(nchara1)
y2<-init1-1
minchar<-min(nchar(data[,2]))
maxchar<-max(c(nchar(colnames(data)[2]),(nchar(data[,2]))))
dif<-maxchar-minchar
if (dif>0){
for (i3 in minchar:(maxchar-1)) {
y2<-y2+1
y<-y+1
str_sub(data[nchar(data[,ncol(data)]) == y2, ][,ncol(data)], y2-y, y2-y)<- " "
}
}
nd<-ncol(data)-2
if(ncol(data)>3){
for (i in 2:nd) {
x3<-i
data[,ncol(data)+1]<-paste(data[,ncol(data)],data[,x3+1],sep=" ")
minchar<-min(nchar(data[,x3+1]))
maxchar<-max(c(nchar(colnames(data)[x3+1]),(nchar(data[,x3+1]))))
ncharmin2<-min(nchar(data[,x3+1]))
y<- ncharmin2-1
nchara1<-nchar(data[,ncol(data)] )
init1<-min(nchara1)
y2<-init1-1
dif<-maxchar-minchar
if (dif>0){
for (i2 in minchar:(maxchar-1)) {
y2<-y2+1
y<-y+1
str_sub(data[nchar(data[,ncol(data)]) == y2, ][,ncol(data)], y2-y, y2-y)<- " "
}
}
}
}
data<- as.data.frame(data[,c(1,ncol(data))])
names(data)[2]<-paste(namecol)
data[,1]<-gsub("\\s+$", "", data[,1])
data
}
make.title.legend <- function(data) {
list<-list()
x<-1
nchar1<-max(nchar(as.character(data[,x])) )
nchar2<-nchar(colnames(data)[x])
maxdif<-max(c(nchar2,nchar1))-min(c(nchar2,nchar1))
first <- paste0(colnames(data)[x], sep=paste(replicate(maxdif, " "), collapse = ""))
list[[first]] <-first
for (i in 1:(ncol(data)-1)) {
x<-i+1
nchar1<-max(nchar(as.character(data[,x])) )
nchar2<-nchar(colnames(data)[x])
maxdif<-if(nchar2>nchar1){0} else {nchar1-nchar2}
first <- paste0(stringi::stri_dup(" ",maxdif),colnames(data)[x], collapse = "")
list[[first]] <-first
title<-str_c(list, collapse = " ")
}
return(title)
}
plotfunctionfirst<-function(df,mylab,intermargin){
ggplot(data=df, aes(x=mylab[,2]) ) +
geom_pointrange(aes(y=mean, ymin=lower, ymax=upper) ) +
geom_hline(yintercept=1, lty=2) +
scale_y_continuous(breaks = pretty_breaks(n=10), limits=c(0,max(data$upper)) ) +
coord_flip() +
theme_bw()+theme(axis.title =element_text(family="CourierNew",size=rel(1) ) ) +
theme(axis.title.y = element_text(angle=0, size = 14) ) +
theme(plot.title = element_text(lineheight=.8, face="bold", hjust=0.5) )+
theme(axis.text.y= element_text(family="CourierNew", size=14 ) ) +
theme(axis.ticks.x = element_blank() )+
theme(axis.text.x = element_blank() )+
theme(plot.margin=unit(c(.5,1,intermargin,1), "cm") )+
labs(x=paste(title,"\n (95% CI)") )+
theme (panel.border = element_blank(),
axis.line.x = element_blank(),
axis.line.y = element_line(color="black", size = 1) )
}
plotfunction2<-function(df,mylab,intermargin){
ggplot(data=df, aes(x=mylab[,2]) ) +
geom_pointrange(aes(y=mean, ymin=lower, ymax=upper) ) +
geom_hline(yintercept=1, lty=2) +
scale_y_continuous(breaks = pretty_breaks(n=10), limits=c(0,max(data$upper)) ) +
coord_flip() +
theme_bw()+theme(axis.title =element_text(family="CourierNew",size=rel(1) ) ) +
theme(axis.title.y = element_text(colour="white",angle=0, size = 14) ) +
theme(plot.title = element_text(lineheight=.8, face="bold", hjust=0.5) )+
theme(axis.text.y= element_text(family="CourierNew", size=14 ) ) +
theme(axis.ticks.x = element_blank() )+
theme(axis.text.x = element_blank() )+
theme(plot.margin=unit(c(intermargin,1,intermargin,1), "cm") )+
labs(x=paste(title,"\n (95% CI)") )+
theme (panel.border = element_blank(),
axis.line.x = element_blank(),
axis.line.y = element_line(color="black", size = 1))
}
plotfunctionlast<-function(df,mylab,intermargin){
ggplot(data=df, aes(x=mylab[,2]) ) +
geom_pointrange(aes(y=mean, ymin=lower, ymax=upper) ) +
geom_hline(yintercept=1, lty=2) +
scale_y_continuous(breaks = pretty_breaks(n=10), limits=c(0,max(data$upper)) ) +
coord_flip() +
theme_bw()+theme(axis.title =element_text(family="CourierNew",size=rel(1) ) ) +
theme(axis.title.y = element_text(colour="white",angle=0, size = 14) ) +
theme(plot.title = element_text(lineheight=.8, face="bold", hjust=0.5) )+
theme(axis.text.y= element_text(family="CourierNew", size=14 ) ) +
theme(plot.margin=unit(c(intermargin,1,0,1), "cm") ) +
labs(x=paste(title,"\n (95% CI)") )+
theme (panel.border = element_blank() )+
theme(axis.line.x = element_line(color="black", size = 1),
axis.line.y = element_line(color="black", size = 1))
}
}
改编自:如何在R图形中的图例中包含小表格,以及来自:https://gitlab.com/ferroao/customplots的函数。