Лесной участок в ggplot2

Question

Я пытаюсь создать лесной участок как найденный здесь .

label <- c("X1","X2","X3", "X4", "X5","X6", "X7") 
mean  <- c(1.09,1.22,1.15,1.13,1.10,1.19, 1.12) 
lower <- c(1.07,1.19,1.13,1.11,1.01,1.00, 1.07)
upper <- c(1.11,1.24,1.18,1.15,1.20,1.40, 1.17)

df <- data.frame(label, mean, lower, upper)

# reverses the factor level ordering for labels after coord_flip()
df$label <- factor(df$label, levels=rev(df$label))

library(ggplot2)
fp <- ggplot(data=df, aes(x=label, y=mean, ymin=lower, ymax=upper)) +
  geom_pointrange() + 
  geom_hline(yintercept=1, lty=2) +  # add a dotted line at x=1 after flip
  coord_flip() +  # flip coordinates (puts labels on y axis)
  xlab("") + ylab("RR") +
  theme_bw()  # use a white background
print(fp)

Как добавить некоторые подгруппы под основными заголовками (переменная "метка")?(например, я хотел бы добавить несколько возрастных подгрупп для каждого основного заголовка).

В идеале я хотел бы что-то вроде этого:

Answer 1

Эта стратегия состоит в том, чтобы разделить фрейм данных на основе интересующего столбца, в данном примере это «метка», а затем построить график для каждого фрейма данных.Наконец, соедините их вместе с arrangeGrob.

library(stringr)
library(ggplot2)
library(scales)
library(stringi)
library(grid)
library(gridExtra)
windowsFonts(CourierNew=windowsFont("Courier New")) # ONLY FOR WINDOWS

# load functions below first
{
#example dataframe. 
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)

# format numeric columns as character, this adds new columns
data<-data.frame(data, lapply(data[3:5], function(x) x<-format(round(x,2),nsmall=2) ), stringsAsFactors = F )

# split dataframe based on selected column label
out <- split( data , f = data$label ) # list of dataframes

# remove column label from dataframes
out<-lapply(out, function(x) x<-x[,2:(ncol(x)) ])

# add new column with 95% based on formated new "numeric" columns
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,")") })
# index of columns to put in y legends
mycols<-c(1,8) # agegroup and Adjusted hazard ratio

# make title of y axis labels
title<-make.title.legend(out[[1]][mycols])

# make new y axis labels for each dataframe
lnewlabel<-lapply(out, function(x) make.legend.withstats(x[mycols],title))

# each category of column label will we a plot in the list plots
plots<-list()
# space among plots
intermargin<- -0.6
# make upper plot
plots[1]<-list(plotfunctionfirst(out[[1]], lnewlabel[[1]], intermargin ) )
# make intermediate plots
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)
}
# make last plot 
plots[length(out)]<-list(plotfunctionlast(out[[length(out)]], lnewlabel[[length(out)]], intermargin) )

# get gtable of plots
gtlist <- lapply(plots, function(x) ggplot_gtable(ggplot_build(x)) )

# modify gtables
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"
}
# make left titles, column label
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)) )

# add new left titles to gtables
gtlist2<-mapply(function(x, titles2) arrangeGrob(x, top = titles2), x=gtlist, titles2= title.grobs,
                SIMPLIFY = F)

# height of each plot
hei<-unlist(lapply(out, function(x) nrow(x) ) )

# plot
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) ) ) 
}
################################## functions - load first ####################
{
  # function to make y legends
  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)] ) # 7
    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
  }   
  # function to make legend title
  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)
  }

  # function to make upper plot
  plotfunctionfirst<-function(df,mylab,intermargin){
    ggplot(data=df, aes(x=mylab[,2]) ) +
      geom_pointrange(aes(y=mean, ymin=lower, ymax=upper) ) + 
      # ggtitle("Adjusted hazard Ratio\n (95% CI)")+
      geom_hline(yintercept=1, lty=2) +
      scale_y_continuous(breaks = pretty_breaks(n=10), limits=c(0,max(data$upper)) ) + 
      coord_flip() +  # flip coordinates (puts labels on y axis)
      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) )
  }
  # function to make intermediat plots
  plotfunction2<-function(df,mylab,intermargin){
    ggplot(data=df, aes(x=mylab[,2]) ) +
      geom_pointrange(aes(y=mean, ymin=lower, ymax=upper) ) + 
      # ggtitle("Adjusted hazard Ratio\n (95% CI)")+
      geom_hline(yintercept=1, lty=2) +
      scale_y_continuous(breaks = pretty_breaks(n=10), limits=c(0,max(data$upper)) ) + 
      coord_flip() +  # flip coordinates (puts labels on y axis)
      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))
  }
  # function to make inferior plot
  plotfunctionlast<-function(df,mylab,intermargin){
    ggplot(data=df, aes(x=mylab[,2]) ) +
      geom_pointrange(aes(y=mean, ymin=lower, ymax=upper) ) + 
      # ggtitle("Adjusted hazard Ratio\n (95% CI)")+
      geom_hline(yintercept=1, lty=2) +
      scale_y_continuous(breaks = pretty_breaks(n=10), limits=c(0,max(data$upper)) ) + 
      coord_flip() +  # flip coordinates (puts labels on y axis)
      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