独自の geom
私も自分のパッケージで独自の geom を作ってみました。
Kaplan-Meier plot という階段状の図を作図するコンポーネントで、信頼区間も階段状に帯の様に表示したかったので、geom_ribbon を継承し、前処理を少し加えたものを作成しました。
@seealso
@param
@examples
@rdname
@importFrom
@export
geom_stepribbon <- function(
mapping = NULL, data = NULL, stat = "identity", position = "identity",
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, kmplot = FALSE, ...) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomStepribbon,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
kmplot = kmplot,
...
)
)
}
@rdname
@format
@usage
@export
GeomStepribbon <- ggproto(
"GeomStepribbon", GeomRibbon,
extra_params = c("na.rm", "kmplot"),
draw_group = function(data, panel_scales, coord, na.rm = FALSE) {
if (na.rm) data <- data[complete.cases(data[c("x", "ymin", "ymax")]), ]
data <- rbind(data, data)
data <- data[order(data$x), ]
data$x <- c(data$x[2:nrow(data)], NA)
data <- data[complete.cases(data["x"]), ]
GeomRibbon$draw_group(data, panel_scales, coord, na.rm = FALSE)
},
setup_data = function(data, params) {
if (params$kmplot) {
data <- data[order(data$PANEL, data$group, data$x), ]
tmpmin <- tmpmax <- NA
for (i in 1:nrow(data)) {
if (is.na(data$ymin[i])) {
data$ymin[i] <- tmpmin
}
if (is.na(data$ymax[i])) {
data$ymax[i] <- tmpmax
}
tmpmin <- data$ymin[i]
tmpmax <- data$ymax[i]
}
}
data
}
)
geom_stepribbon
継承しているため、ほぼ geom_ribbon のコピーですが、kmplot という引数を追加しています。
これは、survival パッケージの survfit という関数を内部で利用していて、この関数の出力を使う場合の例外処理の有無を指定できるようにしたかったので入れました。
GeomStepribbon
実際に処理している本体の部分です。
ggproto(`_class` = NULL, `_inherit` = NULL, ...) となっていて、ひとつ目の引数がクラス名、ふたつ目が継承するオブジェクトなので、GeomRibbon を継承しています、geom を一から作成する場合は Geom を継承すれば良いと思います。extra_params は追加引数名の指定です。geom_xxx の方で追加引数を入れた場合はここで指定していないとエラーになります。draw_group は描画処理の部分ですが、今回はここで前処理をして GeomRibbon$draw_group を呼んでいます。setup_data はデータのセットアップ処理の部分です、今回はここに例外処理を入れています。
実際には、Geom 内部で順番に継承している他の処理と上述の処理が呼ばれていくのですが、今回は一部で事足りてしまいました。
今後は今回触れていない部分を勉強してみようと思っています。
出力例
出力は、geom_stepribbon または以下のようになりました。
require("ggplot2")
data(dataKm, package = "RcmdrPlugin.KMggplot2")
.df <- na.omit(data.frame(x = dataKm$time, y = dataKm$event, z = dataKm$trt))
.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)
.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])
.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)
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) +
scale_x_continuous(breaks = seq(0, 21, by = 7), limits = c(0, 21)) +
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 = "trt") +
theme_bw(base_size = 14, base_family = "sans") +
theme(legend.position = "right")
因みに、geom_ribbon では帯は折れ線状につながるので geom_line と同じ感じです。
今回の、geom_stepribbon はある意味で geom_step と合わせて使うために作っています。
あと、geom_stepribbon の引数で colour = "transparent" とすると帯の端が透明にならないため、次のバージョンアップで colour = NA にでも変えようかと思っています。
