用删减表创建一个ggplot2生存曲线 [英] Create a ggplot2 survival curve with censored table
本文介绍了用删减表创建一个ggplot2生存曲线的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
$ （肺，{b1，b2，b3，b3，b3，b3，b3，b3，b3）的数据（肺，包=存活）b $ b
sex < - factor（sex，labels = c（'male'，'female'））
}）
ggthemes_data < - ggthemes :: ggthemes_data
require（ （数据帧（x =肺$时间，y =肺$状态，z =肺$性））
.df < - .df。 - .df [do.call（order，.df [，c（z，x），drop = FALSE]），drop = FALSE]
.fit< - survival :: survfit（survival :: Surv（time = x，event = y，type =right）〜z，
.df）
.pval < - plyr :: ddply（.df，plyr ::。（），
函数（x）{
data.frame（
x = 0，y = 0，df = 1，
chisq = survival :: survdiff（
survival :: Surv（time = x，event = y，type =right）〜z，x
）$ chisq
）}）
.pval $ label< - paste0（
paste（italic（p），\=，
signif（1 - pchisq（.p） val $ chisq，.pval $ df），3），
\）
）
.fit< - data.frame（x = .fit $ time，y = .fit $ surv，nrisk = .fit $ n.risk，nevent =
.fit $ n.event，ncensor = .fit $ n.censor，upper = .fit $ upper，lower = .fit $ lower） $ b $ .df < - .df [！duplicated（.df [，c（x，z）]），]
.df< - .fit< - data.frame （.fit，.df [，c（z），drop = FALSE]）
.med < - plyr :: ddply（.fit，plyr ::。（z），function（x）{
data.frame（
median = min（subset（x，y< （0.5 + .Machine $ double.eps ^ 0.5））$ x）
）}）
.df< - .fit< - rbind（unique（data.frame（x = 0，y = 1，nrisk = NA，nevent = NA，
ncensor = NA，upper = 1，lower = 1，.df [，c（z），drop = FALSE]）），.fit）
.cens< - subset（.fit，ncensor == 1）
.tmp1< - data.frame（as.table（by（.df，.df [，c（z）， （d）
max（d $ nrisk，na.rm = TRUE））））
.tmp1 $ x < - 0
.nrisk < - 。 （1：9）中的tmp1
{.df < - 子集（.fit，x <100 * i）; .tmp2 < -
data.frame（as.table（by（.df，.df [，c（z），drop = FALSE），函数（d）if
（all is.na（d $ nrisk）））NA else min（d $ nrisk - d $ nevent - d $ ncensor，na.rm = TRUE））））;
.tmp2 $ x< - 100 * i; .tmp2 $ Freq [is.na（.tmp2 $ Freq）] < - .tmp1 $ Freq [is.na（.tmp2 $ Freq）];
.tmp1< - .tmp2; .nrisk < - rbind（.nrisk，.tmp2）}
.nrisk $ y < - rep（seq（0.075,0.025，-0.05），10）
.plot < - ggplot（ data = .fit，aes（x = x，y = y，color = z））+
RcmdrPlugin.KMggplot2 :: geom_stepribbon（data = .fit，aes（x = x，ymin = lower，ymax =
upper，fill = z），alpha = 0.25，color =transparent，show.legend = FALSE，kmplot
= TRUE）+ geom_step（size = 1.5）+
geom_linerange（data = .cens，aes（x = x，ymin = y，
ymax = y + 0.02），size = 1.5）+
geom_text（data = .pval，aes（y = y，x = x， label =
label），color =black，hjust = 0，vjust = -0.5，parse = TRUE，show.legend =
FALSE，size = 14 * 0.282，family =sans） +
geom_vline（data = .med，aes（xintercept
= median），color =black，lty = 2）+ scale_x_continuous（breaks = seq（0，900，by
= 100），limits = c（0,900））+
scale_y_continuous（limits = c（0,1），expand = c（0.01,0））+ scale_colour_brewer（palette =Set1）+ scale_f ill_brewer（palette =Set1）+
xlab（从入门开始的时间）+ ylab（生存比例）+ labs（color =sex）+
ggthemes :: theme_calc（base_size = 1，base_family =sans）+主题（legend.position
= c（1,1），legend.justification = c（1,1））
.nrisk $ y < - （.nrisk $ y - 0.025）/（max（.nrisk $ y） - 0.025）+0.5）* 0.5
.plot2 < - ggplot（data = .nrisk，aes（x = x，y = y ，label = Freq，color = z））+
geom_text（size = 14 * 0.282，family =sans）+ scale_x_continuous（breaks = seq（0,900，by = 100），limits = c（0，900 ）+
scale_y_continuous（limits = c（0，1））+
scale_colour_brewer（palette =Set1）+ ylab（生存比例）+
RcmdrPlugin.KMggplot2 :: theme_natrisk（ggthemes :: theme_calc，14，sans）
.plot3 < - ggplot（data = subset（.nrisk，x == 0），aes（x = x，y = y，label = z ，color = z））+
geom_text（hjust = 0，size = 14 * 0.282，family =sans）+
scale_x_continuous（limits = c（-5，5 ））+ scale_y_continuous（limits = c（0，1））+
scale_colour_brewer（palette =Set1）+
RcmdrPlugin.KMggplot2 :: theme_natrisk21（ggthemes :: theme_calc，14，sans）
.plotb <-ggplot（.df，aes（x = x，y = y））+ geom_blank（）+
RcmdrPlugin.KMggplot2 :: theme_natriskbg（ggthemes :: theme_calc，14，sans ）
grid :: grid.newpage（）; grid :: pushViewport（grid :: viewport（layout =
grid :: grid.layout（2，2，heights = unit（c（1,3），c（null，lines））， widths =
unit（c（4，1），c（lines，null）））））;
print（.plotb，vp =
grid :: viewport（layout.pos.row = 1：2，layout.pos.col = 1：2））;
print（.plot，vp =
grid :: viewport（layout.pos.row = 1，layout.pos.col = 1：2））;
print（.plot2，vp =
grid :: viewport（layout.pos.row = 2，layout.pos.col = 1：2））;
print（.plot3，vp =
grid :: viewport（layout.pos.row = 2，layout.pos.col = 1））;
.plot< - recordPlot（）
print（.plot）
I am trying to create a Kaplan-Meier plot with 95% confidence bands plus having the censored data in a table beneath it. I can create the plot, but not the table. I get the error message: Error in grid.draw(both) : object 'both' not found.
library(survival)
library(ggplot2)
library(GGally)
library(gtable)
data(lung)
sf.sex <- survfit(Surv(time, status) ~ sex, data = lung)
pl.sex <- ggsurv(sf.sex) +
geom_ribbon(aes(ymin=low,ymax=up,fill=group),alpha=0.3) +
guides(fill=guide_legend("sex"))
pl.sex
tbl <- ggplot(df_nums, aes(x = Time, y = factor(variable), colour = variable,+
label=value)) +
geom_text() +
theme_bw() +
theme(panel.grid.major = element_blank(),+
legend.position = "none",+
plot.background = element_blank(), +
panel.grid.major = element_blank(),+
panel.grid.minor = element_blank(),+
panel.border = element_blank(),+
legend.position="none",+
axis.line = element_blank(),+
axis.text.x = element_blank(),+
axis.text.y = element_text(size=15, face="bold", color = 'black'),+
axis.ticks=element_blank(),+
axis.title.x = element_blank(),+
axis.title.y = element_blank(),+
plot.title = element_blank()) +
scale_y_discrete(breaks=c("Group.A", "Group.B"), labels=c("Group A", "Group B"))
both = rbind(ggplotGrob(g), ggplotGrob(tbl), size="last")
panels <- both$layout$t[grep("panel", both$layout$name)]
both$heights[panels] <- list(unit(1,"null"), unit(2, "lines"))
both <- gtable_add_rows(both, heights = unit(1,"line"), 8)
both <- gtable_add_grob(both, textGrob("Number at risk", hjust=0, x=0), t=9, l=2, r=4)
grid.newpage()
grid.draw(both)
解决方案
I solved the problem by using the Rcmdrplugin KMggplot2 The code is generated by the plugin after selecting the data and variables.
library(survival, pos=18)
data(lung, package="survival")
lung <- within(lung, {
sex <- factor(sex, labels=c('male','female'))
})
ggthemes_data <- ggthemes::ggthemes_data
require("ggplot2")
.df <- na.omit(data.frame(x = lung$time, y = lung$status, z = lung$sex))
.df <- .df[do.call(order, .df[, c("z", "x"), drop = FALSE]), , drop = FALSE]
.fit <- survival::survfit(survival::Surv(time = x, event = y, type = "right") ~ z,
.df)
.pval <- plyr::ddply(.df, plyr::.(),
function(x) {
data.frame(
x = 0, y = 0, df = 1,
chisq = survival::survdiff(
survival::Surv(time = x, event = y, type = "right") ~ z, x
)$chisq
)})
.pval$label <- paste0(
"paste(italic(p), \" = ",
signif(1 - pchisq(.pval$chisq, .pval$df), 3),
"\")"
)
.fit <- data.frame(x = .fit$time, y = .fit$surv, nrisk = .fit$n.risk, nevent =
.fit$n.event, ncensor= .fit$n.censor, upper = .fit$upper, lower = .fit$lower)
.df <- .df[!duplicated(.df[,c("x", "z")]), ]
.df <- .fit <- data.frame(.fit, .df[, c("z"), drop = FALSE])
.med <- plyr::ddply(.fit, plyr::.(z), function(x) {
data.frame(
median = min(subset(x, y < (0.5 + .Machine$double.eps^0.5))$x)
)})
.df <- .fit <- rbind(unique(data.frame(x = 0, y = 1, nrisk = NA, nevent = NA,
ncensor = NA, upper = 1, lower = 1, .df[, c("z"), drop = FALSE])), .fit)
.cens <- subset(.fit, ncensor == 1)
.tmp1 <- data.frame(as.table(by(.df, .df[, c("z"), drop = FALSE], function(d)
max(d$nrisk, na.rm = TRUE))))
.tmp1$x <- 0
.nrisk <- .tmp1
for (i in 1:9) {.df <- subset(.fit, x < 100 * i); .tmp2 <-
data.frame(as.table(by(.df, .df[, c("z"), drop = FALSE], function(d) if
(all(is.na(d$nrisk))) NA else min(d$nrisk - d$nevent - d$ncensor, na.rm = TRUE))));
.tmp2$x <- 100 * i; .tmp2$Freq[is.na(.tmp2$Freq)] <- .tmp1$Freq[is.na(.tmp2$Freq)];
.tmp1 <- .tmp2; .nrisk <- rbind(.nrisk, .tmp2)}
.nrisk$y <- rep(seq(0.075, 0.025, -0.05), 10)
.plot <- ggplot(data = .fit, aes(x = x, y = y, colour = z)) +
RcmdrPlugin.KMggplot2::geom_stepribbon(data = .fit, aes(x = x, ymin = lower, ymax =
upper, fill = z), alpha = 0.25, colour = "transparent", show.legend = FALSE, kmplot
= TRUE) + geom_step(size = 1.5) +
geom_linerange(data = .cens, aes(x = x, ymin = y,
ymax = y + 0.02), size = 1.5) +
geom_text(data = .pval, aes(y = y, x = x, label =
label), colour = "black", hjust = 0, vjust = -0.5, parse = TRUE, show.legend =
FALSE, size = 14 * 0.282, family = "sans") +
geom_vline(data = .med, aes(xintercept
= median), colour = "black", lty = 2) + scale_x_continuous(breaks = seq(0, 900, by
= 100), limits = c(0, 900)) +
scale_y_continuous(limits = c(0, 1), expand = c(0.01,0)) + scale_colour_brewer(palette = "Set1") + scale_fill_brewer(palette = "Set1") +
xlab("Time from entry") + ylab("Proportion of survival") + labs(colour = "sex") +
ggthemes::theme_calc(base_size = 14, base_family = "sans") + theme(legend.position
= c(1, 1), legend.justification = c(1, 1))
.nrisk$y <- ((.nrisk$y - 0.025) / (max(.nrisk$y) - 0.025) + 0.5) * 0.5
.plot2 <- ggplot(data = .nrisk, aes(x = x, y = y, label = Freq, colour = z)) +
geom_text(size = 14 * 0.282, family = "sans") + scale_x_continuous(breaks = seq(0,900, by = 100), limits = c(0, 900)) +
scale_y_continuous(limits = c(0, 1)) +
scale_colour_brewer(palette = "Set1") + ylab("Proportion of survival") +
RcmdrPlugin.KMggplot2::theme_natrisk(ggthemes::theme_calc, 14, "sans")
.plot3 <- ggplot(data = subset(.nrisk, x == 0), aes(x = x, y = y, label = z, colour = z)) +
geom_text(hjust = 0, size = 14 * 0.282, family = "sans") +
scale_x_continuous(limits = c(-5, 5)) + scale_y_continuous(limits = c(0, 1)) +
scale_colour_brewer(palette = "Set1") +
RcmdrPlugin.KMggplot2::theme_natrisk21(ggthemes::theme_calc, 14, "sans")
.plotb <- ggplot(.df, aes(x = x, y = y)) + geom_blank() +
RcmdrPlugin.KMggplot2::theme_natriskbg(ggthemes::theme_calc, 14, "sans")
grid::grid.newpage(); grid::pushViewport(grid::viewport(layout =
grid::grid.layout(2, 2, heights = unit(c(1, 3), c("null", "lines")), widths =
unit(c(4, 1), c("lines", "null")))));
print(.plotb, vp =
grid::viewport(layout.pos.row = 1:2, layout.pos.col = 1:2));
print(.plot , vp =
grid::viewport(layout.pos.row = 1 , layout.pos.col = 1:2));
print(.plot2, vp =
grid::viewport(layout.pos.row = 2 , layout.pos.col = 1:2));
print(.plot3, vp =
grid::viewport(layout.pos.row = 2 , layout.pos.col = 1 ));
.plot <- recordPlot()
print(.plot)
这篇关于用删减表创建一个ggplot2生存曲线的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
