1#' Summary of event histories 2#' 3#' Describe events and censoring patterns of an event history. 4#' 5#' 6#' @param object An object with class `Hist' derived with \code{\link{Hist}} 7#' @param verbose Logical. If FALSE any printing is supressed. 8#' @param \dots Not used 9#' @return \code{NULL} for survival and competing risk models. For other 10#' multi-state models, it is a list with the following entries: 11#' \item{states}{the states of the model} \item{transitions}{the transitions 12#' between the states} \item{trans.frame}{a data.frame with the from and to 13#' states of the transitions} 14#' @author Thomas A. Gerds \email{tag@@biostat.ku.dk} 15#' @seealso \code{\link{Hist}}, \code{\link{plot.Hist}} 16#' @keywords survival 17#' @examples 18#' 19#' icensFrame <- data.frame(L=c(1,1,3,4,6),R=c(2,NA,3,6,9),event=c(1,1,1,2,2)) 20#' with(icensFrame,summary(Hist(time=list(L,R)))) 21#' 22#' @export 23summary.Hist <- function(object, verbose=TRUE,...){ 24 D <- object[,"status",drop=TRUE] 25 states <- attr(object,"states") 26 cens.code <- attr(object,"cens.code") 27 # {{{ resolving events and model states 28 model <- attr(object,"model") 29 model.string <- paste("response of a", model,"model") 30 if (model=="multi.states"){ 31 from <- object[,"from"] 32 to <- object[,"to"] 33 code.from <- getEvent(object,mode="factor",column="from") 34 code.to <- getEvent(object,mode="factor",column="to") 35 state.types <- factor(as.numeric(match(states,unique(code.from),nomatch=0)!=0) + 2*as.numeric(match(states,unique(code.to),nomatch=0)!=0),levels=c(1,2,3)) 36 names(state.types) <- states 37 levels(state.types) <- c("initial","absorbing","transient") 38 state.types <- table(state.types) 39 } 40 else{ 41 from <- rep("initial",NROW(object)) 42 code.to <- getEvent(object,mode="factor",column=ifelse(model=="survival","status","event")) 43 code.from <- factor(from) 44 state.types <- c(1,length(states)) 45 names(state.types) <- c("initial","absorbing") 46 } 47 # }}} 48 # {{{ transition frame 49 ## trans.frame <- unique(data.frame(from=code.from,to=code.to),MARGIN=1) 50 trans.frame <- data.frame(from=code.from,to=code.to) 51 Transitions <- apply(cbind(as.character(code.from),as.character(code.to)),1,paste,collapse=" -> ") 52 obnoxious.factor.levels <- unique(Transitions) 53 Transitions <- factor(Transitions,obnoxious.factor.levels) 54 transitions <- table(Transitions) 55 summary.out <- list(states=state.types,transitions=transitions,trans.frame=trans.frame) 56 if (verbose==TRUE){ 57 state.table <- as.matrix(transitions) 58 colnames(state.table) <- c("Freq") 59 } 60 # }}} 61 # {{{ resolving the censoring mechanism 62 if (verbose==TRUE){ 63 ## event time 64 cens.type <- attr(object,"cens.type") 65 ## cens.string <- capitalize(cens.type) 66 cens.string <- switch(cens.type, 67 "intervalCensored"="Interval-censored", 68 "rightCensored"="Right-censored", 69 "uncensored"="Uncensored") 70 Observations <- switch(cens.type, 71 "intervalCensored"=factor(D,levels=c(1,2,0),labels=c("exact.time","interval-censored","right-censored")), 72 "rightCensored"=factor(D,levels=c(1,0),labels=c("event","right.censored")), 73 "uncensored"=factor(D,labels=c("event"))) 74 Freq <- table(Observations) 75 ## entry time 76 entry.type <- attr(object,"entry.type") 77 if (entry.type!="") 78 entry.string <- paste(" with ",entry.type," entry time",sep="") 79 else 80 entry.string <- "" 81 ## stop time 82 stop.time <- attr(object,"stop.time") 83 if (is.null(stop.time)) 84 stop.string <- "" 85 else 86 stop.string <- paste(" stopped at time ",stop.time,sep="") 87 cat("\n", 88 cens.string, 89 " ", 90 model.string, 91 entry.string, 92 stop.string, 93 "\n", 94 sep="") 95 cat("\nNo.Observations:",NROW(object),"\n\nPattern:\n") 96 switch(model,"survival"={ 97 prmatrix(cbind(names(Freq),Freq), 98 quote=FALSE, 99 rowlab=rep("",NROW(Freq)))}, 100 "competing.risks"={ 101 events <- getEvent(object) 102 prout <- table("Cause"=events,as.character(Observations)) 103 print(prout) 104 }, 105 "multi.states"={ 106 x=table(Transitions,Observations) 107 aaa=sapply(strsplit(rownames(x)," -> "),function(x)x[1]) 108 bbb=sapply(strsplit(rownames(x)," -> "),function(x)x[1]) 109 print(x[order(aaa,bbb),,drop=FALSE]) 110 }) 111 } 112 # }}} 113 invisible(summary.out) 114} 115 116## capitalize <- function(x) { 117 ## s <- strsplit(x, " ")[[1]] 118 ## paste(toupper(substring(s, 1,1)), substring(s, 2), sep="", collapse=" ") 119## } 120