### R code from vignette source 'timedep.Rnw'

###################################################
### code chunk number 1: preamble
###################################################
options(width=60, continue=" ")
makefig <- function(file, top=1, right=1, left=4) {
    pdf(file, width=9.5, height=7, pointsize=18)
    par(mar=c(4, left, top, right) +.1)
    }
library(survival)
library(splines)


###################################################
### code chunk number 2: testdata
###################################################
tdata <- data.frame(subject=c("Smith", "Smith", "Smith", "Jones", "Jones"), 
                    time1=  c(0,90, 120, 0, 52),
                    time2 = c(90, 120, 185, 52, 90), death=c(0,0,0,0,1),
                    creatinine=c(0.9, 1.5, 1.2, 1.3, 1.8))
tdata


###################################################
### code chunk number 3: fake
###################################################
getOption("SweaveHooks")[["fig"]]()
set.seed(1953)  # a good year
nvisit <- floor(pmin(lung$time/30.5, 12))
response <- rbinom(nrow(lung), nvisit, .05) > 0
badfit <- survfit(Surv(time/365.25, status) ~ response, data=lung)
plot(badfit, mark.time=FALSE, lty=1:2, 
     xlab="Years post diagnosis", ylab="Survival")
legend(1.5, .85, c("Responders", "Non-responders"), 
       lty=2:1, bty='n')


###################################################
### code chunk number 4: timedep.Rnw:355-356 (eval = FALSE)
###################################################
## newdata <- tmerge(data1, data2, id, newvar=tdc(time, value), ...)


###################################################
### code chunk number 5: timedep.Rnw:401-402
###################################################
cgd0[1:4,]


###################################################
### code chunk number 6: cgd1
###################################################
dim(cgd0)
newcgd <- tmerge(data1=cgd0[, 1:13], data2=cgd0, id=id, tstop=futime)
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime1)) 
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime2)) 
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime3)) 
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime4)) 
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime5)) 
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime6)) 
newcgd <- tmerge(newcgd, cgd0, id=id, infect = event(etime7)) 
newcgd <- tmerge(newcgd, newcgd, id, enum=cumtdc(tstart))
dim(newcgd)
newcgd[1:5,c(1, 4:6, 13:17)]
summary(newcgd)
coxph(Surv(tstart, tstop, infect) ~ treat + inherit + steroids,
      data =newcgd, cluster = id)


###################################################
### code chunk number 7: cgd1b
###################################################
test  <- tmerge(cgd0[, 1:13], cgd0, id=id, tstop=futime,
                 infect = event(etime1), infect= event(etime2),
                 infect = event(etime3), infect= event(etime4),
                 infect = event(etime5), infect= event(etime6),
                 infect = event(etime7))
test <- tmerge(test, test,  id= id, enum = cumtdc(tstart))
all.equal(newcgd, test)


###################################################
### code chunk number 8: cgd1c
###################################################
# create a long data set with the recurrences
temp <- reshape(cgd0[c(1, 14:20)], varying= 2:8, v.names="etime",
                 idvar="id", direction="long")
cgdrecur <- subset(temp, !is.na(etime))  # toss missings (not essential)

newcgd <- tmerge(data1=cgd0[, 1:13], data2=cgd0, id=id, tstop=futime)
newcgd <- tmerge(newcgd, cgdrecur, id=id, infect= event(etime))


###################################################
### code chunk number 9: stanford
###################################################
jasa$subject <- 1:nrow(jasa)  #we need an identifier variable
tdata <- with(jasa, data.frame(subject = subject,
                               futime= pmax(.5, fu.date - accept.dt),
                               txtime= ifelse(tx.date== fu.date,
                                              (tx.date -accept.dt) -.5,
                                              (tx.date - accept.dt)),
                               fustat = fustat
                             ))
xdata <- tmerge(jasa, tdata, id=subject,
                  death = event(futime, fustat),
                  transplant   =  tdc(txtime), 
                  options= list(idname="subject"))

sdata <- tmerge(jasa, tdata, id=subject,
                  death = event(futime, fustat),
                  trt   =  tdc(txtime), 
                  options= list(idname="subject"))
attr(sdata, "tcount")
sdata$age <- sdata$age -48
sdata$year <- as.numeric(sdata$accept.dt - as.Date("1967-10-01"))/365.25

# model 6 of the table in K&P
coxph(Surv(tstart, tstop, death) ~ age*trt + surgery + year, 
      data= sdata, ties="breslow")


###################################################
### code chunk number 10: pbc
###################################################
temp <- subset(pbc, id <= 312, select=c(id:sex, stage)) # baseline
pbc2 <- tmerge(temp, temp, id=id, death = event(time, status)) #set range
pbc2 <- tmerge(pbc2, pbcseq, id=id, ascites = tdc(day, ascites),
               bili = tdc(day, bili), albumin = tdc(day, albumin),
               protime = tdc(day, protime), alk.phos = tdc(day, alk.phos))
fit1 <- coxph(Surv(time, status==2) ~ log(bili) + log(protime), pbc)
fit2 <- coxph(Surv(tstart, tstop, death==2) ~ log(bili) + log(protime), pbc2)
rbind('baseline fit' = coef(fit1),
      'time dependent' = coef(fit2))


###################################################
### code chunk number 11: timedep.Rnw:700-701
###################################################
attr(pbc2, "tcount")


###################################################
### code chunk number 12: timedep.Rnw:703-705
###################################################
#grab a couple of numbers for the paragraph below
atemp <- attr(pbc2, "tcount")[2:3,]


###################################################
### code chunk number 13: timedep.Rnw:786-792 (eval = FALSE)
###################################################
## temp <- subset(pbc, id <= 312, select=c(id:sex, stage))
## pbc2 <- tmerge(temp, temp, id=id, death = event(time, status))
## pbc2a <- tmerge(pbc2, pbcseq, id=id, ascites = tdc(day, ascites),
##                bili = tdc(day, bili), options= list(delay=14))
## pbc2b <- tmerge(pbc2, pbcseq, id=id, ascites = tdc(day+14, ascites),
##                bili = tdc(day+14, bili))


###################################################
### code chunk number 14: rep (eval = FALSE)
###################################################
## newd <- tmerge(data1=base, data2=timeline, id=repid, tstart=age1, 
##                tstop=age2, options(id="repid"))
## newd <- tmerge(newd, outcome, id=repid, mcount = cumtdc(age))
## newd <- tmerge(newd, subset(outcome, event='diabetes'), 
##                diabetes= tdc(age))
## newd <- tmerge(newd, subset(outcome, event='arthritis'), 
##                arthritis= tdc(age))


###################################################
### code chunk number 15: timeline1
###################################################
p3 <- data.frame(id=c(1,1,2,2,3,3), status=c(0,2,0,0,0,2), 
                 time=c(0,400, 0, 4500, 0, 1012),
                 sex=c('f', 'f', 'f', 'f', 'm', 'm'),
                 bili=c(14.5, NA, 1.1, NA, 1.4, NA),
                 chol=c(261, NA, 302, NA, 176, NA))
print(p3, naprint='.')


###################################################
### code chunk number 16: pbctimeline
###################################################
pbctime <- subset(pbcseq, select= -c(futime, status))
pbctime$status <- 0
temp <- subset(pbcseq, !duplicated(id), c(id, trt, age, sex, futime, status))
names(temp)[5] <- "day"  # change futime to day
pbctime <- merge(pbctime, temp, all=TRUE)
subset(pbctime, id<3, c(id, trt, sex, day, status, edema, bili, chol))


###################################################
### code chunk number 17: veteran1
###################################################
options(show.signif.stars = FALSE)  # display statistical intelligence
vfit <- coxph(Surv(time, status) ~ trt + prior + karno, veteran)
vfit
quantile(veteran$karno)

