Advertisement
Guest User

A modified ggsurvplot

a guest
May 18th, 2017
1,350
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 15.62 KB | None | 0 0
  1. myggsurvplot <- function (fit, data = NULL, fun = NULL, color = NULL, palette = NULL,
  2.     linetype = 1, break.x.by = NULL, break.y.by = NULL, break.time.by = NULL,
  3.     surv.scale = c("default", "percent"), conf.int = FALSE, conf.int.fill = "gray",
  4.     conf.int.style = "ribbon", censor = TRUE, pval = FALSE, pval.size = 5,
  5.     pval.coord = c(NULL, NULL), pval.method = FALSE, pval.method.size = pval.size,
  6.     pval.method.coord = c(NULL, NULL), log.rank.weights = c("survdiff",
  7.         "1", "n", "sqrtN", "S1", "S2", "FH_p=1_q=1"), title = NULL,
  8.     xlab = "Time", ylab = "Survival probability", xlim = NULL,
  9.     ylim = NULL, legend = c("top", "bottom", "left", "right",
  10.         "none"), legend.title = "Strata", legend.labs = NULL,
  11.     tables.height = 0.25, tables.y.text = TRUE, tables.col = "black",
  12.     risk.table = FALSE, risk.table.pos = c("out", "in"), risk.table.title = NULL,
  13.     risk.table.col = tables.col, risk.table.fontsize = 4.5, fontsize = 4.5,
  14.     risk.table.y.text = tables.y.text, risk.table.y.text.col = TRUE,
  15.     risk.table.height = tables.height, surv.plot.height = 0.75,
  16.     ncensor.plot.height = tables.height, cumevents.height = tables.height,
  17.     cumcensor.height = tables.height, ncensor.plot = FALSE, ncensor.plot.title = NULL,
  18.     cumevents = FALSE, cumevents.col = tables.col, cumevents.title = NULL,
  19.     cumevents.y.text = tables.y.text, cumevents.y.text.col = TRUE,
  20.     cumcensor = FALSE, cumcensor.col = tables.col, cumcensor.title = NULL,
  21.     cumcensor.y.text = tables.y.text, cumcensor.y.text.col = TRUE,
  22.     surv.median.line = c("none", "hv", "h", "v"), ggtheme = theme_survminer(),
  23.     tables.theme = ggtheme, ...)
  24. {
  25.     if (!inherits(fit, "survfit"))
  26.         stop("Can't handle an object of class ", class(fit))
  27.     size <- ifelse(is.null(list(...)$size), 1, list(...)$size)
  28.     if (is.null(xlim))
  29.         xlim <- c(0, max(fit$time))
  30.     if (is.null(ylim) & is.null(fun))
  31.         ylim <- c(0, 1)
  32.     if (!is(legend, "numeric"))
  33.         legend <- match.arg(legend)
  34.     surv.median.line <- match.arg(surv.median.line)
  35.     stopifnot(log.rank.weights %in% c("survdiff", "1", "n", "sqrtN",
  36.         "S1", "S2", "FH_p=1_q=1"))
  37.     log.rank.weights <- match.arg(log.rank.weights)
  38.     if (ncensor.plot & cumcensor) {
  39.         warning("Both ncensor.plot and cumsensor are TRUE.",
  40.             "In this case, we consider only cumcensor.", call. = FALSE)
  41.         ncensor.plot <- FALSE
  42.     }
  43.     if (cumcensor)
  44.         ncensor.plot.height <- cumcensor.height
  45.     if (is.null(ncensor.plot.title))
  46.         ncensor.plot.title <- "Number of censoring"
  47.     if (is.null(cumcensor.title))
  48.         cumcensor.title <- "Cumulative number of censoring"
  49.     if (is.null(cumevents.title))
  50.         cumevents.title <- "Cumulative number of events"
  51.     ylab <- survminer:::.check_ylab(ylab, fun)
  52.     lty <- survminer:::.get_lty(linetype)
  53.     linetype <- lty$lty
  54.     linetype.manual <- lty$lty.manual
  55.     survminer:::.check_legend_labs(fit, legend.labs)
  56.     risk.table.pos <- match.arg(risk.table.pos)
  57.     risktable <- survminer:::.parse_risk_table_arg(risk.table)
  58.     risk.table <- risktable$display
  59.     risk.table.type <- risktable$type
  60.     extra.params <- list(...)
  61.     data <- survminer:::.get_data(fit, data = data)
  62.     d <- surv_summary(fit, data = data)
  63.     .strata <- d$strata
  64.     if (!is.null(.strata)) {
  65.         strata_names <- levels(.strata)
  66.         n.strata <- length(strata_names)
  67.         if (is.null(legend.labs))
  68.             legend.labs <- strata_names
  69.         if (missing(color))
  70.             color <- "strata"
  71.     }
  72.     else {
  73.         n.strata <- 1
  74.         if (is.null(legend.labs)) {
  75.             .strata <- as.factor(rep("All", nrow(d)))
  76.             legend.labs <- strata_names <- "All"
  77.         }
  78.         else {
  79.             .strata <- as.factor(rep(legend.labs, nrow(d)))
  80.             strata_names <- legend.labs
  81.         }
  82.         if (missing(conf.int))
  83.             conf.int = TRUE
  84.         if (missing(color))
  85.             color <- "black"
  86.     }
  87.     d$strata <- .strata
  88.     d <- survminer:::.connect2origin(d, fit, data)
  89.     d <- survminer:::.apply_surv_func(d, fun = fun)
  90.     surv.scale <- match.arg(surv.scale)
  91.     scale_labels <- ggplot2::waiver()
  92.     if (surv.scale == "percent")
  93.         scale_labels <- scales::percent
  94.     y.breaks <- ggplot2::waiver()
  95.     if (!is.null(break.y.by))
  96.         y.breaks <- seq(0, 1, by = break.y.by)
  97.     d$strata <- factor(d$strata, levels = strata_names, labels = legend.labs)
  98.     d <- d[order(d$strata), , drop = FALSE]
  99.     surv.color <- ifelse(n.strata > 1, "strata", color)
  100.     p <- ggplot2::ggplot(d, ggplot2::aes_string("time", "surv")) +
  101.         ggpubr::geom_exec(ggplot2::geom_step, data = d, size = size,
  102.             color = surv.color, linetype = linetype, ...) + ggplot2::scale_y_continuous(breaks = y.breaks,
  103.         labels = scale_labels, limits = ylim, expand = c(0, 0)) + ggplot2::coord_cartesian(xlim = xlim) +
  104.         ggtheme
  105.     p <- ggpubr::ggpar(p, palette = palette, ...)
  106.     if (!is.null(break.x.by))
  107.         break.time.by <- break.x.by
  108.     if (is.null(break.time.by))
  109.         times <- survminer:::.get_default_breaks(fit$time)
  110.     else times <- seq(0, max(c(fit$time, xlim)), by = break.time.by)
  111.     p <- p + ggplot2::scale_x_continuous(breaks = times, expand = c(0, 0))
  112.     if (conf.int) {
  113.         if (missing(conf.int.fill))
  114.             conf.int.fill <- surv.color
  115.         if (conf.int.style == "ribbon") {
  116.             p <- p + ggpubr::geom_exec(.geom_confint, data = d,
  117.                 ymin = "lower", ymax = "upper", fill = conf.int.fill,
  118.                 alpha = 0.3, na.rm = TRUE)
  119.         }
  120.         else if (conf.int.style == "step") {
  121.             p <- p + ggpubr::geom_exec(ggplot2::geom_step, data = d,
  122.                 y = "lower", linetype = "dashed", color = surv.color,
  123.                 na.rm = TRUE) + ggpubr::geom_exec(ggplot2::geom_step,
  124.                 data = d, y = "upper", linetype = "dashed", color = surv.color,
  125.                 na.rm = TRUE)
  126.         }
  127.     }
  128.     if (censor & any(d$n.censor >= 1)) {
  129.         p <- p + ggpubr::geom_exec(ggplot2::geom_point, data = d[d$n.censor >
  130.             0, , drop = FALSE], colour = surv.color, size = size *
  131.             4.5, shape = "+")
  132.     }
  133.     if (pval & !is.null(fit$strata)) {
  134.         pval <- survminer:::.get_pvalue(fit, method = log.rank.weights, data = data)
  135.         pvaltxt <- ifelse(pval$val < 1e-04, "p < 0.0001", paste("p =",
  136.             signif(pval$val, 2)))
  137.         pval.x <- ifelse(is.null(pval.coord[1]), max(fit$time)/50,
  138.             pval.coord[1])
  139.         pval.y <- ifelse(is.null(pval.coord[2]), 0.2, pval.coord[2])
  140.         p <- p + ggplot2::annotate("text", x = pval.x, y = pval.y,
  141.             label = pvaltxt, size = pval.size, hjust = 0)
  142.         if (pval.method) {
  143.             pvalmethod <- pval$method
  144.             pval.method.x <- ifelse(is.null(pval.method.coord[1]),
  145.                 max(fit$time)/50, pval.method.coord[1])
  146.             pval.method.y <- ifelse(is.null(pval.method.coord[2]),
  147.                 0.3, pval.method.coord[2])
  148.             p <- p + ggplot2::annotate("text", x = pval.method.x,
  149.                 y = pval.method.y, label = pvalmethod, size = pval.method.size,
  150.                 hjust = 0)
  151.         }
  152.     }
  153.     if (surv.median.line %in% c("hv", "h", "v"))
  154.         p <- .add_surv_median(p, fit, type = surv.median.line,
  155.             fun = fun, data = data)
  156.     p <- p + ggplot2::expand_limits(x = 0, y = 0)
  157.     lty.leg.title <- ifelse(linetype == "strata", legend.title,
  158.         linetype)
  159.     p <- p + ggplot2::labs(x = xlab, y = ylab, title = title,
  160.         color = legend.title, fill = legend.title, linetype = lty.leg.title)
  161.     p <- survminer:::.set_general_gpar(p, legend = legend, ...)
  162.     if (!is.null(linetype.manual))
  163.         p <- p + scale_linetype_manual(values = linetype.manual)
  164.     res <- list(plot = p)
  165.     g <- ggplot_build(p)
  166.     scurve_cols <- unlist(unique(g$data[[1]]["colour"]))
  167.     if (length(scurve_cols) == 1)
  168.         scurve_cols <- rep(scurve_cols, length(legend.labs))
  169.     names(scurve_cols) <- legend.labs
  170.     if (risk.table) {
  171.         if (risk.table.pos == "in")
  172.             risk.table.col = surv.color
  173.         risktable <- myggrisktable(fit, data = data, type = risk.table.type,
  174.             color = risk.table.col, palette = palette, break.time.by = break.time.by,
  175.             xlim = xlim, title = risk.table.title, legend = legend,
  176.             legend.title = legend.title, legend.labs = legend.labs,
  177.             y.text = risk.table.y.text, y.text.col = risk.table.y.text.col,
  178.             fontsize = risk.table.fontsize, ggtheme = ggtheme,
  179.             xlab = xlab, ylab = legend.title, ...)
  180.         risktable <- risktable + tables.theme
  181.         if (!risk.table.y.text)
  182.             risktable <- survminer:::.set_large_dash_as_ytext(risktable)
  183.         if (risk.table.y.text.col)
  184.             risktable <- risktable + theme(axis.text.y = element_text(colour = rev(scurve_cols)))
  185.         res$table <- risktable
  186.     }
  187.     if (cumevents) {
  188.         res$cumevents <- ggcumevents(fit, data = data, color = cumevents.col,
  189.             palette = palette, break.time.by = break.time.by,
  190.             xlim = xlim, title = cumevents.title, legend = legend,
  191.             legend.title = legend.title, legend.labs = legend.labs,
  192.             y.text = cumevents.y.text, y.text.col = cumevents.y.text.col,
  193.             fontsize = fontsize, ggtheme = ggtheme, xlab = xlab,
  194.             ylab = legend.title, ...)
  195.         res$cumevents <- res$cumevents + tables.theme
  196.         if (!cumevents.y.text)
  197.             res$cumevents <- survminer:::.set_large_dash_as_ytext(res$cumevents)
  198.         if (cumevents.y.text.col)
  199.             res$cumevents <- res$cumevents + theme(axis.text.y = element_text(colour = rev(scurve_cols)))
  200.     }
  201.     if (ncensor.plot) {
  202.         ncensor_plot <- ggplot(d, aes_string("time", "n.censor")) +
  203.             ggpubr::geom_exec(geom_bar, d, color = surv.color,
  204.                 fill = surv.color, stat = "identity", position = "dodge") +
  205.              scale_x_continuous(breaks = times,expand = c(0, 0)) +
  206.             scale_y_continuous(breaks = sort(unique(d$n.censor)),expand = c(0, 0)) +
  207.             ggtheme
  208.         ncensor_plot <- ggpubr::ggpar(ncensor_plot, palette = palette)
  209.         ncensor_plot <- ncensor_plot + ggplot2::labs(color = legend.title,
  210.             fill = legend.title, x = xlab, y = "n.censor", title = ncensor.plot.title)
  211.         ncensor_plot <- survminer:::.set_general_gpar(ncensor_plot, ...)
  212.         ncensor_plot <- survminer:::.set_ncensorplot_gpar(ncensor_plot, ...)
  213.         ncensor_plot <- ncensor_plot + tables.theme
  214.     }
  215.     else if (cumcensor) {
  216.         ncensor_plot <- ggcumcensor(fit, data = data, color = cumcensor.col,
  217.             palette = palette, break.time.by = break.time.by,
  218.             xlim = xlim, title = cumcensor.title, legend = legend,
  219.             legend.title = legend.title, legend.labs = legend.labs,
  220.             y.text = cumcensor.y.text, y.text.col = cumcensor.y.text.col,
  221.             fontsize = fontsize, ggtheme = ggtheme, xlab = xlab,
  222.             ylab = legend.title, ...)
  223.         ncensor_plot <- ncensor_plot + tables.theme
  224.         if (!cumcensor.y.text)
  225.             ncensor_plot <- survminer:::.set_large_dash_as_ytext(ncensor_plot)
  226.         if (cumcensor.y.text.col)
  227.             ncensor_plot <- ncensor_plot + theme(axis.text.y = element_text(colour = rev(scurve_cols)))
  228.     }
  229.     if (ncensor.plot | cumcensor)
  230.         res$ncensor.plot <- ncensor_plot
  231.     heights <- list(plot = surv.plot.height, table = ifelse(risk.table,
  232.         risk.table.height, 0), ncensor.plot = ifelse(ncensor.plot |
  233.         cumcensor, ncensor.plot.height, 0), cumevents = ifelse(cumevents,
  234.         cumevents.height, 0))
  235.     y.text <- list(table = risk.table.y.text, cumevents = cumevents.y.text,
  236.         cumcensor = cumcensor.y.text)
  237.     y.text.col <- list(table = risk.table.y.text.col, cumevents = cumevents.y.text.col,
  238.         cumcensor = cumcensor.y.text.col)
  239.     res$data.survplot <- d
  240.     res$data.survtable <- survminer:::.get_timepoints_survsummary(fit, data,
  241.         times)
  242.     class(res) <- c("ggsurvplot", "ggsurv", "list")
  243.     attr(res, "heights") <- heights
  244.     attr(res, "y.text") <- y.text
  245.     attr(res, "y.text.col") <- y.text.col
  246.     attr(res, "legend.position") <- legend
  247.     attr(res, "legend.labs") <- legend.labs
  248.     attr(res, "cumcensor") <- cumcensor
  249.     attr(res, "risk.table.pos") <- risk.table.pos
  250.     res
  251. }
  252.  
  253.  
  254. myggrisktable <- function (fit, data = NULL, type = c("absolute", "percentage",
  255.     "abs_pct", "nrisk_cumcensor", "nrisk_cumevents"), color = "black",
  256.     palette = NULL, break.time.by = NULL, xlim = NULL, title = NULL,
  257.     xlab = "Time", ylab = "Strata", legend = "top", legend.title = "Strata",
  258.     legend.labs = NULL, y.text = TRUE, y.text.col = TRUE, fontsize = 4.5,
  259.     ggtheme = theme_light(), ...)
  260. {
  261.     if (!inherits(fit, "survfit"))
  262.         stop("Can't handle an object of class ", class(fit))
  263.     if (is.null(xlim))
  264.         xlim <- c(0, max(fit$time))
  265.     survminer:::.check_legend_labs(fit, legend.labs)
  266.     type <- match.arg(type)
  267.     if (is.null(title)) {
  268.         title <- switch(type, absolute = "Number at risk", percentage = "Percentage at risk",
  269.             abs_pct = "Number at risk: n (%)", nrisk_cumcensor = "Number at risk (number censored)",
  270.             nrisk_cumevents = "Number at risk (number of events)",
  271.             "Number at risk")
  272.     }
  273.     data <- survminer:::.get_data(fit, data = data)
  274.     if (is.null(break.time.by))
  275.         times <- survminer:::.get_default_breaks(fit$time)
  276.     else times <- seq(0, max(c(fit$time, xlim)), by = break.time.by)
  277.     survsummary <- survminer:::.get_timepoints_survsummary(fit, data, times)
  278.     if (!is.null(legend.labs))
  279.         survsummary$strata <- factor(survsummary$strata, labels = legend.labs)
  280.     if (is.null(legend.labs))
  281.         legend.labs <- levels(survsummary$strata)
  282.     yticklabs <- rev(levels(survsummary$strata))
  283.     n_strata <- length(levels(survsummary$strata))
  284.     if (!y.text)
  285.         yticklabs <- rep("-", n_strata)
  286.     time <- strata <- label <- pct.risk <- abs_pct.risk <- n.risk <- NULL
  287.     llabels <- switch(type, percentage = round(survsummary$n.risk *
  288.         100/survsummary$strata_size), abs_pct = paste0(survsummary$n.risk,
  289.         " (", survsummary$pct.risk, ")"), nrisk_cumcensor = paste0(survsummary$n.risk,
  290.         " (", survsummary$cum.n.censor, ")"), nrisk_cumevents = paste0(survsummary$n.risk,
  291.         " (", survsummary$cum.n.event, ")"), survsummary$n.risk)
  292.     survsummary$llabels <- llabels
  293.     p <- ggplot(data = survsummary, aes(x = time, y = rev(strata),
  294.         label = llabels, shape = rev(strata)))
  295.     p <- p + ggpubr::geom_exec(geom_text, data = survsummary,
  296.         size = fontsize, color = color) + scale_shape_manual(values = 1:length(levels(survsummary$strata))) +
  297.         ggtheme + scale_y_discrete(breaks = as.character(levels(survsummary$strata)),
  298.         labels = yticklabs) + coord_cartesian(xlim = xlim) +
  299.         scale_x_continuous(breaks = times, expand = c(0, 0)) + labs(title = title,
  300.         x = xlab, y = ylab, color = legend.title, shape = legend.title)
  301.     p <- survminer:::.set_risktable_gpar(p, ...)
  302.     p <- ggpubr::ggpar(p, legend = legend, palette = palette,
  303.         ...)
  304.     if (!y.text)
  305.         p <- .set_large_dash_as_ytext(p)
  306.     if (y.text.col) {
  307.         g <- ggplot2::ggplot_build(p)
  308.         cols <- unlist(unique(g$data[[1]]["colour"]))
  309.         if (length(cols) == 1)
  310.             cols <- rep(cols, length(legend.labs))
  311.         names(cols) <- legend.labs
  312.         p <- p + theme(axis.text.y = element_text(colour = rev(cols)))
  313.     }
  314.     p
  315. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement