R version 4.4.0 RC (2024-04-16 r86458 ucrt) -- "Puppy Cup"
Copyright (C) 2024 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> # Tests of pseudovalues, by calculating directly from survfit and residuals
> #  this assumes that residuals.survfit is correct
> library(survival)
> aeq <- function(x, y, ...) all.equal(as.vector(x), as.vector(y), ...)
> 
> mdata <- mgus2
> temp <- ifelse(mdata$pstat==1, 1, 2*mdata$death)
> mdata$event <- factor(temp, 0:2, c("censor", "pcm", "death"))
> mdata$etime <- ifelse(mdata$pstat==1, mdata$ptime, mdata$futime)
> mdata <- subset(mdata, etime > 12)  # remove first year
> tvec <- c(10, 100, 200, 365)
> 
> # Single endpoint, one curve
> fit1 <- survfit(Surv(ptime, pstat) ~1, mdata)
> # a time point before first event, after last event, at an event time,
> #  and between event times
> rr1 <- resid(fit1, tvec)
> aeq(colSums(rr1), rep(0,4))
[1] TRUE
> sv1 <- summary(fit1, time=tvec, extend=TRUE)$surv
> 
> # one time point  
> ps1a <- pseudo(fit1, time=100)
> aeq(ps1a, sv1[2] + fit1$n*rr1[,2])
[1] TRUE
> # multiple
> ps1b <- pseudo(fit1,  time=tvec)
> aeq(ps1b,  sv1[col(rr1)] + fit1$n * rr1)
[1] TRUE
> 
> # Single endpoint, multiple curves
> fit2 <- survfit(Surv(futime, death) ~ sex, mdata)
> rr2 <- resid(fit2, time=tvec)
> aeq(colSums(rr2), rep(0,4))
[1] TRUE
> sv2 <- summary(fit2, time=tvec, extend=TRUE)$surv
> sv2 <- t(matrix(sv2, ncol=2))   # row 1= female, row2 = male
> 
> # residuals are the same as for separate models
> fit2a <- survfit(Surv(futime, death) ~1, mdata, subset=( sex=='F'))
> fit2b <- survfit(Surv(futime, death) ~1, mdata, subset= (sex=='M'))
> fem <- (mdata$sex=='F')
> rr2a <- resid(fit2a, times=tvec)
> rr2b <- resid(fit2b, times=tvec)
> aeq(rr2a, rr2[fem,])  # row names won't be equal
[1] TRUE
> aeq(rr2b, rr2[!fem,])
[1] TRUE
> 
> # one time point
> ps2a <- pseudo(fit2a, time=100)
> aeq(ps2a, sv2[1,2] + fit2a$n[1]* rr2a[,2])
[1] TRUE
> ps2b <- pseudo(fit2b, time=100)
> aeq(ps2b, sv2[2,2] + fit2b$n[1]* rr2b[,2])
[1] TRUE
> 
> # overall psuedo are the same as for separate models
> #  (each row of mdata belongs to a single curve)
> ps2c <- pseudo(fit2, time=100)
> aeq(ps2c[ fem], ps2a)
[1] TRUE
> aeq(ps2c[!fem], ps2b)
[1] TRUE
> 
> # multiple time points
> ps2d <- pseudo(fit2a, times=tvec)
> aeq(ps2d, sv2[1, col(rr2a)] + fit2$n[1]* rr2a)
[1] TRUE
> ps2e <- pseudo(fit2b, times=tvec)
> aeq(ps2e, sv2[2, col(rr2b)] + fit2$n[2]* rr2b)
[1] TRUE
> 
> ps2f <- pseudo(fit2, times=tvec)
> aeq(ps2d, ps2f[ fem,])
[1] TRUE
> aeq(ps2e, ps2f[!fem,])
[1] TRUE
> 
> # Repeat the process for a multi-state model
> fit3 <- survfit(Surv(etime, event) ~ sex, mdata)
> fit3a <- survfit(Surv(etime, event) ~1, mdata, subset= (sex=='F'))
> fit3b <- survfit(Surv(etime, event) ~1, mdata, subset= (sex=='M'))
> rr3 <-  resid(fit3, times=tvec)
> aeq(apply(rr3, 2:3, sum), matrix(0,3,4)) # resids sum to 0 for each state & time
[1] TRUE
> rr3a <- resid(fit3a, times=tvec)
> rr3b <- resid(fit3b, times=tvec)
> aeq(rr3[fem,,], rr3a)
[1] TRUE
> aeq(rr3[!fem,,], rr3b)
[1] TRUE
> 
> ps3 <- pseudo(fit3, times=tvec)
> ps3a <- pseudo(fit3a, times=tvec)
> ps3b <- pseudo(fit3b, times=tvec)
> aeq(ps3[ fem,,], ps3a)
[1] TRUE
> aeq(ps3[!fem,,], ps3b)
[1] TRUE
> 
> sv3 <- summary(fit3, times=tvec, extend=TRUE)$pstate
> sv3 <- array(sv3, dim=c(4,2,3))      #times, curve, order
> # ps3a has dimensions (number obs in fit3a, 3 states, 4 timepoints)
> #  to each of the 3x4 combinations we need to add the value of the
> #  survival curve at that time.  A loop is easiest
> temp1 <- array(0, dim= dim(rr3a))
> temp2 <- array(0, dim= dim(rr3b))
> for (i in 1:3) { # each of the 3 states
+     for (j in 1:4) {  # each of the 4 times 
+         temp1[, i,j] <- sv3[j,1,i] + fit3$n[1]*rr3a[,i,j]
+         temp2[, i,j] <- sv3[j,2,i] + fit3$n[2]*rr3b[,i,j]
+     }
+ }
> aeq(temp1, ps3a)
[1] TRUE
> aeq(temp2, ps3b)
[1] TRUE
> 
> ###########################
> # All again, just the same, for cumulative hazards
> #  Though there are 2 of them, vs 3 states.
> #
> rr1 <- resid(fit1, tvec, type="cumhaz")
> aeq(colSums(rr1), rep(0,4))
[1] TRUE
> sv1 <- summary(fit1, time=tvec, extend=TRUE)$cumhaz
> 
> # one time point  
> ps1a <- pseudo(fit1, time=100, type="cumhaz")
> aeq(ps1a, sv1[2] + fit1$n*rr1[,2])
[1] TRUE
> # multiple
> ps1b <- pseudo(fit1,  time=tvec, type="cumhaz")
> aeq(ps1b,  sv1[col(rr1)] + fit1$n * rr1)
[1] TRUE
> 
> # Single endpoint, multiple curves
> fit2 <- survfit(Surv(futime, death) ~ sex, mdata)
> rr2 <- resid(fit2, time=tvec, type="cumhaz")
> aeq(colSums(rr2), rep(0,4))
[1] TRUE
> sv2 <- summary(fit2, time=tvec, extend=TRUE)$cumhaz
> sv2 <- t(matrix(sv2, ncol=2))   # row 1= female, row2 = male
> 
> # residuals are the same as for separate models
> rr2a <- resid(fit2a, times=tvec, type= "cumhaz")
> rr2b <- resid(fit2b, times=tvec, type= "cumhaz")
> aeq(rr2a, rr2[fem,])
[1] TRUE
> aeq(rr2b, rr2[!fem,])
[1] TRUE
> 
> # one time point
> ps2a <- pseudo(fit2a, time=100, type="cumhaz")
> aeq(ps2a, sv2[1,2] + fit2a$n[1]* rr2a[,2])
[1] TRUE
> ps2b <- pseudo(fit2b, time=100, type="cumhaz")
> aeq(ps2b, sv2[2,2] + fit2b$n[1]* rr2b[,2])
[1] TRUE
> 
> # overall psuedo are the same as for separate models
> #  (each row of mdata belongs to a single curve)
> ps2c <- pseudo(fit2, time=100, type="cumhaz")
> aeq(ps2c[ fem], ps2a)
[1] TRUE
> aeq(ps2c[!fem], ps2b)
[1] TRUE
> 
> # multiple time points
> ps2d <- pseudo(fit2a, times=tvec, type="cumhaz")
> aeq(ps2d, sv2[1, col(rr2a)] + fit2$n[1]* rr2a)
[1] TRUE
> ps2e <- pseudo(fit2b, times=tvec, type= "cumhaz")
> aeq(ps2e, sv2[2, col(rr2b)] + fit2$n[2]* rr2b)
[1] TRUE
> 
> ps2f <- pseudo(fit2, times=tvec, type="cumhaz")
> aeq(ps2d, ps2f[ fem,])
[1] TRUE
> aeq(ps2e, ps2f[!fem,])
[1] TRUE
> 
> # Repeat the process for a multi-state model
> rr3 <-  resid(fit3, times=tvec, type="cumhaz")
> aeq(apply(rr3, 2:3, sum), matrix(0, 2,4))
[1] TRUE
> rr3a <- resid(fit3a, times=tvec, type="cumhaz")
> rr3b <- resid(fit3b, times=tvec, type="cumhaz")
> aeq(rr3[fem,,], rr3a)
[1] TRUE
> aeq(rr3[!fem,,], rr3b)
[1] TRUE
> 
> ps3 <- pseudo(fit3, times=tvec, type="cumhaz")
> ps3a <- pseudo(fit3a, times=tvec, type="cumhaz")
> ps3b <- pseudo(fit3b, times=tvec, type="cumhaz")
> aeq(ps3[ fem,,], ps3a)
[1] TRUE
> aeq(ps3[!fem,,], ps3b)
[1] TRUE
> 
> sv3 <- summary(fit3, times=tvec, extend=TRUE)$cumhaz
> sv3 <- array(sv3, dim=c(4,2,2))      #times, curve, hazard
> # ps3a has dimensions (number obs in fit3a, 4 timepoints, 3 states)
> #  to each of the 4x3 combinations we need to add the value of the
> #  survival curve at that time.  A loop is easiest
> temp1 <- array(0, dim= dim(rr3a))
> temp2 <- array(0, dim= dim(rr3b))
> for (i in 1:2) { # each of the 2 hazard
+     for (j in 1:4) {  # each of the 4 timepoints
+         temp1[, i,j] <- sv3[j,1,i] + fit3$n[1]*rr3a[,i,j]
+         temp2[, i,j] <- sv3[j,2,i] + fit3$n[2]*rr3b[,i,j]
+     }
+ }
> aeq(temp1, ps3a)
[1] TRUE
> aeq(temp2, ps3b)
[1] TRUE
> 
> #################################################
> # Last, one more time with AUC
> #  A bit more bother, since summary.survfit only returns AUC for one time
> #   value at a time.  It also does not like times before the first event
> #
> tvec <- tvec[2:4]
> 
> rr1 <- resid(fit1, tvec, type="auc")
> aeq(colSums(rr1), rep(0,3))
[1] TRUE
> afun <- function(fit, times) {
+     ntime <- length(times)
+     if (length(fit$strata)) xfun <- function(x) x$table[, "rmean"]
+         else xfun <- function(x) x$table["rmean"]
+ 
+     temp <- xfun(summary(fit, rmean=times[1]))
+     if (ntime==1) return(temp)
+     
+     result <- matrix(0, ntime, length(temp))
+     result[1,] <- temp
+     for (i in 2:ntime) 
+         result[i,] <- xfun(summary(fit, rmean=times[i]))
+     drop(result)
+ }
>     
> sv1 <- afun(fit1, tvec)
> 
> # one time point  
> ps1a <- pseudo(fit1, time=tvec[1], type="auc")
> aeq(ps1a, sv1[1] + fit1$n*rr1[,1])
[1] TRUE
> # multiple
> ps1b <- pseudo(fit1,  time=tvec, type="auc")
> aeq(ps1b,  sv1[col(rr1)] + fit1$n * rr1)
[1] TRUE
> 
> # Single endpoint, multiple curves
> rr2 <- resid(fit2, time=tvec, type="auc")
> sv2 <- t(afun(fit2, tvec))
> aeq(colSums(rr2), rep(0,3))
[1] TRUE
> 
> # residuals are the same as for separate models
> rr2a <- resid(fit2a, times=tvec, type= "auc")
> rr2b <- resid(fit2b, times=tvec, type= "auc")
> aeq(rr2a, rr2[fem,])
[1] TRUE
> aeq(rr2b, rr2[!fem,])
[1] TRUE
> 
> # one time point
> ps2a <- pseudo(fit2a, time=100, type="auc")
> aeq(ps2a, sv2[1,1] + fit2a$n[1]* rr2a[,1])
[1] TRUE
> ps2b <- pseudo(fit2b, time=100, type="auc")
> aeq(ps2b, sv2[2,1] + fit2b$n[1]* rr2b[,1])
[1] TRUE
> 
> # overall psuedo are the same as for separate models
> #  (each row of mdata belongs to a single curve)
> ps2c <- pseudo(fit2, time=100, type="auc")
> aeq(ps2c[ fem], ps2a)
[1] TRUE
> aeq(ps2c[!fem], ps2b)
[1] TRUE
> 
> # multiple time points
> ps2d <- pseudo(fit2a, times=tvec, type="auc")
> aeq(ps2d, sv2[1, col(rr2a)] + fit2$n[1]* rr2a)
[1] TRUE
> ps2e <- pseudo(fit2b, times=tvec, type= "auc")
> aeq(ps2e, sv2[2, col(rr2b)] + fit2$n[2]* rr2b)
[1] TRUE
> 
> ps2f <- pseudo(fit2, times=tvec, type="auc")
> aeq(ps2d, ps2f[ fem,])
[1] TRUE
> aeq(ps2e, ps2f[!fem,])
[1] TRUE
> 
> # Repeat the process for a multi-state model
> rr3 <-  resid(fit3, times=tvec, type="auc")
> aeq(apply(rr3, 2:3, sum), matrix(0, 3,3))
[1] TRUE
> rr3a <- resid(fit3a, times=tvec, type="auc")
> rr3b <- resid(fit3b, times=tvec, type="auc")
> aeq(rr3[fem,,], rr3a)
[1] TRUE
> aeq(rr3[!fem,,], rr3b)
[1] TRUE
> 
> ps3 <- pseudo(fit3, times=tvec, type="auc")
> ps3a <- pseudo(fit3a, times=tvec, type="auc")
> ps3b <- pseudo(fit3b, times=tvec, type="auc")
> aeq(ps3[ fem,,], ps3a)
[1] TRUE
> aeq(ps3[!fem,,], ps3b)
[1] TRUE
> 
> sv3 <- rbind(summary(fit3, rmean=tvec[1])$table[,"rmean"],
+              summary(fit3, rmean=tvec[2])$table[,"rmean"],
+              summary(fit3, rmean=tvec[3])$table[,"rmean"])
> sv3 <- array(sv3, dim=c(3,2,3))      #times, curve, state
> # ps3a has dimensions (number obs in fit3a, 4 timepoints, 3 states)
> #  to each of the 4x3 combinations we need to add the value of the
> #  survival curve at that time.  A loop is easiest
> temp1 <- array(0, dim= dim(rr3a))
> temp2 <- array(0, dim= dim(rr3b))
> for (i in 1:3) { # each of the 3 states
+     for (j in 1:3) {  # each of the 3 times
+         temp1[, i,j] <- sv3[j,1,i] + fit3$n[1]*rr3a[,i,j]
+         temp2[, i,j] <- sv3[j,2,i] + fit3$n[2]*rr3b[,i,j]
+     }
+ }
> aeq(temp1, ps3a)
[1] TRUE
> aeq(temp2, ps3b)
[1] TRUE
> 
> #
> # a data set with a missing value, and with a group that has only one obs
> #  a good test of edge cases
> #
> lfit1 <- survfit(Surv(time, status) ~ ph.ecog, lung)
> # This will warn about points beyond the curve; ph.ecog==3 has a single point
> # at time=118, and it will have one fewer obs than the data
> p1 <- pseudo(lfit1, times=c(100, 200))
Warning message:
In pseudo(lfit1, times = c(100, 200)) :
  requested time points are beyond the end of one or more curves
> aeq(dim(p1), c(nrow(lung)-1, 2))
[1] TRUE
> 
> 
> # This will have rows that match the data
> lfit2 <- survfit(Surv(time, status) ~ ph.ecog, lung, na.action= na.exclude)
> p2 <- pseudo(lfit2, time=c(100, 200))
Warning message:
In pseudo(lfit2, time = c(100, 200)) :
  requested time points are beyond the end of one or more curves
> aeq(dim(p2), c(nrow(lung), 2))
[1] TRUE
> all(is.na(p2[is.na(lung$ph.ecog)]))  # a row of missing was inserted
[1] TRUE
> 
> row3 <- which(!is.na(lung$ph.ecog) & lung$ph.ecog ==3)  # the singleton row
> all(p2[row3,] == c(1, 0))
[1] TRUE
> 
> 
> proc.time()
   user  system elapsed 
   1.29    0.12    1.40