zp <- cox.zph(vfit, transform= function(time) log(time +20))
zp


###################################################
### code chunk number 18: veteran1b
###################################################
getOption("SweaveHooks")[["fig"]]()
plot(zp[3], resid=FALSE)    # a plot for the 3rd variable in the fit
abline(0,0, lty=3)
abline(h= vfit$coef[3], lwd=2, lty=3)


###################################################
### code chunk number 19: split
###################################################
vet2 <- survSplit(Surv(time, status) ~ ., data= veteran, cut=c(90, 180), 
                  episode= "tgroup", id="id")
vet2[1:7, c("id", "tstart", "time", "status", "tgroup", "age", "karno")]


###################################################
### code chunk number 20: split2
###################################################
vfit2 <- coxph(Surv(tstart, time, status) ~ trt + prior +
                  karno:strata(tgroup), data=vet2)
vfit2
cox.zph(vfit2)


###################################################
### code chunk number 21: split3
###################################################
vfit2$means


###################################################
### code chunk number 22: split4
###################################################
getOption("SweaveHooks")[["fig"]]()
quantile(veteran$karno)
cdata <- data.frame(tstart= rep(c(0,90,180), 2),
                    time =  rep(c(90,180, 365), 2),
                    status= rep(0,6),   #necessary, but ignored
                    tgroup= rep(1:3, 2),
                    trt  =  rep(1,6),
                    prior=  rep(0,6),
                    karno=  rep(c(40, 75), each=3),
                    curve=  rep(1:2, each=3))
cdata
sfit <- survfit(vfit2, newdata=cdata, id=curve)
km <- survfit(Surv(time, status) ~ I(karno>60), veteran)
plot(km, xmax= 365, col=1:2, lwd=2, 
     xlab="Days from enrollment", ylab="Survival")
lines(sfit, col=1:2, lty=2, lwd=2)


###################################################
### code chunk number 23: vfit3 (eval = FALSE)
###################################################
## vfit3 <- coxph(Surv(time, status) ~ trt + prior + karno +
##                 I(karno * log(time + 20)), data=veteran)


###################################################
### code chunk number 24: vfit3b
###################################################
vdeath <- sort(unique(veteran$time[veteran$status==1]))
length(vdeath)
vet3 <- survSplit(Surv(time, status) ~ ., data= veteran, cut=vdeath, 
                  episode= "tgroup", id="id")
quantile(table(vet3$id))


###################################################
### code chunk number 25: vfit3c
###################################################
vet3$xtime <- vet3$time
vfit3 <- coxph(Surv(tstart, time, status) ~ trt + prior + karno +
                   I(karno * log(xtime+20)), vet3)
plot(zp[3])
abline(coef(vfit3)[3:4], col=2, lty=2)


###################################################
### code chunk number 26: vet3d
###################################################
vfit3b <-  coxph(Surv(time, status) ~ trt + prior + karno + tt(karno),
                data=veteran,
                tt = function(x, t, ...) x * log(t+20))
rbind(coef(vfit3b), coef(vfit3))


###################################################
### code chunk number 27: vet4
###################################################
ns2 <- function(x) ns(x, knots=c(100, 200), Boundary.knots = c(5,400))
vfit4 <-  coxph(Surv(tstart,time, status) ~ trt + prior + karno + 
                    karno:ns2(xtime), data=vet3)
vfit4

# termplot does not create sensible estimates for interactions (per its
#  help page), so do it by hand for the karno term
smat <- cbind(1, ns2(5:400)) # a range of plotting values
estimate <- drop(smat %*% coef(vfit4)[3:6])
sd.est <- sqrt(diag(smat %*% vcov(vfit4)[3:6, 3:6] %*% t(smat)))
yy <- estimate + outer(sd.est, c(0, -1.96, 1.96), "*")
matplot(5:400/30.5, yy, type='l', lty=c(1,2,2), col=1, lwd=c(2,1,1),
        xlab="Months", ylab= "Estimated beta(t) for karno")
