-
Notifications
You must be signed in to change notification settings - Fork 1
/
confint-methods.R
118 lines (117 loc) · 3.78 KB
/
confint-methods.R
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
114
115
116
117
118
#' @rdname confint
setMethod("confint", "EL", function(object,
parm,
level = 0.95,
cv = NULL,
control = NULL) {
# No confidence interval for an empty model
if (getDF(object) == 0L) {
ci <- matrix(numeric(0), nrow = 0L, ncol = 2L)
colnames(ci) <- c("lower", "upper")
return(ci)
}
stopifnot(
"`object` has no `data`. Fit the model with `keep_data == TRUE`." =
(isFALSE(is.null(getData(object))))
)
if (is.null(control)) {
control <- getControlEL(object)
} else {
assert_class(control, "ControlEL")
}
est <- coef(object)
# Index for tracking the parameters
idx <- seq(length(est))
# Row names of the confidence interval matrix
nm <- names(est)
pnames <- if (is.null(nm)) idx else nm
# If `parm` is supplied, modify idx and pnames accordingly
if (!missing(parm)) {
if (is.numeric(parm) && all(is.finite(parm))) {
pnames <- pnames[parm]
idx <- if (is.null(nm)) match(pnames, idx) else match(pnames, nm)
} else if (is.character(parm)) {
idx <- match(parm, pnames)
pnames <- parm
} else {
stop("Invalid `parm` specified.")
}
}
# Number of rows of the confidence interval matrix
p <- length(idx)
level <- assert_number(level, lower = 0, upper = 1, finite = TRUE)
if (isTRUE(all.equal(level, 0))) {
ci <- matrix(rep(est[idx], 2L), ncol = 2L)
colnames(ci) <- c("lower", "upper")
return(ci)
} else if (isTRUE(all.equal(level, 1))) {
ci <- matrix(NA_real_, nrow = p, ncol = 2L)
ci[which(!is.na(idx)), ] <- c(if (is(object, "SD")) 0 else -Inf, Inf)
colnames(ci) <- c("lower", "upper")
return(ci)
}
method <- getMethodEL(object)
maxit <- control@maxit
maxit_l <- control@maxit_l
tol <- control@tol
tol_l <- control@tol_l
step <- control@step
th <- control@th
nthreads <- control@nthreads
w <- getWeights(object)
cv <- if (is.null(cv)) qchisq(level, 1L) else validate_cv(cv, th)
if (all(is.na(idx))) {
ci <- matrix(NA_real_, nrow = p, ncol = 2L)
} else if (any(is.na(idx))) {
idx_na <- which(is.na(idx))
ci <- matrix(NA_real_, nrow = p, ncol = 2L)
ci[-idx_na, ] <- compute_confidence_intervals(
method, getEstimates(object), getData(object), cv, idx[-idx_na], maxit,
maxit_l, tol, tol_l, step, th, nthreads, w
)
} else {
ci <- compute_confidence_intervals(
method, getEstimates(object), getData(object), cv, idx, maxit, maxit_l,
tol, tol_l, step, th, nthreads, w
)
}
dimnames(ci) <- list(pnames, c("lower", "upper"))
ci
})
#' @rdname confint
setMethod("confint", "ELMT", function(object,
cv = NULL,
control = NULL) {
stopifnot(
"Each hypothesis must correspond to a linear combination of parameters." =
(isTRUE(all(getDF(object) == 1L))),
"`object` has no `data`. Fit the model with `keep_data == TRUE`." =
(isFALSE(is.null(getData(object))))
)
if (is.null(control)) {
control <- getControlEL(object)
} else {
assert_class(control, "ControlEL")
}
method <- getMethodEL(object)
maxit <- control@maxit
maxit_l <- control@maxit_l
tol <- control@tol
tol_l <- control@tol_l
step <- control@step
th <- control@th
cv <- if (is.null(cv)) object@cv else validate_cv(cv, th)
nthreads <- control@nthreads
w <- getWeights(object)
estimates <- unlist(getEstimates(object))
ci <- compute_confidence_intervals_EMLT(
method, getData(object), coef(object), object@lhs, estimates, cv, maxit,
maxit_l, tol, tol_l, step, th, nthreads, w
)
dimnames(ci) <-
list(
describe_hypothesis(object@rhs, object@lhs, colnames(object@lhs)),
c("lower", "upper")
)
ci
})