MLSurvival: Machine Learning for Survival Analysis

#' @export
Performance <- function(object, method="gbm"){

threshold <- object$threshold
predict.times <- object$predict.times 
pred <- object$resamples 
form <- object$form 
resp.vars <- all.vars(form[[2]]) ## 
time = resp.vars[1]; status = resp.vars[2]

classifier <- c("gbm", "ranger", "glm", "glmnet", "xgbTree", "svmRadial")
method1 <- c("COX", "RSF", "Classifier")
names(method1) <- method1 

if(method%in%classifier) {mod1 = method; method = "Classifier"}  


switch(method1[method], 
Classifier = {
perf <- ddply(pred, .variables = "Resample", .fun = function(xx){
ddply(xx, .variables = "time.id", .fun = function(yy){
ix <- unique(yy$time.id)
p <- yy$Yes 
obs <- ifelse(yy$obs == "Yes", 1, 0) 
cbind(method = object$method, predict.times = predict.times[ix], Performance.measures(pred= p, obs= obs, threshold= threshold[ix]))
})
})
perf$time.id <- NULL
perf$Resample <- NULL 
rownames(perf) <- NULL 
},
COX = {
perf <- do.call(rbind, lapply(pred, function(xx){
xx <- data.frame(xx)
obs <- xx[, status] 
ts <- xx[, time] 
nme  <- colnames(xx)[-c(1,2)]
names(predict.times) <- nme
names(threshold) <- nme
do.call(rbind, lapply(nme, function(ii){
p <- xx[, ii]
y = obs
y[(predict.times[ii] < ts)] <- 0
AUC <- Performance.measures(pred=p, obs= y, threshold= 0.5*threshold[ii])

cbind(method = "COX", predict.times = predict.times[ii],  AUC)
}))
}))
rownames(perf) <- NULL 
}, 

RF = {
perf <- do.call(rbind, lapply(pred, function(xx){
xx <- data.frame(xx)
obs <- xx[, status] 
ts <- xx[, time] 
nme  <- colnames(xx)[-c(1,2)]
names(predict.times) <- nme 
names(threshold) <- nme
do.call(rbind, lapply(nme, function(ii){
p <- xx[, ii]
y = obs
y[(predict.times[ii] < ts) & (obs == 1)] <- 0
AUC <- Performance.measures(pred=1-p, obs= y, threshold= threshold[ii])
cbind(predict.times = predict.times[ii],  AUC)
}))
}))
rownames(perf) <- NULL 
}, 
RSF = {
perf <- do.call(rbind, lapply(pred, function(xx){
xx <- data.frame(xx)
obs <- xx[, status] 
ts <- xx[, time] 
nme  <- colnames(xx)[-c(1,2)]
names(predict.times) <- nme 
names(threshold) <- nme
do.call(rbind, lapply(nme, function(ii){
p <- xx[, ii]
y = obs
y[(predict.times[ii] < ts)] <- 0
AUC <- Performance.measures(pred=p, obs= y, threshold= threshold[ii])
cbind(method = "RSF", predict.times = predict.times[ii],  AUC)
}))
}))
rownames(perf) <- NULL 
}, 
stop(paste0(x," not yet implemented"))
)
return(perf)

}




#' @export
external_validation  <- function(object, ext.data, method="gbm"){

classifier <- c("gbm", "ranger", "glm", "glmnet", "xgbTree", "svmRadial")
method1 <- c("COX", "RSF", "Classifier")
names(method1) <- method1 
mod <- method 
if(method%in%classifier) {mod = "Classifier"}  

resp.vars <- all.vars(object$formula[[2]]) ## 
time = resp.vars[1]; status = resp.vars[2]
rhs.vars <- all.vars(object$formula[[3]])
#ext.data <- na.omit(ext.data[, c(time, status, rhs.vars)]) 
obs <- ext.data[, status]
ts <- ext.data[, time] 

switch(method1[mod], 

Classifier = {
threshold <- object$MLsurvival[[method]]$model$threshold  
predict.times <- object$MLsurvival[[method]]$model$predict.times
pred <- do.call(cbind, lapply(object$MLsurvival[[method]]$model$finalModel, function(xx) 
               predict(xx, newdata = ext.data, type = "prob")[,"Yes"]))	

perf <- do.call(rbind, lapply(1:length(predict.times), function(ii){
p <- pred[, ii]
y = obs
y[(predict.times[ii] < ts)] <- 0

AUC <- Performance.measures(pred=p, obs= y, threshold= threshold[ii])
cbind.data.frame(method = method, predict.times = predict.times[ii],  AUC)
}))
rownames(perf) <- NULL 
},
COX = {
threshold <- object$MLsurvival$COX$model$threshold  
predict.times <- object$MLsurvival$COX$model$predict.times

pred <- predict(object=object, method = "COX", newdata = ext.data, predict.times=predict.times)

nme <- names(threshold)
colnames(pred) = nme 
names(predict.times) = nme 

perf <- do.call(rbind, lapply(nme, function(ii){
p <- pred[, ii]
y = obs
y[(predict.times[ii] < ts)] <- 0
AUC <- Performance.measures(pred=p, obs= y, threshold= threshold[ii])
cbind(method = "COX", predict.times = predict.times[ii],  AUC)
}))
rownames(perf) <- NULL 
}, 

RSF = {
threshold <- object$MLsurvival$RSF$model$threshold  
predict.times <- object$MLsurvival$RSF$model$predict.times
pred <- predict(object=object, method = "RSF", newdata = ext.data, predict.times=predict.times)
nme <- names(threshold)
colnames(pred) = nme 
names(predict.times) = nme 

perf <- do.call(rbind, lapply(nme, function(ii){
p <- pred[, ii]
y = obs
y[(predict.times[ii] < ts)] <- 0

AUC <- Performance.measures(pred=p, obs= y, threshold= threshold[ii])
cbind(method = "RSF", predict.times = predict.times[ii],  AUC)
}))
rownames(perf) <- NULL 
}, 
stop(paste0(x," not yet implemented"))
)

return(perf)

}