Question

我想知道是否有办法在森林图的x轴上添加两个箭头，类似于本示例中显示的内容：How to add arrows to a forest plot?（此代码不适用于ggforest）

这是示例代码：

from polyglot.text import Text
import json
file = open('input_raw.txt', 'r')
input_file = file.read()
file = Text(input_file, hint_language_code='fa')

result = set()
entities_with_tag = []
def return_match(entities_list, sentence):  # Check if Chunks
    for i in range(len(sentence.entities)):
        for j in range(len(entities_list)):
            if entities_list[j] == sentence.entities[i]:
                # result.append(sentence.entities[i])
                result.add(str(sentence.entities[i]))
                entities_with_tag.append(sentence.entities[i])

def return_list_of_entities(file):
    list_entity = []
    for sentence in file.sentences:
        for entity in sentence.entities:
            list_entity.append(entity)
    return list_entity

list_entity = return_list_of_entities(file)

def return_sentence_number():
    for i in range(len(file.sentences)):
        sentence_no = file.sentences[i]
        return sentence_no

sent_no = return_sentence_number()
return_match(list_entity, sent_no)
print("Entity Term " + str(result) + " is in the sentence. '" + str(sent_no) + "'")

我希望x轴下方的两个箭头指向任一方向，并带有“风险增加”和“风险降低”的注释。

Forest plot image example

Answer 1

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

我修改了此功能以允许这样做。下面的使用示例：

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）中的森林图中添加箭头

1 个答案: