如何在Survminer(ggforest)中的森林图中添加箭头 [英] How to add arrows to forest plot in survminer (ggforest)

问题描述

我想知道是否有一种方法可以向森林图的x轴添加两个箭头，类似于本示例中所示:

I was wondering if there was a way to add two arrows to the x-axis of a forest plot, similar to what is shown in this example: How to add arrows to a forest plot? (this code does not work on ggforest)

这是示例代码:

library(survival)
library(survminer)

model <- coxph(Surv(time, status) ~ sex + rx + adhere,
               data = colon )
ggforest(model)

colon <- within(colon, {
  sex <- factor(sex, labels = c("female", "male"))
  differ <- factor(differ, labels = c("well", "moderate", "poor"))
  extent <- factor(extent, labels = c("submuc.", "muscle", "serosa", "contig."))
})
bigmodel <-
  coxph(Surv(time, status) ~ sex + rx + adhere + differ + extent + node4,
        data = colon )
ggforest(bigmodel)

我希望x轴下方的两个箭头指向任一方向，并带有增加的风险"和减少的风险"的注释.

And I'd like two arrows underneath the x axis pointing in either direction with annotations of "increased risk" and "decreased risk".

推荐答案

survminer包中的ggforest函数使用ggplot()创建图，但是此后将该图转换为grob对象.如果要参考垂直线的位置1适当地定位箭头，则必须在转换之前 .

The ggforest function from the survminer package uses ggplot() to create the plot, but converts that plot into a grob object thereafter. If you want to position the arrows appropriately with reference to the position of the vertical line at 1, you'll have to do so before the conversion.

我修改了此功能以实现此目的.下面的使用示例:

I modified the function to allow for this. Usage examples below:

ggforest(bigmodel)
ggforest2(bigmodel) # behaves like normal ggforest

# basic usage: specify left & right labels
ggforest2(bigmodel, arrow = TRUE, arrow.labels = c("increased risk", "decreased risk"))

# change arrow colour & appearance
ggforest2(bigmodel, arrow = TRUE, arrow.labels = c("increased risk", "decreased risk"),
          arrow.colour = "blue", 
          arrow.specification = arrow(angle = 20, length = unit(0.1, "inches")))

# different arrow colours
ggforest2(bigmodel, arrow = TRUE, arrow.labels = c("increased risk", "decreased risk"),
          arrow.colour = c("firebrick", "forestgreen"))

ggforest2()的代码:

