293 lines
10 KiB
Plaintext
293 lines
10 KiB
Plaintext
|
|
||
|
|
R Under development (unstable) (2024-04-01 r86255) -- "Unsuffered Consequences"
|
||
|
|
Copyright (C) 2024 The R Foundation for Statistical Computing
|
||
|
|
Platform: x86_64-pc-linux-gnu
|
||
|
|
|
||
|
|
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.
|
||
|
|
|
||
|
|
> library(survival)
|
||
|
|
> aeq <- function(x, y, ...) all.equal(as.vector(x), as.vector(y), ...)
|
||
|
|
>
|
||
|
|
> # This is a test of the influence matrix for an Andersen-Gill fit, using the
|
||
|
|
> # formulas found in the methods document, and implemented in the survfitaj.c
|
||
|
|
> # code. As much as anything it was a help in debugging -- both the mathematics
|
||
|
|
> # and the program.
|
||
|
|
> # The test case below has tied events, tied event/censoring, entry in mutiple
|
||
|
|
> # states, staggered entry, repeated events for a subject, varying case weights
|
||
|
|
> # within a subject, ... on purpose
|
||
|
|
>
|
||
|
|
> tdata <- data.frame(id= c(1, 1, 1, 2, 2, 3, 4, 4, 4, 4, 5, 5, 6, 6),
|
||
|
|
+ t1= c(0, 4, 9, 1, 5, 2, 0, 2, 5, 8, 1, 3, 3, 5),
|
||
|
|
+ t2= c(4, 9, 10, 5, 7, 9, 2, 5, 8, 9, 3, 11, 5, 8),
|
||
|
|
+ st= c(2, 3, 2, 3, 1, 2, 2, 4, 4, 1, 3, 1, 3, 2),
|
||
|
|
+ i0= c(1, 2, 3, 2, 3, 1, 1, 2, 4, 4, 4, 3, 2, 3),
|
||
|
|
+ wt= c(1:8, 8:3))
|
||
|
|
>
|
||
|
|
> tdata$st <- factor(tdata$st, c(1:4),
|
||
|
|
+ labels=c("censor", "a", "b", "c"))
|
||
|
|
> tdata$i0 <- factor(tdata$i0, 1:4,
|
||
|
|
+ labels=c("entry","a", "b", "c"))
|
||
|
|
> check <- survcheck(Surv(t1, t2,st) ~1, tdata, id=id, istate=i0)
|
||
|
|
>
|
||
|
|
> if (FALSE) {
|
||
|
|
+ #useful picture
|
||
|
|
+ plot(c(0,11), c(1,6.5), type='n', xlab="Time", ylab= "Subject")
|
||
|
|
+ with(tdata, segments(t1+.1, id, t2, id, col=as.numeric(check$istate)))
|
||
|
|
+ with(subset(tdata, st!= "censor"),
|
||
|
|
+ text(t2, id+.15, as.character(st)))
|
||
|
|
+ with(tdata, text((t1+t2)/2, id+.25, wt))
|
||
|
|
+ with(subset(tdata, !duplicated(id)),
|
||
|
|
+ text(t1, id+.15, as.character(i0)))
|
||
|
|
+ #segments are colored by current state, case weight in center, events at ends
|
||
|
|
+ abline(v=c(2:5, 8:11), lty=3, col='gray')
|
||
|
|
+ }
|
||
|
|
>
|
||
|
|
> # Compute the unweighted per observation leverages, using the approach in
|
||
|
|
> # the methods document, as a check of both it and the C code.
|
||
|
|
> # These IJ residuals can be directly verified using emprical derivatives,
|
||
|
|
> # and collapsed to test the weighted+collapsed results from survfitAJ.
|
||
|
|
> #
|
||
|
|
> survfitaj <- function(t1, t2, state, istate=NULL, wt, id, p0, start.time=NULL,
|
||
|
|
+ debug = FALSE) {
|
||
|
|
+ check <- survcheck(Surv(t1, t2, state) ~ 1, id=id, istate=istate)
|
||
|
|
+ if (any(check$flag >0)) stop("failed survcheck")
|
||
|
|
+ states <- check$states
|
||
|
|
+ nstate <- length(states)
|
||
|
|
+ istate <- check$istate # will have the correct levels
|
||
|
|
+ isn <- as.numeric(istate)
|
||
|
|
+ n <- length(t1)
|
||
|
|
+ if (length(t2) !=n || length(state) !=n || length(istate) !=n ||
|
||
|
|
+ length(wt) !=n || length(id) !=n) stop("input error")
|
||
|
|
+
|
||
|
|
+ newstate <- factor(state, unique(c(levels(state)[1], states)))
|
||
|
|
+ Y <- Surv(t1, t2, newstate) # makes the levels match up
|
||
|
|
+ position <- survival:::survflag(Y, id)
|
||
|
|
+
|
||
|
|
+ uid <- unique(id)
|
||
|
|
+ nid <- length(uid)
|
||
|
|
+ id <- match(id, uid) # turn it into 1,2,...
|
||
|
|
+ event <- (Y[,3] >0)
|
||
|
|
+
|
||
|
|
+ U <- A <- matrix(0, n, nstate) # per observation influence, unweighted
|
||
|
|
+ if (missing(p0)) {
|
||
|
|
+ if (!missing(start.time)) t0 <- start.time
|
||
|
|
+ else {
|
||
|
|
+ if (all(Y[, 3] ==0)) t0 <- min(Y[, 2]) # no events!
|
||
|
|
+ else t0 <- min(Y[event, 2])
|
||
|
|
+ }
|
||
|
|
+ atrisk <- (Y[,1] < t0 & Y[,2] >= t0)
|
||
|
|
+ wtsum <- sum(wt[atrisk]) # weights at that time
|
||
|
|
+ p0 <- tapply(wt[atrisk], istate[atrisk], sum) / wtsum
|
||
|
|
+ p0 <- ifelse(is.na(p0), 0, p0) #if a state has no one, tapply =NA
|
||
|
|
+ if (all(p0 <1)) { # compute intitial leverage
|
||
|
|
+ for (j in 1:nstate) {
|
||
|
|
+ U[atrisk,j] <- (ifelse(istate[atrisk]==states[j], 1, 0)
|
||
|
|
+ - p0[j])/wtsum
|
||
|
|
+ }
|
||
|
|
+ }
|
||
|
|
+ } else {
|
||
|
|
+ if (missing(start.time)) t0 <- 0 else t0 <- start.time
|
||
|
|
+ }
|
||
|
|
+
|
||
|
|
+ utime <- sort(unique(c(0, Y[event | position>1, 2])))
|
||
|
|
+
|
||
|
|
+ ntime <- length(utime)
|
||
|
|
+ phat <- matrix(0, ntime, nstate)
|
||
|
|
+ phat[1,] <- p0
|
||
|
|
+ n.risk <- matrix(0, ntime, nstate)
|
||
|
|
+ n.risk[1,] <- table(istate[Y[,1]< start.time & Y[,2] > start.time])
|
||
|
|
+
|
||
|
|
+ # count the number of transitions, and make an index to them
|
||
|
|
+ temp <- table(istate[event], factor(Y[event,3], 1:nstate, states))
|
||
|
|
+ trmat <- cbind(from= row(temp)[temp>0], to= col(temp)[temp>0])
|
||
|
|
+ nhaz <- nrow(trmat)
|
||
|
|
+ n.event <- matrix(0, ntime, nhaz)
|
||
|
|
+ C <- matrix(0, n, nhaz)
|
||
|
|
+ chaz <- matrix(0, ntime, nhaz)
|
||
|
|
+
|
||
|
|
+ hash <- trmat %*% c(1,10)
|
||
|
|
+ tindx <- match(isn + 10*Y[,3], hash, nomatch=0) #index to transitions
|
||
|
|
+
|
||
|
|
+ # at this point I have the initial inflence matrices (U= pstate,
|
||
|
|
+ # C= cumhaz, A= auc). The auc and cumhaz are 0 at the starting point
|
||
|
|
+ # so their influence is 0.
|
||
|
|
+
|
||
|
|
+ Usave <- array(0, dim=c(dim(U), ntime))
|
||
|
|
+ Usave[,,1] <- U
|
||
|
|
+ Csave <- array(0, dim= c(dim(C), ntime)) #chaz and AUC are 0 at start.time
|
||
|
|
+ Asave <- array(0, dim= c(dim(A), ntime))
|
||
|
|
+
|
||
|
|
+ for (it in 2:ntime) {
|
||
|
|
+ # AUC
|
||
|
|
+ if (it==2) delta <- utime[it]- t0
|
||
|
|
+ else delta <- utime[it] - utime[it-1]
|
||
|
|
+ A <- A + delta* U
|
||
|
|
+
|
||
|
|
+ # count noses
|
||
|
|
+ atrisk <- (t1 < utime[it] & t2 >= utime[it])
|
||
|
|
+ temp <- tapply(wt[atrisk], istate[atrisk], sum)
|
||
|
|
+ n.risk[it,] <- ifelse(is.na(temp), 0, temp)
|
||
|
|
+ event <- (Y[,2]== utime[it] & Y[,3]>0)
|
||
|
|
+ temp <- tapply(wt[event], factor(tindx[event], 1:nhaz), sum)
|
||
|
|
+ n.event[it,] <- ifelse(is.na(temp), 0, temp)
|
||
|
|
+
|
||
|
|
+
|
||
|
|
+ # Add events to C and create the H matrix
|
||
|
|
+ H <- diag(nstate)
|
||
|
|
+ for (i in which(event)) {
|
||
|
|
+ j <- isn[i] # from, to, and transition indices
|
||
|
|
+ k <- Y[i,3]
|
||
|
|
+ jk <- match(j+10*k, hash)
|
||
|
|
+ C[i, jk] <- C[i, jk] + 1/n.risk[it,j]
|
||
|
|
+ if (j!=k) {
|
||
|
|
+ H[j,j] <- H[j,j] - wt[i]/n.risk[it,j]
|
||
|
|
+ H[j,k] <- H[j,k] + wt[i]/n.risk[it,j]
|
||
|
|
+ }
|
||
|
|
+ }
|
||
|
|
+
|
||
|
|
+ U <- U %*% H
|
||
|
|
+ phat[it,] <- phat[it-1,] %*% H
|
||
|
|
+
|
||
|
|
+ if (debug) browser()
|
||
|
|
+ # Add events to U
|
||
|
|
+ for (i in which(event)) {
|
||
|
|
+ j <- isn[i] # from, to, and transition indices
|
||
|
|
+ k <- Y[i,3]
|
||
|
|
+ if (j != k) {
|
||
|
|
+ U[i,j] <- U[i,j] - phat[it-1,j]/n.risk[it,j]
|
||
|
|
+ U[i,k] <- U[i,k] + phat[it-1,j]/n.risk[it,j]
|
||
|
|
+ }
|
||
|
|
+ }
|
||
|
|
+
|
||
|
|
+ if (debug) browser()
|
||
|
|
+ # now the hazard part
|
||
|
|
+ for (h in which(n.event[it,] >0)) {
|
||
|
|
+ j <- trmat[h,1]
|
||
|
|
+ k <- trmat[h,2]
|
||
|
|
+ haz <- n.event[it,h]/n.risk[it, j]
|
||
|
|
+ h2 <- haz/n.risk[it,j]
|
||
|
|
+ who <- (atrisk & isn ==j) # at risk, currently in state j
|
||
|
|
+
|
||
|
|
+ C[who,h] <- C[who,h] - h2
|
||
|
|
+ if (j != k) {
|
||
|
|
+ U[who,j] <- U[who,j] + h2 * phat[it-1,j]
|
||
|
|
+ U[who,k] <- U[who,k] - h2 * phat[it-1,j]
|
||
|
|
+ }
|
||
|
|
+ }
|
||
|
|
+ if (debug) browser()
|
||
|
|
+ Usave[,,it] <- U
|
||
|
|
+ Csave[,,it] <- C
|
||
|
|
+ Asave[,,it] <- A
|
||
|
|
+ }
|
||
|
|
+ colnames(n.event) <- paste(trmat[,1], trmat[,2], sep=':')
|
||
|
|
+ colnames(n.risk) <- check$states
|
||
|
|
+ colnames(phat) <- check$states
|
||
|
|
+
|
||
|
|
+ list(time = utime, n.risk= n.risk, n.event=n.event, pstate= phat,
|
||
|
|
+ C=Csave, U=Usave, A=Asave)
|
||
|
|
+ }
|
||
|
|
>
|
||
|
|
> mfit <- survfit(Surv(t1, t2, st) ~ 1, tdata, id=id, istate=i0,
|
||
|
|
+ weights=wt, influence=TRUE)
|
||
|
|
> mtest <- with(tdata, survfitaj(t1, t2, st, i0, wt, id))
|
||
|
|
> # mtest <- with(tdata, survfitaj(t1, t2, st, i0, wt, id, debug=TRUE))
|
||
|
|
>
|
||
|
|
> # p0 and U0 from the methods document
|
||
|
|
> p0 <- c(8, 4,0,6)/ 18
|
||
|
|
> U0 <- rbind(c(1,0,0,0) - p0, 0, 0,
|
||
|
|
+ c(0,1,0,0) - p0, 0,
|
||
|
|
+ 0,
|
||
|
|
+ c(1,0,0,0) - p0, 0, 0, 0,
|
||
|
|
+ c(0,0,0,1) - p0, 0,
|
||
|
|
+ 0, 0) /18
|
||
|
|
>
|
||
|
|
> aeq(mtest$pstate[1,], p0)
|
||
|
|
[1] TRUE
|
||
|
|
> aeq(mtest$U[,,1], U0)
|
||
|
|
[1] TRUE
|
||
|
|
> aeq(mtest$time[-1], mfit$time) # mtest includes U(2-eps) as 'time 0'
|
||
|
|
[1] TRUE
|
||
|
|
> aeq(mtest$pstate[-1,], mfit$pstate)
|
||
|
|
[1] TRUE
|
||
|
|
> aeq(mfit$p0, p0)
|
||
|
|
[1] TRUE
|
||
|
|
> aeq(mfit$i0, rowsum(U0*tdata$wt, tdata$id))
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
> # direct check that mtest has the correct answer
|
||
|
|
> eps <- 1e-6
|
||
|
|
> delta <- array(0, dim= c(nrow(tdata), dim(mfit$pstate)))
|
||
|
|
> deltaC<- array(0, dim= c(nrow(tdata), dim(mfit$cumhaz)))
|
||
|
|
> for (i in 1:nrow(tdata)) {
|
||
|
|
+ twt <- tdata$wt
|
||
|
|
+ twt[i] <- twt[i] + eps
|
||
|
|
+ tfit <- survfit(Surv(t1, t2, st) ~1, tdata, id=id, istate=i0,
|
||
|
|
+ weights= twt)
|
||
|
|
+ delta[i,,] <- (tfit$pstate - mfit$pstate)/eps
|
||
|
|
+ deltaC[i,,] <-(tfit$cumhaz - mfit$cumhaz)/eps
|
||
|
|
+ }
|
||
|
|
> temp <- aperm(mtest$U, c(1,3,2)) # drop time 0, put state last
|
||
|
|
> all.equal(temp[,-1,], delta, tol=eps/2)
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
> tempC <-aperm(mtest$C, c(1,3,2))
|
||
|
|
> all.equal(tempC[,-1,], deltaC, tol= eps/2)
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
> # Now check mfit, which returns the weighted collapsed values
|
||
|
|
> BD <- t(model.matrix(~ factor(id) -1, tdata)) %*% diag(tdata$wt)
|
||
|
|
> rownames(BD) <- 1:6
|
||
|
|
>
|
||
|
|
> collapse <- function(U, cmat=BD) {
|
||
|
|
+ # for each time point, replace the inflence matrix U with BDU
|
||
|
|
+ if (is.matrix(U)) BD %*% U
|
||
|
|
+ else {
|
||
|
|
+ dd <- dim(U)
|
||
|
|
+ temp <- cmat %*% matrix(U, nrow = dd[1]) #fake out matrix multiply
|
||
|
|
+ array(temp, dim= c(nrow(temp), dd[2:3]))
|
||
|
|
+ }
|
||
|
|
+ }
|
||
|
|
>
|
||
|
|
> sqsum <- function(x) sqrt(sum(x^2))
|
||
|
|
> temp <- collapse(mtest$U[,,-1]) # mtest has time 0, mfit does not
|
||
|
|
> # mfit$influence is in id, time, state order
|
||
|
|
> aeq(aperm(temp, c(1,3,2)), mfit$influence) # mtest has time 0, mfit does not
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
> setemp <- apply(collapse(mtest$U[,,-1]), 2:3, sqsum)
|
||
|
|
> aeq(t(setemp), mfit$std.err)
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
> ctemp <- apply(collapse(mtest$C[,,-1]), 2:3, sqsum)
|
||
|
|
> aeq(t(ctemp), mfit$std.chaz)
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
> atemp <- apply(collapse(mtest$A[,,-1]), 2:3, sqsum)
|
||
|
|
> aeq(t(atemp), mfit$std.auc)
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
>
|
||
|
|
> # check residuals
|
||
|
|
> rr1 <- resid(mfit, times=mfit$time, type='pstate')
|
||
|
|
> aeq(rr1, mtest$U[,,-1])
|
||
|
|
[1] TRUE
|
||
|
|
> rr2 <- resid(mfit, times=mfit$time, type='auc')
|
||
|
|
> aeq(rr2, mtest$A[,,-1])
|
||
|
|
[1] TRUE
|
||
|
|
>
|
||
|
|
>
|
||
|
|
>
|
||
|
|
> proc.time()
|
||
|
|
user system elapsed
|
||
|
|
1.175 0.081 1.248
|