1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
find_times <- function(d, timepoints) {
ind <- findInterval(timepoints, d$time)
ind0 <- sum(ind == 0)
dd <- d[ind, ]
if (ind0 > 0) {
tmp <- d[1, , drop = FALSE]
tmp$P <- round(tmp$P)
tmp$var <- 0
tmp$lower <- tmp$upper <- tmp$P
tmp$n.event <- 0
for (i in seq_len(ind0)) dd <- rbind(tmp, dd)
}
dd$time <- timepoints
dd$n.event <- cumsum(dd$n.event)
dd
}
summary.etm <- function(object, tr.choice, ci.fun = "linear", level = 0.95, times, ...) {
if (!inherits(object, "etm"))
stop("'object' must be of class 'etm'")
if (level <= 0 | level > 1) {
stop ("'level' must be between 0 and 1")
}
ref <- c("linear", "log", "cloglog", "log-log")
if (sum(ci.fun %in% ref == FALSE) != 0) {
stop("'ci.fun' is not correct. See help page")
}
## Number of strata. Will be computed in this if condition
ns <- 1
if (!is.null(object$strata_variable)) {
ns <- length(object$strata)
time <- unique(sapply(1:ns, function(i) {
object[[i]]$time
}))
} else {
time <- object$time
}
## If no event time between s and t, don't need a summary
if (is.null(time)) stop("no event time")
## Derive the transition names we need
if (missing(tr.choice)) {
if (!is.null(object$strata_variable)) {
indi <- lapply(1:ns, function(i) {
!apply(object[[i]]$est != 0, c(1, 2), function(temp){all(temp == FALSE)})
})
indi <- do.call("+", indi) > 0
} else {
ind <- object$est != 0
indi <- !apply(ind, c(1, 2), function(temp){all(temp == FALSE)})
}
tmp <- which(indi, arr.ind = TRUE)
tmp <- tmp[order(tmp[, 1]), ]
namen <- list(rownames(indi), colnames(indi))
trs <- lapply(seq_len(NROW(tmp)), function(i) {
paste(namen[[1]][tmp[i, 1]], namen[[2]][tmp[i, 2]], sep = " ")
})
trs <- cbind(trs)
absorb <- setdiff(as.character(object$tran$to), as.character(object$trans$from))
for (i in seq_along(absorb))
trs <- trs[-grep(paste("^", absorb[i], sep =""), trs, perl = TRUE)]
} else {
ref <- sapply(1:length(object$state.names), function(i) {
paste(object$state.names, object$state.names[i])
})
ref <- matrix(ref)
if (sum(tr.choice %in% ref == FALSE) > 0)
stop("Argument 'tr.choice' and possible transitions must match")
trs <- tr.choice
}
not_missing <- !missing(times)
if (ns > 1) {
res <- lapply(seq_len(ns), function(i) {
tmp <- ci.transfo(object[[i]], trs, level, ci.fun)
if (not_missing) tmp <- lapply(tmp, find_times, timepoints = times)
class(tmp) <- "summary.etm"
tmp
})
names(res) <- object$strata
class(res) <- "summary.etm"
} else {
res <- ci.transfo(object, trs, level, ci.fun)
if (not_missing) res <- lapply(res, find_times, timepoints = times)
class(res) <- "summary.etm"
}
res
}
|
