From 01e0fe5a5e346cf3e72eb340616d1ad57fc340e7 Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Mon, 17 Jun 2024 01:34:01 +0200 Subject: [PATCH 1/8] fix `n.risk` at `time == 0` when `nlevels(strata) > 1` --- R/fortify_surv.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/fortify_surv.R b/R/fortify_surv.R index 96e0182..719cc24 100644 --- a/R/fortify_surv.R +++ b/R/fortify_surv.R @@ -66,7 +66,12 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, # connect to the origin for plotting if (surv.connect) { - base <- d[1, ] + if ('strata' %in% colnames(d)) { + base <- d[d$time == ave(d$time, d$strata, FUN = min), ] + } + if ('event' %in% colnames(d)) { + base <- d[1, ] + } # cumhaz is for survfit.cox cases base[intersect(c('time', 'n.event', 'n.censor', 'std.err', 'cumhaz'), colnames(base))] <- 0 if ('pstate' %in% colnames(d)) { @@ -76,7 +81,6 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, } if ('strata' %in% colnames(d)) { strata <- levels(d$strata) - base <- base[rep(seq_len(nrow(base)), length(strata)), ] rownames(base) <- NULL base$strata <- strata base$strata <- factor(base$strata, levels = base$strata) From 92bc773e51f66d5a116bc8d004264ba7a9276fe1 Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Tue, 18 Jun 2024 12:25:14 +0200 Subject: [PATCH 2/8] add test for 01e0fe5 --- tests/testthat/test-surv.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/testthat/test-surv.R b/tests/testthat/test-surv.R index 99c43af..e3cb195 100644 --- a/tests/testthat/test-surv.R +++ b/tests/testthat/test-surv.R @@ -260,3 +260,17 @@ test_that('fortify.survfit regular expression for renaming strata works with mul 'std.err', 'upper', 'lower', 'strata') expect_equal(names(fortified), expected_names) }) + +test_that('n.risk at time == 0 is correct in fortify.survfit(*, surv.connect = TRUE) (#229)', { + skip_if_not_installed("survival") + library(survival) + fit <- survfit(Surv(time, status) ~ x, data = aml) + + sfit <- unclass(summary(fit)) + sfit_n <- sfit$n.risk[sfit$time == ave(sfit$time, sfit$strata, FUN = min)] + + ggfit <- fortify.survfit2(fit, surv.connect = TRUE) + ggfit_n <- ggfit[ggfit$time == 0, "n.risk"] + + expect_equal(sfit_n, ggfit_n) +}) From 531dcd0e33259ddc8f2165105067a06b7dd961be Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Tue, 18 Jun 2024 18:56:03 +0200 Subject: [PATCH 3/8] clean up for 01e0fe5 --- R/fortify_surv.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/fortify_surv.R b/R/fortify_surv.R index 719cc24..46ce174 100644 --- a/R/fortify_surv.R +++ b/R/fortify_surv.R @@ -80,9 +80,8 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, base[c('surv', 'upper', 'lower')] <- 1.0 } if ('strata' %in% colnames(d)) { - strata <- levels(d$strata) rownames(base) <- NULL - base$strata <- strata + base$strata <- levels(d$strata) base$strata <- factor(base$strata, levels = base$strata) } if ('event' %in% colnames(d)) { From d5510b4be5e84678ce58ebb9c1a2fed50d353424 Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Wed, 19 Jun 2024 12:11:29 +0200 Subject: [PATCH 4/8] more clean up for 01e0fe5 --- R/fortify_surv.R | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/R/fortify_surv.R b/R/fortify_surv.R index 46ce174..c378070 100644 --- a/R/fortify_surv.R +++ b/R/fortify_surv.R @@ -79,19 +79,14 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, } else { base[c('surv', 'upper', 'lower')] <- 1.0 } - if ('strata' %in% colnames(d)) { - rownames(base) <- NULL - base$strata <- levels(d$strata) - base$strata <- factor(base$strata, levels = base$strata) - } if ('event' %in% colnames(d)) { events <- levels(d$event) base <- base[rep(seq_len(nrow(base)), length(events)), ] - rownames(base) <- NULL base$event <- events base$event <- factor(base$event, levels = events) base[base$event == 'any', c('pstate', 'upper', 'lower')] <- 1.0 } + rownames(base) <- NULL d <- rbind(base, d) } From 7277152c8664463545055908652573c5e79b5ddf Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Thu, 20 Jun 2024 12:33:31 +0200 Subject: [PATCH 5/8] fix `n.risk` at `time == 0` for `"survfitms"` --- R/fortify_surv.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/fortify_surv.R b/R/fortify_surv.R index c378070..6ed6665 100644 --- a/R/fortify_surv.R +++ b/R/fortify_surv.R @@ -70,7 +70,7 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, base <- d[d$time == ave(d$time, d$strata, FUN = min), ] } if ('event' %in% colnames(d)) { - base <- d[1, ] + base <- d[d$time == ave(d$time, d$event, FUN = min), ] } # cumhaz is for survfit.cox cases base[intersect(c('time', 'n.event', 'n.censor', 'std.err', 'cumhaz'), colnames(base))] <- 0 @@ -80,11 +80,7 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, base[c('surv', 'upper', 'lower')] <- 1.0 } if ('event' %in% colnames(d)) { - events <- levels(d$event) - base <- base[rep(seq_len(nrow(base)), length(events)), ] - base$event <- events - base$event <- factor(base$event, levels = events) - base[base$event == 'any', c('pstate', 'upper', 'lower')] <- 1.0 + base[base$event == 'any', c('pstate', 'upper', 'lower')] <- 1.0 } rownames(base) <- NULL d <- rbind(base, d) From 906ad32219c839e25c0b803058e4b0358ae589cf Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Thu, 20 Jun 2024 13:14:27 +0200 Subject: [PATCH 6/8] coding style in `fortify.survfit()` --- R/fortify_surv.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/fortify_surv.R b/R/fortify_surv.R index 6ed6665..cbf10a2 100644 --- a/R/fortify_surv.R +++ b/R/fortify_surv.R @@ -19,7 +19,7 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, fun = NULL, ...) { # survival package >= v3.6.1 - if (length(dim(model$n.censor)) == 2) { + if (is.matrix(model$n.censor)) { model$n.censor <- rowSums(model$n.censor) } d <- data.frame(time = model$time, @@ -30,16 +30,16 @@ fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, upper = model$upper, lower = model$lower) - if (is(model, 'survfit.cox')) { + if (inherits(model, 'survfit.cox')) { d <- cbind_wraps(d, data.frame(surv = model$surv, cumhaz = model$cumhaz)) - } else if (is(model, 'survfit')) { - if (is(model, 'survfitms')) { + } else if (inherits(model, 'survfit')) { + if (inherits(model, 'survfitms')) { d <- cbind_wraps(d, data.frame(pstate = model$pstate)) varying.names <- c('n.risk', 'n.event', 'pstate', 'std.err', 'upper', 'lower') - varying.i <- lapply(varying.names, function(x) which(startsWith(colnames(d), x))) + varying.i <- lapply(varying.names, grep, colnames(d)) d <- reshape(d, varying = varying.i, v.names = varying.names, timevar = NULL, direction = 'long') - d <- suppressWarnings(subset(d, select = -c(id))) + d <- d[!names(d) %in% "id"] rownames(d) <- NULL if (length(model$states) > 1) { From 973b124faff6a548fdeb2cf05164a1f2f2180c33 Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Thu, 20 Jun 2024 15:20:07 +0200 Subject: [PATCH 7/8] add test for 7277152 and clean up --- tests/testthat/test-surv.R | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-surv.R b/tests/testthat/test-surv.R index e3cb195..0e53c3b 100644 --- a/tests/testthat/test-surv.R +++ b/tests/testthat/test-surv.R @@ -264,13 +264,17 @@ test_that('fortify.survfit regular expression for renaming strata works with mul test_that('n.risk at time == 0 is correct in fortify.survfit(*, surv.connect = TRUE) (#229)', { skip_if_not_installed("survival") library(survival) + fit <- survfit(Surv(time, status) ~ x, data = aml) + fit_surv <- summary(fit) + fit_surv <- fit_surv$n.risk[fit_surv$time == ave(fit_surv$time, fit_surv$strata, FUN = min)] + fit_gg <- fortify.survfit(fit, surv.connect = TRUE) + fit_gg <- fit_gg[fit_gg$time == 0, "n.risk"] + expect_equal(fit_surv, fit_gg) - sfit <- unclass(summary(fit)) - sfit_n <- sfit$n.risk[sfit$time == ave(sfit$time, sfit$strata, FUN = min)] - - ggfit <- fortify.survfit2(fit, surv.connect = TRUE) - ggfit_n <- ggfit[ggfit$time == 0, "n.risk"] - - expect_equal(sfit_n, ggfit_n) + fitMS <- survfit(Surv(start, stop, event) ~ 1, id = id, data = mgus1) + fitMS_surv <- unname(fitMS$n.risk[1, ]) + fitMS_gg <- fortify.survfit(fitMS, surv.connect = TRUE) + fitMS_gg <- fitMS_gg[fitMS_gg$time == 0, "n.risk"] + expect_equal(fitMS_surv, fitMS_gg) }) From b3f60c87b866c597f4b2a97a20e77b8ffd7b7548 Mon Sep 17 00:00:00 2001 From: Thomas Soeiro Date: Fri, 21 Jun 2024 22:52:05 +0200 Subject: [PATCH 8/8] fix `n.cencor` for `"survfitms"` --- R/fortify_surv.R | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) diff --git a/R/fortify_surv.R b/R/fortify_surv.R index cbf10a2..ffea376 100644 --- a/R/fortify_surv.R +++ b/R/fortify_surv.R @@ -18,30 +18,29 @@ #' @export fortify.survfit <- function(model, data = NULL, surv.connect = FALSE, fun = NULL, ...) { - # survival package >= v3.6.1 - if (is.matrix(model$n.censor)) { - model$n.censor <- rowSums(model$n.censor) + if (inherits(model, 'survfitms')) { + d <- data.frame(time = model$time, + n.risk = c(model$n.risk), + n.event = c(model$n.event), + n.censor = c(model$n.censor), + pstate = c(model$pstate), + std.err = c(model$std.err), + upper = c(model$upper), + lower = c(model$lower)) + } else { + d <- data.frame(time = model$time, + n.risk = model$n.risk, + n.event = model$n.event, + n.censor = model$n.censor, + std.err = model$std.err, + upper = model$upper, + lower = model$lower) } - d <- data.frame(time = model$time, - n.risk = model$n.risk, - n.event = model$n.event, - n.censor = model$n.censor, - std.err = model$std.err, - upper = model$upper, - lower = model$lower) - + if (inherits(model, 'survfit.cox')) { d <- cbind_wraps(d, data.frame(surv = model$surv, cumhaz = model$cumhaz)) } else if (inherits(model, 'survfit')) { if (inherits(model, 'survfitms')) { - d <- cbind_wraps(d, data.frame(pstate = model$pstate)) - - varying.names <- c('n.risk', 'n.event', 'pstate', 'std.err', 'upper', 'lower') - varying.i <- lapply(varying.names, grep, colnames(d)) - d <- reshape(d, varying = varying.i, v.names = varying.names, timevar = NULL, direction = 'long') - d <- d[!names(d) %in% "id"] - rownames(d) <- NULL - if (length(model$states) > 1) { ev.names <- model$states ev.names[ev.names == ''] <- 'any'