abline(0,0, lty=3)


###################################################
### code chunk number 28: ties1
###################################################
data1 <- read.table(col.names=c("id", "diabetes", "lfu", "status"),
                          header=FALSE, text="
1   5 30  1
2  10 15  1
3  NA 60  0
4  NA 80  1
5  10 80  0
6  NA 90  1
7  30 95  1
")

data1$d2 <- pmin(data1$diabetes, 300, na.rm=TRUE) #replace NA with 300
fit1 <- coxph(Surv(lfu, status) ~ tt(d2), data=data1,
              tt = function(d2, t, ...) ifelse(t > d2, 1, 0))
fit2 <- coxph(Surv(lfu, status) ~ tt(d2), data=data1,
              tt = function(d2, t, ...) ifelse(t < d2, 0, 1))
c(coef(fit1), coef(fit2))


###################################################
### code chunk number 29: ties2
###################################################
data2 <- tmerge(data1, data1, id=id, dstat=event(lfu, status),
                diab = tdc(diabetes))
subset(data2, id %in% c(1,7), c(id, tstart:diab))               
fit3 <- coxph(Surv(tstart, tstop, dstat) ~ diab, data2)
c(coef(fit1), coef(fit2), coef(fit3))


###################################################
### code chunk number 30: expand
###################################################
dtimes <- sort(unique(with(pbc, time[status==2])))
tdata1 <- survSplit(Surv(time, status==2) ~., pbc, cut=dtimes)
tdata1$c.age <- tdata1$age + tdata1$time/365.25 -50 #current age, centered at 50
pfit1 <- coxph(Surv(tstart, time, event) ~ log(bili) + ascites + c.age +
    I(c.age^2) + I(c.age^3), data=tdata1)

tdata2 <- survSplit(Surv(time, status==2) ~., pbc, cut=1:12 * 365.25)
tdata2$c.age <- tdata2$age + tdata2$time/365.25 -50 #current age, centered at 50
pfit2 <- coxph(Surv(tstart, time, event) ~ log(bili) + ascites + c.age +
    I(c.age^2) + I(c.age^3), data=tdata2)

rbind(coef(pfit1), coef(pfit2))
c(nrow(pbc), nrow(tdata1), nrow(tdata2))


###################################################
### code chunk number 31: veteran3
###################################################
getOption("SweaveHooks")[["fig"]]()
dtime <- round(1:13 * 30.5)
vdata2 <- survSplit(Surv(time, status) ~ ., veteran, cut=dtime,
                    episode= "month")
vfit1 <- coxph(Surv(tstart, time, status) ~ trt + prior + karno, vdata2)
vfit5 <- coxph(Surv(tstart, time, status) ~ trt + prior + karno + 
                   karno:ns(month, df=3), vdata2)
anova(vfit1, vfit5)

tdata <- expand.grid(trt=0, prior=0, karno=30, month=seq(1,13, length=50))
yhat <- predict(vfit5, newdata=tdata, se.fit=TRUE, reference="zero")
yy <- yhat$fit+ outer(yhat$se.fit, c(0, -1.96, 1.96), '*')
matplot(seq(1,13, length=50), yy, type='l', lty=c(1,2,2), col=1, lwd=c(2,1,1),
        xlab="Month of fu", ylab="Effect, Karnofsky 60 vs 90")


###################################################
### code chunk number 32: timedep.Rnw:1391-1398
###################################################
function(x, t, riskset, weights){ 
    obrien <- function(x) {
        r <- rank(x)
        (r-.5)/(.5+length(r)-r)
    }
    unlist(tapply(x, riskset, obrien))
}


###################################################
### code chunk number 33: timedep.Rnw:1408-1410
###################################################
function(x, t, riskset, weights) 
    unlist(tapply(x, riskset, rank))
