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