R/SurvSplit.R

In eha: Event History Analysis

#' Split a survival object at specified durations.
#' 
#' Given a survival object, (a matrix with two or three columns) and a set of
#' specified cut times, split each record into multiple subrecords at each cut
#' time.  The new survival object will be in `counting process' format, with an
#' enter time, exit time, and event status for each record.
#' 
#' 
#' @param Y A survival object, a matrix with two or three columns.
#' @param cuts The cut points, must be strictly positive and distinct.
#' @return A list with components 
#' \item{Y}{The new survival object with three
#' columns, i.e., in 'counting process' form.} 
#' \item{ivl}{Interval No., starting from leftmost, (0, cuts[1]) or similar.} 
#' \item{idx}{Row number for original Y row.}
#' @note This function is used in \code{\link{phreg}} for the piecewise
#' constant hazards model. It uses \code{\link{age.window}} for each interval.
#' @author Göran Broström
#' @seealso \code{\link[survival]{survSplit}}, \code{\link{age.window}}.
#' @keywords manip
#' @examples
#' 
#' ##---- Should be DIRECTLY executable !! ----
#' ##-- ==>  Define data, use random,
#' ##--	or do  help(data=index)  for the standard data sets.
#' 
#' ## The function is currently defined as
#' function(Y, cuts){
#'     if (NCOL(Y) == 2) Y <- cbind(rep(0, NROW(Y)), Y)
#'     indat <- cbind(Y, 1:NROW(Y), rep(-1, NROW(Y)))
#'     colnames(indat) <- c("enter", "exit", "event", "idx", "ivl")
#'     n <- length(cuts)
#'     cuts <- sort(cuts)
#'     if ((cuts[1] <= 0) || (cuts[n] == Inf))
#'         stop("'cuts' must be positive and finite.")
#'     cuts <- c(0, cuts, Inf)
#'     n <- n + 1
#'     out <- list()
#'     indat <- as.data.frame(indat)
#'     for (i in 1:n){
#'         out[[i]] <- age.window(indat, cuts[i:(i+1)])
#'         out[[i]]$ivl <- i
#'         out[[i]] <- t(out[[i]])
#'     }
#'     Y <- matrix(unlist(out), ncol = 5, byrow = TRUE)
#'     colnames(Y) <- colnames(indat)
#'     list(Y = Y[, 1:3],
#'          ivl = Y[, 5],
#'          idx = Y[, 4]
#'          )
#'   }
#' 
#' @export SurvSplit
SurvSplit <- function(Y, cuts){
    if (NCOL(Y) == 2) Y <- cbind(rep(0, NROW(Y)), Y)
    indat <- cbind(Y, 1:NROW(Y), rep(-1, NROW(Y)))
    colnames(indat) <- c("enter", "exit", "event", "idx", "ivl")
    n <- length(cuts)
    cuts <- sort(cuts)
    if ((cuts[1] <= 0) || (cuts[n] == Inf))
        stop("'cuts' must be positive and finite.")
    cuts <- c(0, cuts, Inf)
    n <- n + 1
    out <- list()
    indat <- as.data.frame(indat)
    for (i in 1:n){
        out[[i]] <- age.window(indat, cuts[i:(i+1)])
        out[[i]]$ivl <- i
        ##out[[i]] <- t(out[[i]]) Needed for old method with unlist.
    }
    ## Y <- matrix(unlist(out), ncol = 5, byrow = TRUE)
    ## Faster (and cleaner):
    Y <- do.call(rbind, out)
    colnames(Y) <- colnames(indat)
    list(Y = Y[, 1:3],
         ivl = Y[, 5],
         idx = Y[, 4]
         )
}