ggforest2 <- function (model, data = NULL, main = "Hazard ratio", 
                       cpositions = c(0.02, 0.22, 0.4), 
                       fontsize = 0.7, refLabel = "reference", noDigits = 2,

                       # new parameters with some default values; function's behaviour
                       # does not differ from ggforest() unless arrow = TRUE
                       arrow = FALSE, arrow.labels = c("left", "right"), 
                       arrow.specification = arrow(), arrow.colour = "black") {

  # this part is unchanged
  conf.high <- conf.low <- estimate <- NULL
  stopifnot(class(model) == "coxph")
  data <- survminer:::.get_data(model, data = data)
  terms <- attr(model$terms, "dataClasses")[-1]
  terms <- terms[intersect(names(terms), 
                           gsub(rownames(anova(model))[-1], pattern = "`", replacement = ""))]
  allTerms <- lapply(seq_along(terms), function(i) {
    var <- names(terms)[i]
    if (terms[i] == "factor") {
      adf <- as.data.frame(table(data[, var]))
      cbind(var = var, adf, pos = 1:nrow(adf))
    }
    else {
      data.frame(var = var, Var1 = "", Freq = nrow(data), pos = 1)
    }
  })
  allTermsDF <- do.call(rbind, allTerms)
  colnames(allTermsDF) <- c("var", "level", "N", "pos")
  inds <- apply(allTermsDF[, 1:2], 1, paste0, collapse = "")
  coef <- as.data.frame(broom::tidy(model))
  gmodel <- broom::glance(model)
  rownames(coef) <- gsub(coef$term, pattern = "`", replacement = "")
  toShow <- cbind(allTermsDF, coef[inds, ])[, c("var", "level", "N", "p.value", "estimate", 
                                                "conf.low", "conf.high", "pos")]
  toShowExp <- toShow[, 5:7]
  toShowExp[is.na(toShowExp)] <- 0
  toShowExp <- format(exp(toShowExp), digits = noDigits)
  toShowExpClean <- data.frame(toShow, pvalue = signif(toShow[, 4], noDigits + 1), toShowExp)
  toShowExpClean$stars <- paste0(round(toShowExpClean$p.value, noDigits + 1), " ", 
                                 ifelse(toShowExpClean$p.value < 0.05, "*", ""), 
                                 ifelse(toShowExpClean$p.value < 0.01, "*", ""), 
                                 ifelse(toShowExpClean$p.value < 0.001, "*", ""))
  toShowExpClean$ci <- paste0("(", toShowExpClean[, "conf.low.1"], 
                              " - ", toShowExpClean[, "conf.high.1"], ")")
  toShowExpClean$estimate.1[is.na(toShowExpClean$estimate)] = refLabel
  toShowExpClean$stars[which(toShowExpClean$p.value < 0.001)] = "<0.001 ***"
  toShowExpClean$stars[is.na(toShowExpClean$estimate)] = ""
  toShowExpClean$ci[is.na(toShowExpClean$estimate)] = ""
  toShowExpClean$estimate[is.na(toShowExpClean$estimate)] = 0
  toShowExpClean$var = as.character(toShowExpClean$var)
  toShowExpClean$var[duplicated(toShowExpClean$var)] = ""
  toShowExpClean$N <- paste0("(N=", toShowExpClean$N, ")")
  toShowExpClean <- toShowExpClean[nrow(toShowExpClean):1, ]
  rangeb <- range(toShowExpClean$conf.low, toShowExpClean$conf.high, 
                  na.rm = TRUE)
  breaks <- axisTicks(rangeb/2, log = TRUE, nint = 7)
  rangeplot <- rangeb
  rangeplot[1] <- rangeplot[1] - diff(rangeb)
  rangeplot[2] <- rangeplot[2] + 0.15 * diff(rangeb)
  width <- diff(rangeplot)
  y_variable <- rangeplot[1] + cpositions[1] * width
  y_nlevel <- rangeplot[1] + cpositions[2] * width
  y_cistring <- rangeplot[1] + cpositions[3] * width
  y_stars <- rangeb[2]
  x_annotate <- seq_len(nrow(toShowExpClean))
  annot_size_mm <- fontsize * as.numeric(grid::convertX(unit(theme_get()$text$size, "pt"), "mm"))

  # modified code from here onwards
  p <- ggplot(toShowExpClean, aes(seq_along(var), exp(estimate))) + 
    geom_rect(aes(xmin = seq_along(var) - 0.5, 
                  xmax = seq_along(var) + 0.5,
                  ymin = exp(rangeplot[1]), 
                  ymax = exp(rangeplot[2]), 
                  fill = ordered(seq_along(var)%%2 + 1))) + 
    geom_point(pch = 15, size = 4) + 
    geom_errorbar(aes(ymin = exp(conf.low), ymax = exp(conf.high)), 
                  width = 0.15) + 
    geom_hline(yintercept = 1, linetype = 3) + 

    annotate(geom = "text", x = x_annotate, y = exp(y_variable), 
             label = toShowExpClean$var, fontface = "bold", hjust = 0, 
             size = annot_size_mm) + 
    annotate(geom = "text", x = x_annotate, y = exp(y_nlevel),
             hjust = 0, label = toShowExpClean$level, 
             vjust = -0.1, size = annot_size_mm) + 
    annotate(geom = "text", x = x_annotate, y = exp(y_nlevel), 
             label = toShowExpClean$N, 
             fontface = "italic", hjust = 0, 
             vjust = ifelse(toShowExpClean$level == "", 0.5, 1.1), 
             size = annot_size_mm) + 
    annotate(geom = "text", x = x_annotate, y = exp(y_cistring), 
             label = toShowExpClean$estimate.1, 
             size = annot_size_mm, 
             vjust = ifelse(toShowExpClean$estimate.1 == "reference", 0.5, -0.1)) + 
    annotate(geom = "text", x = x_annotate, y = exp(y_cistring), 
             label = toShowExpClean$ci, 
             size = annot_size_mm, vjust = 1.1, fontface = "italic") + 
    annotate(geom = "text", x = x_annotate, y = exp(y_stars), 
             label = toShowExpClean$stars, size = annot_size_mm, 
             hjust = -0.2, fontface = "italic") + 
    annotate(geom = "text", x = 0.5, y = exp(y_variable), 
             label = paste0("# Events: ", 
                            gmodel$nevent, "; Global p-value (Log-Rank): ", 
                            format.pval(gmodel$p.value.log, eps = ".001"), " \nAIC: ", 
                            round(gmodel$AIC, 2), "; Concordance Index: ", 
                            round(gmodel$concordance, 2)), 
             size = annot_size_mm, hjust = 0, vjust = 1.2, 
             fontface = "italic") +

    scale_y_log10(labels = sprintf("%g", breaks),
                  expand = c(0.02, 0.02), breaks = breaks) + 
    scale_fill_manual(values = c("#FFFFFF33", "#00000033"), guide = "none") + 
    labs(title = main, x = "", y = "") +

    coord_flip(ylim = exp(rangeplot), 
               xlim = c(0.5, nrow(toShowExpClean) + 0.5),
               clip = "off") + 

    theme_light() + 
    theme(panel.grid.minor = element_blank(), 
          panel.grid.major.y = element_blank(), 
          legend.position = "none", 
          panel.border = element_blank(), 
          axis.title.y = element_blank(), 
          axis.text.y = element_blank(), 
          axis.ticks.y = element_blank(), 
          plot.title = element_text(hjust = 0.5))

  if(arrow){
    # define arrow positions based on range of coefficient values, &
    # exact y-axis range after flipping coordinates, taking into account
    # any expansion due to annotated labels above
    range.arrow.outer <- exp(min(abs(rangeb)) * c(-1, 1))
    range.arrow.inner <- exp(min(abs(rangeb)) * c(-1, 1) / 2)
    arrow.y <- ggplot_build(p)$layout$panel_params[[1]]$y.range[1] - 
      0.05 * diff(ggplot_build(p)$layout$panel_params[[1]]$y.range)

    p <- p + 
      annotate("segment", 
               x = arrow.y, xend = arrow.y, 
               y = range.arrow.inner, 
               yend = range.arrow.outer, 
               arrow = arrow.specification, color = arrow.colour) +
      annotate("text",
               x = arrow.y, y = range.arrow.inner,
               label = arrow.labels, 
               hjust = 0.5, vjust = -0.5, size = annot_size_mm,
               color = arrow.colour) +
      theme(plot.margin = margin(5.5, 5.5, 20, 5.5, "pt"))
  }

  # this part is unchanged
  gt <- ggplot_gtable(ggplot_build(p))
  gt$layout$clip[gt$layout$name == "panel"] <- "off"
  ggpubr::as_ggplot(gt)
}

这篇关于如何在Survminer(ggforest)中的森林图中添加箭头的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！