Survival Curves with D3

Proof of concept, selections and transitions

library(survival)
library(ggplot2)
library(gridSVG)

## 
## Attaching package: 'gridSVG'
## 
## The following object is masked from 'package:grDevices':
## 
##     dev.off

library(grid)
library(dplyr)

## 
## Attaching package: 'dplyr'
## 
## The following object is masked from 'package:stats':
## 
##     filter
## 
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

gdat <- survival::lung
fit <- survfit(Surv(time, status) ~ factor(sex), data = gdat)
tdat <- with(fit, data.frame(n.risk, time, surv, strata = rep(1:2, strata)))
targ.times <- seq(min(tdat$time), max(tdat$time), by = 15)[-c(1, 68)]

interp <- function(dat, t){
  
  if(t %in% dat$time){
    
    return(dat[dat$time == t, ])
    
  } else {
    
    t2 <- max(dat$time[dat$time < t])
    
    d2 <- dat[dat$time == t2, ]
    d2$time <- t
    return(d2)
    
  }
  
}

tdat2 <- NULL
for(ttt in targ.times){
  
  tdat2 <- rbind(tdat2, tdat %>% group_by(strata) %>% do({
  
    interp(., ttt)
  
  }))
}
tdat <- tdat2[order(tdat2$strata, tdat2$time),]

p1 <- ggplot(gdat, aes(x = time, status = status, color = factor(sex))) + geom_km()

p1 + geom_text(data = tdat, aes(x = time, y = surv, label = n.risk, hjust = .5, vjust = -1,
                                status = NULL, color = NULL), alpha = 0) + 
  geom_point(data = tdat, aes(x = time, y = surv,
                                status = NULL, color = NULL), alpha = 0)

grid.force()
#grid.ls()

grid.garnish("geom_point.points.11", tip = paste(tdat$n.risk), group = FALSE, global = TRUE, grep = TRUE)
grid.export(NULL, prefix = "km")$svg

Transitioning a line

sdat1 <- survfit(Surv(time, status) ~ 1, data = subset(lung, sex == 1))
sdat2 <- survfit(Surv(time, status) ~ 1, data = subset(lung, sex == 2))
## create stepfunction
dostep <- function(x,y) {
        keep <- is.finite(x) & is.finite(y) 
        if (!any(keep)) return()  #all points were infinite or NA
        if (!all(keep)) {
            # these won't plot anyway, so simplify (CI values are often NA)
            x <- x[keep]
            y <- y[keep]
        }
        n <- length(x)
        if (n==1)       list(x=x, y=y)
        else if (n==2)  list(x=x[c(1,2,2)], y=y[c(1,1,2)])
        else {
            # replace verbose horizonal sequences like
            # (1, .2), (1.4, .2), (1.8, .2), (2.3, .2), (2.9, .2), (3, .1)
            # with (1, .2), (.3, .2),(3, .1).  
            #  They are slow, and can smear the looks of the line type.
            temp <- rle(y)$lengths
            drops <- 1 + cumsum(temp[-length(temp)])  # points where the curve drops

            #create a step function
            if (n %in% drops) {  #the last point is a drop
                xrep <- c(x[1], rep(x[drops], each=2))
                yrep <- rep(y[c(1,drops)], c(rep(2, length(drops)), 1))
            }
            else {
                xrep <- c(x[1], rep(x[drops], each=2), x[n])
                yrep <- c(rep(y[c(1,drops)], each=2))
            }
            list(x=xrep, y=yrep)
        }
}

step1 <- dostep(sdat1$time, sdat1$surv)
step2 <- dostep(sdat2$time, sdat2$surv)

p1 <- ggplot(lung, aes(x = time, status = status)) + geom_km(se = FALSE) + 
  scale_x_continuous(limits = c(0, 1022)) + 
  scale_y_continuous(limits = c(0, 1))
p1 
grid.force()
#grid.ls()

grid.garnish("GRID.polyline.244", 
             tipy1 = paste(round(step1$y, 3), collapse = ","), 
             tipx1 = paste(step1$x, collapse = ","),
             tipy2 = paste(round(step2$y, 3), collapse = ","), 
             tipx2 = paste(step2$x, collapse = ","),
             group = TRUE, global = TRUE, grep = TRUE)
grid.export(NULL, prefix = "km2")$svg