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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
#' Method to get the names of ill-defined parameters
#'
#' The method for generalised nonlinear regression fits as obtained
#' with [mkinfit] and [mmkin] checks if the degradation parameters
#' pass the Wald test (in degradation kinetics often simply called t-test) for
#' significant difference from zero. For this test, the parameterisation
#' without parameter transformations is used.
#'
#' The method for hierarchical model fits, also known as nonlinear
#' mixed-effects model fits as obtained with [saem] and [mhmkin]
#' checks if any of the confidence intervals for the random
#' effects expressed as standard deviations include zero, and if
#' the confidence intervals for the error model parameters include
#' zero.
#'
#' @param object The object to investigate
#' @param x The object to be printed
#' @param conf.level The confidence level for checking p values
#' @param \dots For potential future extensions
#' @param random For hierarchical fits, should random effects be tested?
#' @param errmod For hierarchical fits, should error model parameters be
#' tested?
#' @return For [mkinfit] or [saem] objects, a character vector of parameter
#' names. For [mmkin] or [mhmkin] objects, a matrix like object of class
#' 'illparms.mmkin' or 'illparms.mhmkin'.
#' @note All return objects have printing methods. For the single fits, printing
#' does not output anything in the case no ill-defined parameters are found.
#' @export
illparms <- function(object, ...)
{
UseMethod("illparms", object)
}
#' @rdname illparms
#' @export
#' @examples
#' fit <- mkinfit("FOMC", FOCUS_2006_A, quiet = TRUE)
#' illparms(fit)
illparms.mkinfit <- function(object, conf.level = 0.95, ...) {
p_values <- suppressWarnings(summary(object)$bpar[, "Pr(>t)"])
na <- is.na(p_values)
failed <- p_values > 1 - conf.level
ret <- names(parms(object))[na | failed]
class(ret) <- "illparms.mkinfit"
return(ret)
}
#' @rdname
#' @export
print.illparms.mkinfit <- function(x, ...) {
class(x) <- NULL
if (length(x) > 0) {
print(as.character(x))
}
}
#' @rdname illparms
#' @export
#' @examples
#' \dontrun{
#' fits <- mmkin(
#' c("SFO", "FOMC"),
#' list("FOCUS A" = FOCUS_2006_A,
#' "FOCUS C" = FOCUS_2006_C),
#' quiet = TRUE)
#' illparms(fits)
#' }
illparms.mmkin <- function(object, conf.level = 0.95, ...) {
result <- lapply(object,
function(fit) {
if (inherits(fit, "try-error")) return("E")
ill <- illparms(fit, conf.level = conf.level)
if (length(ill) > 0) {
return(paste(ill, collapse = ", "))
} else {
return("")
}
})
result <- unlist(result)
dim(result) <- dim(object)
dimnames(result) <- dimnames(object)
class(result) <- "illparms.mmkin"
return(result)
}
#' @rdname illparms
#' @export
print.illparms.mmkin <- function(x, ...) {
class(x) <- NULL
print(x, quote = FALSE)
}
#' @rdname illparms
#' @export
illparms.saem.mmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, ...) {
if (inherits(object, "try-error")) {
failed <- NA
} else {
ints <- intervals(object, conf.level = conf.level)
failed <- NULL
if (random) {
failed_random <- ints$random[, "lower"] < 0
failed <- c(failed, names(which(failed_random)))
}
if (errmod) {
failed_errmod <- ints$errmod[, "lower"] < 0 & ints$errmod[, "est."] > 0
failed <- c(failed, names(which(failed_errmod)))
}
}
class(failed) <- "illparms.saem.mmkin"
return(failed)
}
#' @export
print.illparms.saem.mmkin <- print.illparms.mkinfit
#' @rdname illparms
#' @export
illparms.mhmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, ...) {
if (inherits(object[[1]], "saem.mmkin")) {
check_failed <- function(x) if (inherits(x$so, "try-error")) TRUE else FALSE
}
result <- lapply(object,
function(fit) {
if (check_failed(fit)) {
return("E")
} else {
if (!is.null(fit$FIM_failed) &&
"random effects and error model parameters" %in% fit$FIM_failed) {
return("NA")
} else {
ill <- illparms(fit, conf.level = conf.level, random = random, errmod = errmod)
if (length(ill) > 0) {
return(paste(ill, collapse = ", "))
} else {
return("")
}
}
}
})
result <- unlist(result)
dim(result) <- dim(object)
dimnames(result) <- dimnames(object)
class(result) <- "illparms.mhmkin"
return(result)
}
#' @rdname illparms
#' @export
print.illparms.mhmkin <- function(x, ...) {
class(x) <- NULL
print(x, quote = FALSE)
}
|
