1 |
utils::globalVariables(c("predicted", "std")) |
|
2 | ||
3 |
#' Fit nonlinear mixed models with SAEM |
|
4 |
#' |
|
5 |
#' This function uses [saemix::saemix()] as a backend for fitting nonlinear mixed |
|
6 |
#' effects models created from [mmkin] row objects using the Stochastic Approximation |
|
7 |
#' Expectation Maximisation algorithm (SAEM). |
|
8 |
#' |
|
9 |
#' An mmkin row object is essentially a list of mkinfit objects that have been |
|
10 |
#' obtained by fitting the same model to a list of datasets using [mkinfit]. |
|
11 |
#' |
|
12 |
#' Starting values for the fixed effects (population mean parameters, argument |
|
13 |
#' psi0 of [saemix::saemixModel()] are the mean values of the parameters found |
|
14 |
#' using [mmkin]. |
|
15 |
#' |
|
16 |
#' @importFrom utils packageVersion |
|
17 |
#' @importFrom saemix saemix |
|
18 |
#' @param object An [mmkin] row object containing several fits of the same |
|
19 |
#' [mkinmod] model to different datasets |
|
20 |
#' @param verbose Should we print information about created objects of |
|
21 |
#' type [saemix::SaemixModel] and [saemix::SaemixData]? |
|
22 |
#' @param transformations Per default, all parameter transformations are done |
|
23 |
#' in mkin. If this argument is set to 'saemix', parameter transformations |
|
24 |
#' are done in 'saemix' for the supported cases, i.e. (as of version 1.1.2) |
|
25 |
#' SFO, FOMC, DFOP and HS without fixing `parent_0`, and SFO or DFOP with |
|
26 |
#' one SFO metabolite. |
|
27 |
#' @param error_model Possibility to override the error model used in the mmkin object |
|
28 |
#' @param degparms_start Parameter values given as a named numeric vector will |
|
29 |
#' be used to override the starting values obtained from the 'mmkin' object. |
|
30 |
#' @param test_log_parms If TRUE, an attempt is made to use more robust starting |
|
31 |
#' values for population parameters fitted as log parameters in mkin (like |
|
32 |
#' rate constants) by only considering rate constants that pass the t-test |
|
33 |
#' when calculating mean degradation parameters using [mean_degparms]. |
|
34 |
#' @param conf.level Possibility to adjust the required confidence level |
|
35 |
#' for parameter that are tested if requested by 'test_log_parms'. |
|
36 |
#' @param solution_type Possibility to specify the solution type in case the |
|
37 |
#' automatic choice is not desired |
|
38 |
#' @param no_random_effect Character vector of degradation parameters for |
|
39 |
#' which there should be no variability over the groups. Only used |
|
40 |
#' if the covariance model is not explicitly specified. |
|
41 |
#' @param covariance.model Will be passed to [saemix::saemixModel()]. Per |
|
42 |
#' default, uncorrelated random effects are specified for all degradation |
|
43 |
#' parameters. |
|
44 |
#' @param omega.init Will be passed to [saemix::saemixModel()]. If using |
|
45 |
#' mkin transformations and the default covariance model with optionally |
|
46 |
#' excluded random effects, the variances of the degradation parameters |
|
47 |
#' are estimated using [mean_degparms], with testing of untransformed |
|
48 |
#' log parameters for significant difference from zero. If not using |
|
49 |
#' mkin transformations or a custom covariance model, the default |
|
50 |
#' initialisation of [saemix::saemixModel] is used for omega.init. |
|
51 |
#' @param covariates A data frame with covariate data for use in |
|
52 |
#' 'covariate_models', with dataset names as row names. |
|
53 |
#' @param covariate_models A list containing linear model formulas with one explanatory |
|
54 |
#' variable, i.e. of the type 'parameter ~ covariate'. Covariates must be available |
|
55 |
#' in the 'covariates' data frame. |
|
56 |
#' @param error.init Will be passed to [saemix::saemixModel()]. |
|
57 |
#' @param quiet Should we suppress the messages saemix prints at the beginning |
|
58 |
#' and the end of the optimisation process? |
|
59 |
#' @param nbiter.saemix Convenience option to increase the number of |
|
60 |
#' iterations |
|
61 |
#' @param control Passed to [saemix::saemix]. |
|
62 |
#' @param \dots Further parameters passed to [saemix::saemixModel]. |
|
63 |
#' @return An S3 object of class 'saem.mmkin', containing the fitted |
|
64 |
#' [saemix::SaemixObject] as a list component named 'so'. The |
|
65 |
#' object also inherits from 'mixed.mmkin'. |
|
66 |
#' @seealso [summary.saem.mmkin] [plot.mixed.mmkin] |
|
67 |
#' @examples |
|
68 |
#' \dontrun{ |
|
69 |
#' ds <- lapply(experimental_data_for_UBA_2019[6:10], |
|
70 |
#' function(x) subset(x$data[c("name", "time", "value")])) |
|
71 |
#' names(ds) <- paste("Dataset", 6:10) |
|
72 |
#' f_mmkin_parent_p0_fixed <- mmkin("FOMC", ds, |
|
73 |
#' state.ini = c(parent = 100), fixed_initials = "parent", quiet = TRUE) |
|
74 |
#' f_saem_p0_fixed <- saem(f_mmkin_parent_p0_fixed) |
|
75 |
#' |
|
76 |
#' f_mmkin_parent <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE) |
|
77 |
#' f_saem_sfo <- saem(f_mmkin_parent["SFO", ]) |
|
78 |
#' f_saem_fomc <- saem(f_mmkin_parent["FOMC", ]) |
|
79 |
#' f_saem_dfop <- saem(f_mmkin_parent["DFOP", ]) |
|
80 |
#' anova(f_saem_sfo, f_saem_fomc, f_saem_dfop) |
|
81 |
#' anova(f_saem_sfo, f_saem_dfop, test = TRUE) |
|
82 |
#' illparms(f_saem_dfop) |
|
83 |
#' f_saem_dfop_red <- update(f_saem_dfop, no_random_effect = "g_qlogis") |
|
84 |
#' anova(f_saem_dfop, f_saem_dfop_red, test = TRUE) |
|
85 |
#' |
|
86 |
#' anova(f_saem_sfo, f_saem_fomc, f_saem_dfop) |
|
87 |
#' # The returned saem.mmkin object contains an SaemixObject, therefore we can use |
|
88 |
#' # functions from saemix |
|
89 |
#' library(saemix) |
|
90 |
#' compare.saemix(f_saem_sfo$so, f_saem_fomc$so, f_saem_dfop$so) |
|
91 |
#' plot(f_saem_fomc$so, plot.type = "convergence") |
|
92 |
#' plot(f_saem_fomc$so, plot.type = "individual.fit") |
|
93 |
#' plot(f_saem_fomc$so, plot.type = "npde") |
|
94 |
#' plot(f_saem_fomc$so, plot.type = "vpc") |
|
95 |
#' |
|
96 |
#' f_mmkin_parent_tc <- update(f_mmkin_parent, error_model = "tc") |
|
97 |
#' f_saem_fomc_tc <- saem(f_mmkin_parent_tc["FOMC", ]) |
|
98 |
#' anova(f_saem_fomc, f_saem_fomc_tc, test = TRUE) |
|
99 |
#' |
|
100 |
#' sfo_sfo <- mkinmod(parent = mkinsub("SFO", "A1"), |
|
101 |
#' A1 = mkinsub("SFO")) |
|
102 |
#' fomc_sfo <- mkinmod(parent = mkinsub("FOMC", "A1"), |
|
103 |
#' A1 = mkinsub("SFO")) |
|
104 |
#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"), |
|
105 |
#' A1 = mkinsub("SFO")) |
|
106 |
#' # The following fit uses analytical solutions for SFO-SFO and DFOP-SFO, |
|
107 |
#' # and compiled ODEs for FOMC that are much slower |
|
108 |
#' f_mmkin <- mmkin(list( |
|
109 |
#' "SFO-SFO" = sfo_sfo, "FOMC-SFO" = fomc_sfo, "DFOP-SFO" = dfop_sfo), |
|
110 |
#' ds, quiet = TRUE) |
|
111 |
#' # saem fits of SFO-SFO and DFOP-SFO to these data take about five seconds |
|
112 |
#' # each on this system, as we use analytical solutions written for saemix. |
|
113 |
#' # When using the analytical solutions written for mkin this took around |
|
114 |
#' # four minutes |
|
115 |
#' f_saem_sfo_sfo <- saem(f_mmkin["SFO-SFO", ]) |
|
116 |
#' f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ]) |
|
117 |
#' # We can use print, plot and summary methods to check the results |
|
118 |
#' print(f_saem_dfop_sfo) |
|
119 |
#' plot(f_saem_dfop_sfo) |
|
120 |
#' summary(f_saem_dfop_sfo, data = TRUE) |
|
121 |
#' |
|
122 |
#' # The following takes about 6 minutes |
|
123 |
#' f_saem_dfop_sfo_deSolve <- saem(f_mmkin["DFOP-SFO", ], solution_type = "deSolve", |
|
124 |
#' nbiter.saemix = c(200, 80)) |
|
125 |
#' |
|
126 |
#' #anova( |
|
127 |
#' # f_saem_dfop_sfo, |
|
128 |
#' # f_saem_dfop_sfo_deSolve)) |
|
129 |
#' |
|
130 |
#' # If the model supports it, we can also use eigenvalue based solutions, which |
|
131 |
#' # take a similar amount of time |
|
132 |
#' #f_saem_sfo_sfo_eigen <- saem(f_mmkin["SFO-SFO", ], solution_type = "eigen", |
|
133 |
#' # control = list(nbiter.saemix = c(200, 80), nbdisplay = 10)) |
|
134 |
#' } |
|
135 |
#' @export |
|
136 | 2411x |
saem <- function(object, ...) UseMethod("saem") |
137 | ||
138 |
#' @rdname saem |
|
139 |
#' @export |
|
140 |
saem.mmkin <- function(object, |
|
141 |
transformations = c("mkin", "saemix"), |
|
142 |
error_model = "auto", |
|
143 |
degparms_start = numeric(), |
|
144 |
test_log_parms = TRUE, |
|
145 |
conf.level = 0.6, |
|
146 |
solution_type = "auto", |
|
147 |
covariance.model = "auto", |
|
148 |
omega.init = "auto", |
|
149 |
covariates = NULL, |
|
150 |
covariate_models = NULL, |
|
151 |
no_random_effect = NULL, |
|
152 |
error.init = c(1, 1), |
|
153 |
nbiter.saemix = c(300, 100), |
|
154 |
control = list(displayProgress = FALSE, print = FALSE, |
|
155 |
nbiter.saemix = nbiter.saemix, |
|
156 |
save = FALSE, save.graphs = FALSE), |
|
157 |
verbose = FALSE, quiet = FALSE, ...) |
|
158 |
{ |
|
159 | 2411x |
call <- match.call() |
160 | 2411x |
transformations <- match.arg(transformations) |
161 | 2411x |
m_saemix <- saemix_model(object, verbose = verbose, |
162 | 2411x |
error_model = error_model, |
163 | 2411x |
degparms_start = degparms_start, |
164 | 2411x |
test_log_parms = test_log_parms, conf.level = conf.level, |
165 | 2411x |
solution_type = solution_type, |
166 | 2411x |
transformations = transformations, |
167 | 2411x |
covariance.model = covariance.model, |
168 | 2411x |
omega.init = omega.init, |
169 | 2411x |
covariates = covariates, |
170 | 2411x |
covariate_models = covariate_models, |
171 | 2411x |
error.init = error.init, |
172 | 2411x |
no_random_effect = no_random_effect, |
173 |
...) |
|
174 | 2187x |
d_saemix <- saemix_data(object, covariates = covariates, verbose = verbose) |
175 | ||
176 | 2187x |
fit_failed <- FALSE |
177 | 2187x |
FIM_failed <- NULL |
178 | 2187x |
fit_time <- system.time({ |
179 | 2187x |
utils::capture.output(f_saemix <- try(saemix(m_saemix, d_saemix, control)), split = !quiet) |
180 | ! |
if (inherits(f_saemix, "try-error")) fit_failed <- TRUE |
181 |
}) |
|
182 | ||
183 | 2187x |
return_data <- nlme_data(object) |
184 | ||
185 | 2187x |
if (!fit_failed) { |
186 | ! |
if (any(is.na(f_saemix@results@se.fixed))) FIM_failed <- c(FIM_failed, "fixed effects") |
187 | 2187x |
if (any(is.na(c(f_saemix@results@se.omega, f_saemix@results@se.respar)))) { |
188 | ! |
FIM_failed <- c(FIM_failed, "random effects and error model parameters") |
189 |
} |
|
190 | ||
191 | 2187x |
transparms_optim <- f_saemix@results@fixed.effects |
192 | 2187x |
names(transparms_optim) <- f_saemix@results@name.fixed |
193 | ||
194 | 2187x |
if (transformations == "mkin") { |
195 | 1413x |
bparms_optim <- backtransform_odeparms(transparms_optim, |
196 | 1413x |
object[[1]]$mkinmod, |
197 | 1413x |
object[[1]]$transform_rates, |
198 | 1413x |
object[[1]]$transform_fractions) |
199 |
} else { |
|
200 | 774x |
bparms_optim <- transparms_optim |
201 |
} |
|
202 | ||
203 | 2187x |
saemix_data_ds <- f_saemix@data@data$ds |
204 | 2187x |
mkin_ds_order <- as.character(unique(return_data$ds)) |
205 | 2187x |
saemix_ds_order <- unique(saemix_data_ds) |
206 | ||
207 | 2187x |
psi <- saemix::psi(f_saemix) |
208 | 2187x |
rownames(psi) <- saemix_ds_order |
209 | 2187x |
return_data$predicted <- f_saemix@model@model( |
210 | 2187x |
psi = psi[mkin_ds_order, ], |
211 | 2187x |
id = as.numeric(return_data$ds), |
212 | 2187x |
xidep = return_data[c("time", "name")]) |
213 | ||
214 | 2187x |
return_data <- transform(return_data, |
215 | 2187x |
residual = value - predicted, |
216 | 2187x |
std = sigma_twocomp(predicted, |
217 | 2187x |
f_saemix@results@respar[1], f_saemix@results@respar[2])) |
218 | 2187x |
return_data <- transform(return_data, |
219 | 2187x |
standardized = residual / std) |
220 |
} |
|
221 | ||
222 | 2187x |
result <- list( |
223 | 2187x |
mkinmod = object[[1]]$mkinmod, |
224 | 2187x |
mmkin = object, |
225 | 2187x |
solution_type = object[[1]]$solution_type, |
226 | 2187x |
transformations = transformations, |
227 | 2187x |
transform_rates = object[[1]]$transform_rates, |
228 | 2187x |
transform_fractions = object[[1]]$transform_fractions, |
229 | 2187x |
covariates = covariates, |
230 | 2187x |
covariate_models = covariate_models, |
231 | 2187x |
sm = m_saemix, |
232 | 2187x |
so = f_saemix, |
233 | 2187x |
call = call, |
234 | 2187x |
time = fit_time, |
235 | 2187x |
FIM_failed = FIM_failed, |
236 | 2187x |
mean_dp_start = attr(m_saemix, "mean_dp_start"), |
237 | 2187x |
bparms.fixed = object[[1]]$bparms.fixed, |
238 | 2187x |
data = return_data, |
239 | 2187x |
err_mod = object[[1]]$err_mod, |
240 | 2187x |
date.fit = date(), |
241 | 2187x |
saemixversion = as.character(utils::packageVersion("saemix")), |
242 | 2187x |
mkinversion = as.character(utils::packageVersion("mkin")), |
243 | 2187x |
Rversion = paste(R.version$major, R.version$minor, sep=".") |
244 |
) |
|
245 | ||
246 | 2187x |
if (!fit_failed) { |
247 | 2187x |
result$mkin_ds_order <- mkin_ds_order |
248 | 2187x |
result$saemix_ds_order <- saemix_ds_order |
249 | 2187x |
result$bparms.optim <- bparms_optim |
250 |
} |
|
251 | ||
252 | 2187x |
class(result) <- c("saem.mmkin", "mixed.mmkin") |
253 | 2187x |
return(result) |
254 |
} |
|
255 | ||
256 |
#' @export |
|
257 |
#' @rdname saem |
|
258 |
#' @param x An saem.mmkin object to print |
|
259 |
#' @param digits Number of digits to use for printing |
|
260 |
print.saem.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { |
|
261 | 234x |
cat( "Kinetic nonlinear mixed-effects model fit by SAEM" ) |
262 | 234x |
cat("\nStructural model:\n") |
263 | 234x |
diffs <- x$mmkin[[1]]$mkinmod$diffs |
264 | 234x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs) |
265 | 234x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
266 | 234x |
cat("\nData:\n") |
267 | 234x |
cat(nrow(x$data), "observations of", |
268 | 234x |
length(unique(x$data$name)), "variable(s) grouped in", |
269 | 234x |
length(unique(x$data$ds)), "datasets\n") |
270 | ||
271 | 234x |
if (inherits(x$so, "try-error")) { |
272 | ! |
cat("\nFit did not terminate successfully\n") |
273 |
} else { |
|
274 | 234x |
cat("\nLikelihood computed by importance sampling\n") |
275 | 234x |
ll <- try(logLik(x$so, type = "is"), silent = TRUE) |
276 | 234x |
if (inherits(ll, "try-error")) { |
277 | ! |
cat("Not available\n") |
278 |
} else { |
|
279 | 234x |
print(data.frame( |
280 | 234x |
AIC = AIC(x$so, type = "is"), |
281 | 234x |
BIC = BIC(x$so, type = "is"), |
282 | 234x |
logLik = logLik(x$so, type = "is"), |
283 | 234x |
row.names = " "), digits = digits) |
284 |
} |
|
285 | ||
286 | 234x |
cat("\nFitted parameters:\n") |
287 | 234x |
conf.int <- parms(x, ci = TRUE) |
288 | 234x |
print(conf.int, digits = digits) |
289 |
} |
|
290 | ||
291 | 234x |
invisible(x) |
292 |
} |
|
293 | ||
294 |
#' @rdname saem |
|
295 |
#' @return An [saemix::SaemixModel] object. |
|
296 |
#' @export |
|
297 |
saemix_model <- function(object, solution_type = "auto", |
|
298 |
transformations = c("mkin", "saemix"), error_model = "auto", |
|
299 |
degparms_start = numeric(), |
|
300 |
covariance.model = "auto", no_random_effect = NULL, |
|
301 |
omega.init = "auto", |
|
302 |
covariates = NULL, covariate_models = NULL, |
|
303 |
error.init = numeric(), |
|
304 |
test_log_parms = FALSE, conf.level = 0.6, verbose = FALSE, ...) |
|
305 |
{ |
|
306 | 65x |
if (nrow(object) > 1) stop("Only row objects allowed") |
307 | ||
308 | 2346x |
mkin_model <- object[[1]]$mkinmod |
309 | ||
310 | 2346x |
if (length(mkin_model$spec) > 1 & solution_type[1] == "analytical") { |
311 | 104x |
stop("mkin analytical solutions not supported for more thane one observed variable") |
312 |
} |
|
313 | ||
314 | 2242x |
degparms_optim <- mean_degparms(object, test_log_parms = test_log_parms) |
315 | 2242x |
na_degparms <- names(which(is.na(degparms_optim))) |
316 | 2242x |
if (length(na_degparms) > 0) { |
317 | ! |
message("Did not find valid starting values for ", paste(na_degparms, collapse = ", "), "\n", |
318 | ! |
"Now trying with test_log_parms = FALSE") |
319 | ! |
degparms_optim <- mean_degparms(object, test_log_parms = FALSE) |
320 |
} |
|
321 | 2242x |
if (transformations == "saemix") { |
322 | 779x |
degparms_optim <- backtransform_odeparms(degparms_optim, |
323 | 779x |
object[[1]]$mkinmod, |
324 | 779x |
object[[1]]$transform_rates, |
325 | 779x |
object[[1]]$transform_fractions) |
326 |
} |
|
327 | 2242x |
degparms_fixed <- object[[1]]$bparms.fixed |
328 | ||
329 |
# Transformations are done in the degradation function by default |
|
330 |
# (transformations = "mkin") |
|
331 | 2242x |
transform.par = rep(0, length(degparms_optim)) |
332 | ||
333 | 2242x |
odeini_optim_parm_names <- grep('_0$', names(degparms_optim), value = TRUE) |
334 | 2242x |
odeini_fixed_parm_names <- grep('_0$', names(degparms_fixed), value = TRUE) |
335 | ||
336 | 2242x |
odeparms_fixed_names <- setdiff(names(degparms_fixed), odeini_fixed_parm_names) |
337 | 2242x |
odeparms_fixed <- degparms_fixed[odeparms_fixed_names] |
338 | ||
339 | 2242x |
odeini_fixed <- degparms_fixed[odeini_fixed_parm_names] |
340 | 2242x |
names(odeini_fixed) <- gsub('_0$', '', odeini_fixed_parm_names) |
341 | ||
342 | 2242x |
model_function <- FALSE |
343 | ||
344 |
# Model functions with analytical solutions |
|
345 |
# Fixed parameters, use_of_ff = "min" and turning off sinks currently not supported here |
|
346 |
# In general, we need to consider exactly how the parameters in mkinfit were specified, |
|
347 |
# as the parameters are currently mapped by position in these solutions |
|
348 | 2242x |
sinks <- sapply(mkin_model$spec, function(x) x$sink) |
349 | 2242x |
if (length(odeparms_fixed) == 0 & mkin_model$use_of_ff == "max" & all(sinks)) { |
350 |
# Parent only |
|
351 | 2242x |
if (length(mkin_model$spec) == 1) { |
352 | 1748x |
parent_type <- mkin_model$spec[[1]]$type |
353 | 1748x |
if (length(odeini_fixed) == 1 && !grepl("_bound$", names(odeini_fixed))) { |
354 | 50x |
if (transformations == "saemix") { |
355 | ! |
stop("saemix transformations are not supported for parent fits with fixed initial parent value") |
356 |
} |
|
357 | 50x |
if (parent_type == "SFO") { |
358 | 50x |
stop("saemix needs at least two parameters to work on.") |
359 |
} |
|
360 | ! |
if (parent_type == "FOMC") { |
361 | ! |
model_function <- function(psi, id, xidep) { |
362 | ! |
odeini_fixed / (xidep[, "time"]/exp(psi[id, 2]) + 1)^exp(psi[id, 1]) |
363 |
} |
|
364 |
} |
|
365 | ! |
if (parent_type == "DFOP") { |
366 | ! |
model_function <- function(psi, id, xidep) { |
367 | ! |
g <- plogis(psi[id, 3]) |
368 | ! |
t <- xidep[, "time"] |
369 | ! |
odeini_fixed * (g * exp(- exp(psi[id, 1]) * t) + |
370 | ! |
(1 - g) * exp(- exp(psi[id, 2]) * t)) |
371 |
} |
|
372 |
} |
|
373 | ! |
if (parent_type == "HS") { |
374 | ! |
model_function <- function(psi, id, xidep) { |
375 | ! |
tb <- exp(psi[id, 3]) |
376 | ! |
t <- xidep[, "time"] |
377 | ! |
k1 = exp(psi[id, 1]) |
378 | ! |
odeini_fixed * ifelse(t <= tb, |
379 | ! |
exp(- k1 * t), |
380 | ! |
exp(- k1 * tb) * exp(- exp(psi[id, 2]) * (t - tb))) |
381 |
} |
|
382 |
} |
|
383 |
} else { |
|
384 | 1698x |
if (length(odeini_fixed) == 2) { |
385 | ! |
stop("SFORB with fixed initial parent value is not supported") |
386 |
} |
|
387 | 1698x |
if (parent_type == "SFO") { |
388 | 785x |
if (transformations == "mkin") { |
389 | 283x |
model_function <- function(psi, id, xidep) { |
390 | 2628025x |
psi[id, 1] * exp( - exp(psi[id, 2]) * xidep[, "time"]) |
391 |
} |
|
392 |
} else { |
|
393 | 502x |
model_function <- function(psi, id, xidep) { |
394 | 4054103x |
psi[id, 1] * exp( - psi[id, 2] * xidep[, "time"]) |
395 |
} |
|
396 | 502x |
transform.par = c(0, 1) |
397 |
} |
|
398 |
} |
|
399 | 1698x |
if (parent_type == "FOMC") { |
400 | 76x |
if (transformations == "mkin") { |
401 | 41x |
model_function <- function(psi, id, xidep) { |
402 | 510269x |
psi[id, 1] / (xidep[, "time"]/exp(psi[id, 3]) + 1)^exp(psi[id, 2]) |
403 |
} |
|
404 |
} else { |
|
405 | 35x |
model_function <- function(psi, id, xidep) { |
406 | 432565x |
psi[id, 1] / (xidep[, "time"]/psi[id, 3] + 1)^psi[id, 2] |
407 |
} |
|
408 | 35x |
transform.par = c(0, 1, 1) |
409 |
} |
|
410 |
} |
|
411 | 1698x |
if (parent_type == "DFOP") { |
412 | 677x |
if (transformations == "mkin") { |
413 | 637x |
model_function <- function(psi, id, xidep) { |
414 | 8785439x |
g <- plogis(psi[id, 4]) |
415 | 8785439x |
t <- xidep[, "time"] |
416 | 8785439x |
psi[id, 1] * (g * exp(- exp(psi[id, 2]) * t) + |
417 | 8785439x |
(1 - g) * exp(- exp(psi[id, 3]) * t)) |
418 |
} |
|
419 |
} else { |
|
420 | 40x |
model_function <- function(psi, id, xidep) { |
421 | 507885x |
g <- psi[id, 4] |
422 | 507885x |
t <- xidep[, "time"] |
423 | 507885x |
psi[id, 1] * (g * exp(- psi[id, 2] * t) + |
424 | 507885x |
(1 - g) * exp(- psi[id, 3] * t)) |
425 |
} |
|
426 | 40x |
transform.par = c(0, 1, 1, 3) |
427 |
} |
|
428 |
} |
|
429 | 1698x |
if (parent_type == "SFORB") { |
430 | 150x |
if (transformations == "mkin") { |
431 | 130x |
model_function <- function(psi, id, xidep) { |
432 | 1240580x |
k_12 <- exp(psi[id, 3]) |
433 | 1240580x |
k_21 <- exp(psi[id, 4]) |
434 | 1240580x |
k_1output <- exp(psi[id, 2]) |
435 | 1240580x |
t <- xidep[, "time"] |
436 | ||
437 | 1240580x |
sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21) |
438 | 1240580x |
b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp |
439 | 1240580x |
b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp |
440 | ||
441 | 1240580x |
psi[id, 1] * (((k_12 + k_21 - b1)/(b2 - b1)) * exp(-b1 * t) + |
442 | 1240580x |
((k_12 + k_21 - b2)/(b1 - b2)) * exp(-b2 * t)) |
443 |
} |
|
444 |
} else { |
|
445 | 20x |
model_function <- function(psi, id, xidep) { |
446 | 290980x |
k_12 <- psi[id, 3] |
447 | 290980x |
k_21 <- psi[id, 4] |
448 | 290980x |
k_1output <- psi[id, 2] |
449 | 290980x |
t <- xidep[, "time"] |
450 | ||
451 | 290980x |
sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21) |
452 | 290980x |
b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp |
453 | 290980x |
b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp |
454 | ||
455 | 290980x |
psi[id, 1] * (((k_12 + k_21 - b1)/(b2 - b1)) * exp(-b1 * t) + |
456 | 290980x |
((k_12 + k_21 - b2)/(b1 - b2)) * exp(-b2 * t)) |
457 |
} |
|
458 | 20x |
transform.par = c(0, 1, 1, 1) |
459 |
} |
|
460 |
} |
|
461 | 1698x |
if (parent_type == "HS") { |
462 | 10x |
if (transformations == "mkin") { |
463 | 10x |
model_function <- function(psi, id, xidep) { |
464 | 150610x |
tb <- exp(psi[id, 4]) |
465 | 150610x |
t <- xidep[, "time"] |
466 | 150610x |
k1 <- exp(psi[id, 2]) |
467 | 150610x |
psi[id, 1] * ifelse(t <= tb, |
468 | 150610x |
exp(- k1 * t), |
469 | 150610x |
exp(- k1 * tb) * exp(- exp(psi[id, 3]) * (t - tb))) |
470 |
} |
|
471 |
} else { |
|
472 | ! |
model_function <- function(psi, id, xidep) { |
473 | ! |
tb <- psi[id, 4] |
474 | ! |
t <- xidep[, "time"] |
475 | ! |
psi[id, 1] * ifelse(t <= tb, |
476 | ! |
exp(- psi[id, 2] * t), |
477 | ! |
exp(- psi[id, 2] * tb) * exp(- psi[id, 3] * (t - tb))) |
478 |
} |
|
479 | ! |
transform.par = c(0, 1, 1, 1) |
480 |
} |
|
481 |
} |
|
482 |
} |
|
483 |
} |
|
484 | ||
485 |
# Parent with one metabolite |
|
486 |
# Parameter names used in the model functions are as in |
|
487 |
# https://nbviewer.jupyter.org/urls/jrwb.de/nb/Symbolic%20ODE%20solutions%20for%20mkin.ipynb |
|
488 | 2192x |
types <- unname(sapply(mkin_model$spec, function(x) x$type)) |
489 | 2192x |
if (length(mkin_model$spec) == 2 &! "SFORB" %in% types ) { |
490 |
# Initial value for the metabolite (n20) must be fixed |
|
491 | 494x |
if (names(odeini_fixed) == names(mkin_model$spec)[2]) { |
492 | 494x |
n20 <- odeini_fixed |
493 | 494x |
parent_name <- names(mkin_model$spec)[1] |
494 | 494x |
if (identical(types, c("SFO", "SFO"))) { |
495 | 208x |
if (transformations == "mkin") { |
496 | 208x |
model_function <- function(psi, id, xidep) { |
497 | 873912x |
t <- xidep[, "time"] |
498 | 873912x |
n10 <- psi[id, 1] |
499 | 873912x |
k1 <- exp(psi[id, 2]) |
500 | 873912x |
k2 <- exp(psi[id, 3]) |
501 | 873912x |
f12 <- plogis(psi[id, 4]) |
502 | 873912x |
ifelse(xidep[, "name"] == parent_name, |
503 | 873912x |
n10 * exp(- k1 * t), |
504 | 873912x |
(((k2 - k1) * n20 - f12 * k1 * n10) * exp(- k2 * t)) / (k2 - k1) + |
505 | 873912x |
(f12 * k1 * n10 * exp(- k1 * t)) / (k2 - k1) |
506 |
) |
|
507 |
} |
|
508 |
} else { |
|
509 | ! |
model_function <- function(psi, id, xidep) { |
510 | ! |
t <- xidep[, "time"] |
511 | ! |
n10 <- psi[id, 1] |
512 | ! |
k1 <- psi[id, 2] |
513 | ! |
k2 <- psi[id, 3] |
514 | ! |
f12 <- psi[id, 4] |
515 | ! |
ifelse(xidep[, "name"] == parent_name, |
516 | ! |
n10 * exp(- k1 * t), |
517 | ! |
(((k2 - k1) * n20 - f12 * k1 * n10) * exp(- k2 * t)) / (k2 - k1) + |
518 | ! |
(f12 * k1 * n10 * exp(- k1 * t)) / (k2 - k1) |
519 |
) |
|
520 |
} |
|
521 | ! |
transform.par = c(0, 1, 1, 3) |
522 |
} |
|
523 |
} |
|
524 | 494x |
if (identical(types, c("DFOP", "SFO"))) { |
525 | 286x |
if (transformations == "mkin") { |
526 | 104x |
model_function <- function(psi, id, xidep) { |
527 | 1821022x |
t <- xidep[, "time"] |
528 | 1821022x |
n10 <- psi[id, 1] |
529 | 1821022x |
k2 <- exp(psi[id, 2]) |
530 | 1821022x |
f12 <- plogis(psi[id, 3]) |
531 | 1821022x |
l1 <- exp(psi[id, 4]) |
532 | 1821022x |
l2 <- exp(psi[id, 5]) |
533 | 1821022x |
g <- plogis(psi[id, 6]) |
534 | 1821022x |
ifelse(xidep[, "name"] == parent_name, |
535 | 1821022x |
n10 * (g * exp(- l1 * t) + (1 - g) * exp(- l2 * t)), |
536 | 1821022x |
((f12 * g - f12) * l2 * n10 * exp(- l2 * t)) / (l2 - k2) - |
537 | 1821022x |
(f12 * g * l1 * n10 * exp(- l1 * t)) / (l1 - k2) + |
538 | 1821022x |
((((l1 - k2) * l2 - k2 * l1 + k2^2) * n20 + |
539 | 1821022x |
((f12 * l1 + (f12 * g - f12) * k2) * l2 - |
540 | 1821022x |
f12 * g * k2 * l1) * n10) * exp( - k2 * t)) / |
541 | 1821022x |
((l1 - k2) * l2 - k2 * l1 + k2^2) |
542 |
) |
|
543 |
} |
|
544 |
} else { |
|
545 | 182x |
model_function <- function(psi, id, xidep) { |
546 | 2908620x |
t <- xidep[, "time"] |
547 | 2908620x |
n10 <- psi[id, 1] |
548 | 2908620x |
k2 <- psi[id, 2] |
549 | 2908620x |
f12 <- psi[id, 3] |
550 | 2908620x |
l1 <- psi[id, 4] |
551 | 2908620x |
l2 <- psi[id, 5] |
552 | 2908620x |
g <- psi[id, 6] |
553 | 2908620x |
ifelse(xidep[, "name"] == parent_name, |
554 | 2908620x |
n10 * (g * exp(- l1 * t) + (1 - g) * exp(- l2 * t)), |
555 | 2908620x |
((f12 * g - f12) * l2 * n10 * exp(- l2 * t)) / (l2 - k2) - |
556 | 2908620x |
(f12 * g * l1 * n10 * exp(- l1 * t)) / (l1 - k2) + |
557 | 2908620x |
((((l1 - k2) * l2 - k2 * l1 + k2^2) * n20 + |
558 | 2908620x |
((f12 * l1 + (f12 * g - f12) * k2) * l2 - |
559 | 2908620x |
f12 * g * k2 * l1) * n10) * exp( - k2 * t)) / |
560 | 2908620x |
((l1 - k2) * l2 - k2 * l1 + k2^2) |
561 |
) |
|
562 |
} |
|
563 | 182x |
transform.par = c(0, 1, 3, 1, 1, 3) |
564 |
} |
|
565 |
} |
|
566 |
} |
|
567 |
} |
|
568 |
} |
|
569 | ||
570 | 2192x |
if (is.function(model_function) & solution_type == "auto") { |
571 | 2083x |
solution_type = "analytical saemix" |
572 |
} else { |
|
573 | ||
574 | 109x |
if (transformations == "saemix") { |
575 | 5x |
stop("Using saemix transformations is only supported if an analytical solution is implemented for saemix") |
576 |
} |
|
577 | ||
578 | 104x |
if (solution_type == "auto") |
579 | ! |
solution_type <- object[[1]]$solution_type |
580 | ||
581 |
# Define some variables to avoid function calls in model function |
|
582 | 104x |
transparms_optim_names <- names(degparms_optim) |
583 | 104x |
odeini_optim_names <- gsub('_0$', '', odeini_optim_parm_names) |
584 | 104x |
diff_names <- names(mkin_model$diffs) |
585 | 104x |
ode_transparms_optim_names <- setdiff(transparms_optim_names, odeini_optim_parm_names) |
586 | 104x |
transform_rates <- object[[1]]$transform_rates |
587 | 104x |
transform_fractions <- object[[1]]$transform_fractions |
588 | ||
589 |
# Get native symbol info for speed |
|
590 | 104x |
use_symbols = FALSE |
591 | 104x |
if (solution_type == "deSolve" & !is.null(mkin_model$cf)) { |
592 | 104x |
mkin_model$symbols <- try(deSolve::checkDLL( |
593 | 104x |
dllname = mkin_model$dll_info[["name"]], |
594 | 104x |
func = "diffs", initfunc = "initpar", |
595 | 104x |
jacfunc = NULL, nout = 0, outnames = NULL)) |
596 | 104x |
if (!inherits(mkin_model$symbols, "try-error")) { |
597 | 104x |
use_symbols = TRUE |
598 |
} |
|
599 |
} |
|
600 | ||
601 |
# Define the model function |
|
602 | 104x |
model_function <- function(psi, id, xidep) { |
603 | ||
604 | 873912x |
uid <- unique(id) |
605 | ||
606 | 873912x |
res_list <- lapply(uid, function(i) { |
607 | ||
608 | 43671888x |
transparms_optim <- as.numeric(psi[i, ]) # psi[i, ] is a dataframe when called in saemix.predict |
609 | 43671888x |
names(transparms_optim) <- transparms_optim_names |
610 | ||
611 | 43671888x |
odeini_optim <- transparms_optim[odeini_optim_parm_names] |
612 | 43671888x |
names(odeini_optim) <- odeini_optim_names |
613 | ||
614 | 43671888x |
odeini <- c(odeini_optim, odeini_fixed)[diff_names] |
615 | ||
616 | 43671888x |
odeparms_optim <- backtransform_odeparms(transparms_optim[ode_transparms_optim_names], mkin_model, |
617 | 43671888x |
transform_rates = transform_rates, |
618 | 43671888x |
transform_fractions = transform_fractions) |
619 | 43671888x |
odeparms <- c(odeparms_optim, odeparms_fixed) |
620 | ||
621 | 43671888x |
xidep_i <- xidep[which(id == i), ] |
622 | ||
623 | 43671888x |
if (solution_type[1] == "analytical") { |
624 | ! |
out_values <- mkin_model$deg_func(xidep_i, odeini, odeparms) |
625 |
} else { |
|
626 | ||
627 | 43671888x |
i_time <- xidep_i$time |
628 | 43671888x |
i_name <- xidep_i$name |
629 | ||
630 | 43671888x |
out_wide <- mkinpredict(mkin_model, |
631 | 43671888x |
odeparms = odeparms, odeini = odeini, |
632 | 43671888x |
solution_type = solution_type, |
633 | 43671888x |
outtimes = sort(unique(i_time)), |
634 | 43671888x |
na_stop = FALSE |
635 |
) |
|
636 | ||
637 | 43671888x |
out_index <- cbind(as.character(i_time), as.character(i_name)) |
638 | 43671888x |
out_values <- out_wide[out_index] |
639 |
} |
|
640 | 43671888x |
return(out_values) |
641 |
}) |
|
642 | 873912x |
res <- unlist(res_list) |
643 | 873912x |
return(res) |
644 |
} |
|
645 |
} |
|
646 | ||
647 | 2187x |
if (identical(error_model, "auto")) { |
648 | 2187x |
error_model = object[[1]]$err_mod |
649 |
} |
|
650 | 2187x |
error.model <- switch(error_model, |
651 | 2187x |
const = "constant", |
652 | 2187x |
tc = "combined", |
653 | 2187x |
obs = "constant") |
654 | ||
655 | 2187x |
if (error_model == "obs") { |
656 | ! |
warning("The error model 'obs' (variance by variable) can currently not be transferred to an saemix model") |
657 |
} |
|
658 | ||
659 | 2187x |
degparms_psi0 <- degparms_optim |
660 | 2187x |
degparms_psi0[names(degparms_start)] <- degparms_start |
661 | 2187x |
psi0_matrix <- matrix(degparms_psi0, nrow = 1, |
662 | 2187x |
dimnames = list("(Intercept)", names(degparms_psi0))) |
663 | ||
664 | 2187x |
if (covariance.model[1] == "auto") { |
665 | 2062x |
covariance_diagonal <- rep(1, length(degparms_optim)) |
666 | 2062x |
if (!is.null(no_random_effect)) { |
667 | 766x |
degparms_no_random <- which(names(degparms_psi0) %in% no_random_effect) |
668 | 766x |
covariance_diagonal[degparms_no_random] <- 0 |
669 |
} |
|
670 | 2062x |
covariance.model = diag(covariance_diagonal) |
671 |
} |
|
672 | ||
673 | 2187x |
if (omega.init[1] == "auto") { |
674 | 2187x |
if (transformations == "mkin") { |
675 | 1413x |
degparms_eta_ini <- as.numeric( # remove names |
676 | 1413x |
mean_degparms(object, |
677 | 1413x |
random = TRUE, test_log_parms = TRUE)$eta) |
678 | ||
679 | 1413x |
omega.init <- 2 * diag(degparms_eta_ini^2) |
680 |
} else { |
|
681 | 774x |
omega.init <- matrix(nrow = 0, ncol = 0) |
682 |
} |
|
683 |
} |
|
684 | ||
685 | 2187x |
if (is.null(covariate_models)) { |
686 | 2027x |
covariate.model <- matrix(nrow = 0, ncol = 0) # default in saemixModel() |
687 |
} else { |
|
688 | 160x |
degparms_dependent <- sapply(covariate_models, function(x) as.character(x[[2]])) |
689 | 160x |
covariates_in_models = unique(unlist(lapply( |
690 | 160x |
covariate_models, function(x) |
691 | 160x |
colnames(attr(terms(x), "factors")) |
692 |
))) |
|
693 | 160x |
covariates_not_available <- setdiff(covariates_in_models, names(covariates)) |
694 | 160x |
if (length(covariates_not_available) > 0) { |
695 | ! |
stop("Covariate(s) ", paste(covariates_not_available, collapse = ", "), |
696 | ! |
" used in the covariate models not available in the covariate data") |
697 |
} |
|
698 | 160x |
psi0_matrix <- rbind(psi0_matrix, |
699 | 160x |
matrix(0, nrow = length(covariates), ncol = ncol(psi0_matrix), |
700 | 160x |
dimnames = list(names(covariates), colnames(psi0_matrix)))) |
701 | 160x |
covariate.model <- matrix(0, nrow = length(covariates), |
702 | 160x |
ncol = ncol(psi0_matrix), |
703 | 160x |
dimnames = list( |
704 | 160x |
covariates = names(covariates), |
705 | 160x |
degparms = colnames(psi0_matrix))) |
706 | 160x |
if (transformations == "saemix") { |
707 | ! |
stop("Covariate models with saemix transformations currently not supported") |
708 |
} |
|
709 | 160x |
parms_trans <- as.data.frame(t(sapply(object, parms, transformed = TRUE))) |
710 | 160x |
for (covariate_model in covariate_models) { |
711 | 160x |
covariate_name <- as.character(covariate_model[[2]]) |
712 | 160x |
model_data <- cbind(parms_trans, covariates) |
713 | 160x |
ini_model <- lm(covariate_model, data = model_data) |
714 | 160x |
ini_coef <- coef(ini_model) |
715 | 160x |
psi0_matrix[names(ini_coef), covariate_name] <- ini_coef |
716 | 160x |
covariate.model[names(ini_coef)[-1], covariate_name] <- as.numeric(as.logical(ini_coef[-1])) |
717 |
} |
|
718 |
} |
|
719 | ||
720 | 2187x |
res <- saemix::saemixModel(model_function, |
721 | 2187x |
psi0 = psi0_matrix, |
722 | 2187x |
"Mixed model generated from mmkin object", |
723 | 2187x |
transform.par = transform.par, |
724 | 2187x |
error.model = error.model, |
725 | 2187x |
verbose = verbose, |
726 | 2187x |
covariance.model = covariance.model, |
727 | 2187x |
covariate.model = covariate.model, |
728 | 2187x |
omega.init = omega.init, |
729 | 2187x |
error.init = error.init, |
730 |
... |
|
731 |
) |
|
732 | 2187x |
attr(res, "mean_dp_start") <- degparms_optim |
733 | 2187x |
return(res) |
734 |
} |
|
735 | ||
736 |
#' @rdname saem |
|
737 |
#' @importFrom rlang !!! |
|
738 |
#' @return An [saemix::SaemixData] object. |
|
739 |
#' @export |
|
740 |
saemix_data <- function(object, covariates = NULL, verbose = FALSE, ...) { |
|
741 | ! |
if (nrow(object) > 1) stop("Only row objects allowed") |
742 | 2187x |
ds_names <- colnames(object) |
743 | ||
744 | 2187x |
ds_list <- lapply(object, function(x) x$data[c("time", "variable", "observed")]) |
745 | 2187x |
names(ds_list) <- ds_names |
746 | 2187x |
ds_saemix_all <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds") |
747 | 2187x |
ds_saemix <- data.frame(ds = ds_saemix_all$ds, |
748 | 2187x |
name = as.character(ds_saemix_all$variable), |
749 | 2187x |
time = ds_saemix_all$time, |
750 | 2187x |
value = ds_saemix_all$observed, |
751 | 2187x |
stringsAsFactors = FALSE) |
752 | 2187x |
if (!is.null(covariates)) { |
753 | 160x |
name.covariates <- names(covariates) |
754 | 160x |
covariates$ds <- rownames(covariates) |
755 | 160x |
ds_saemix <- merge(ds_saemix, covariates, sort = FALSE) |
756 |
} else { |
|
757 | 2027x |
name.covariates <- character(0) |
758 |
} |
|
759 | ||
760 | 2187x |
res <- saemix::saemixData(ds_saemix, |
761 | 2187x |
name.group = "ds", |
762 | 2187x |
name.predictors = c("time", "name"), |
763 | 2187x |
name.response = "value", |
764 | 2187x |
name.covariates = name.covariates, |
765 | 2187x |
verbose = verbose, |
766 |
...) |
|
767 | 2187x |
return(res) |
768 |
} |
|
769 | ||
770 |
#' logLik method for saem.mmkin objects |
|
771 |
#' |
|
772 |
#' @param object The fitted [saem.mmkin] object |
|
773 |
#' @param \dots Passed to [saemix::logLik.SaemixObject] |
|
774 |
#' @param method Passed to [saemix::logLik.SaemixObject] |
|
775 |
#' @export |
|
776 |
logLik.saem.mmkin <- function(object, ..., method = c("is", "lin", "gq")) { |
|
777 | 4404x |
method <- match.arg(method) |
778 | 4404x |
return(logLik(object$so, method = method)) |
779 |
} |
|
780 | ||
781 |
#' @export |
|
782 |
update.saem.mmkin <- function(object, ..., evaluate = TRUE) { |
|
783 | 507x |
call <- object$call |
784 |
# For some reason we get saem.mmkin in the call when using mhmkin |
|
785 |
# so we need to fix this so we do not have to export saem.mmkin in |
|
786 |
# addition to the S3 method |
|
787 | 507x |
call[[1]] <- saem |
788 | ||
789 |
# We also need to provide the mmkin object in the call, so it |
|
790 |
# will also be found when called by testthat or pkgdown |
|
791 | 507x |
call[[2]] <- object$mmkin |
792 | ||
793 | 507x |
update_arguments <- match.call(expand.dots = FALSE)$... |
794 | ||
795 | 507x |
if (length(update_arguments) > 0) { |
796 | 507x |
update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) |
797 |
} |
|
798 | ||
799 | 507x |
for (a in names(update_arguments)[update_arguments_in_call]) { |
800 | 35x |
call[[a]] <- update_arguments[[a]] |
801 |
} |
|
802 | ||
803 | 507x |
update_arguments_not_in_call <- !update_arguments_in_call |
804 | 507x |
if(any(update_arguments_not_in_call)) { |
805 | 472x |
call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) |
806 | 472x |
call <- as.call(call) |
807 |
} |
|
808 | 507x |
if(evaluate) eval(call, parent.frame()) |
809 | ! |
else call |
810 |
} |
|
811 | ||
812 |
#' @export |
|
813 |
#' @rdname parms |
|
814 |
#' @param ci Should a matrix with estimates and confidence interval boundaries |
|
815 |
#' be returned? If FALSE (default), a vector of estimates is returned if no |
|
816 |
#' covariates are given, otherwise a matrix of estimates is returned, with |
|
817 |
#' each column corresponding to a row of the data frame holding the covariates |
|
818 |
#' @param covariates A data frame holding covariate values for which to |
|
819 |
#' return parameter values. Only has an effect if 'ci' is FALSE. |
|
820 |
parms.saem.mmkin <- function(object, ci = FALSE, covariates = NULL, ...) { |
|
821 | 2904x |
cov.mod <- object$sm@covariance.model |
822 | 2904x |
n_cov_mod_parms <- sum(cov.mod[upper.tri(cov.mod, diag = TRUE)]) |
823 | 2904x |
n_parms <- length(object$sm@name.modpar) + |
824 | 2904x |
n_cov_mod_parms + |
825 | 2904x |
length(object$sm@name.sigma) |
826 | ||
827 | 2904x |
if (inherits(object$so, "try-error")) { |
828 | ! |
conf.int <- matrix(rep(NA, 3 * n_parms), ncol = 3) |
829 | ! |
colnames(conf.int) <- c("estimate", "lower", "upper") |
830 |
} else { |
|
831 | 2904x |
conf.int <- object$so@results@conf.int[c("estimate", "lower", "upper")] |
832 | 2904x |
rownames(conf.int) <- object$so@results@conf.int[["name"]] |
833 | 2904x |
conf.int.var <- grepl("^Var\\.", rownames(conf.int)) |
834 | 2904x |
conf.int <- conf.int[!conf.int.var, ] |
835 | 2904x |
conf.int.cov <- grepl("^Cov\\.", rownames(conf.int)) |
836 | 2904x |
conf.int <- conf.int[!conf.int.cov, ] |
837 |
} |
|
838 | 2904x |
estimate <- conf.int[, "estimate"] |
839 | ||
840 | 2904x |
names(estimate) <- rownames(conf.int) |
841 | ||
842 | 2904x |
if (ci) { |
843 | 1034x |
return(conf.int) |
844 |
} else { |
|
845 | 1870x |
if (is.null(covariates)) { |
846 | 1760x |
return(estimate) |
847 |
} else { |
|
848 | 110x |
est_for_cov <- matrix(NA, |
849 | 110x |
nrow = length(object$sm@name.modpar), ncol = nrow(covariates), |
850 | 110x |
dimnames = (list(object$sm@name.modpar, rownames(covariates)))) |
851 | 110x |
covmods <- object$covariate_models |
852 | 110x |
names(covmods) <- sapply(covmods, function(x) as.character(x[[2]])) |
853 | 110x |
for (deg_parm_name in rownames(est_for_cov)) { |
854 | 440x |
if (deg_parm_name %in% names(covmods)) { |
855 | 110x |
covariate <- covmods[[deg_parm_name]][[3]] |
856 | 110x |
beta_degparm_name <- paste0("beta_", covariate, |
857 | 110x |
"(", deg_parm_name, ")") |
858 | 110x |
est_for_cov[deg_parm_name, ] <- estimate[deg_parm_name] + |
859 | 110x |
covariates[[covariate]] * estimate[beta_degparm_name] |
860 |
} else { |
|
861 | 330x |
est_for_cov[deg_parm_name, ] <- estimate[deg_parm_name] |
862 |
} |
|
863 |
} |
|
864 | 110x |
return(est_for_cov) |
865 |
} |
|
866 |
} |
|
867 |
} |
1 |
#' Method to get status information for fit array objects |
|
2 |
#' |
|
3 |
#' @param object The object to investigate |
|
4 |
#' @param x The object to be printed |
|
5 |
#' @param \dots For potential future extensions |
|
6 |
#' @return An object with the same dimensions as the fit array |
|
7 |
#' suitable printing method. |
|
8 |
#' @export |
|
9 |
status <- function(object, ...) |
|
10 |
{ |
|
11 | 589x |
UseMethod("status", object) |
12 |
} |
|
13 | ||
14 |
#' @rdname status |
|
15 |
#' @export |
|
16 |
#' @examples |
|
17 |
#' \dontrun{ |
|
18 |
#' fits <- mmkin( |
|
19 |
#' c("SFO", "FOMC"), |
|
20 |
#' list("FOCUS A" = FOCUS_2006_A, |
|
21 |
#' "FOCUS B" = FOCUS_2006_C), |
|
22 |
#' quiet = TRUE) |
|
23 |
#' status(fits) |
|
24 |
#' } |
|
25 |
status.mmkin <- function(object, ...) { |
|
26 | 376x |
all_summary_warnings <- character() |
27 | 376x |
sww <- 0 # Counter for Shapiro-Wilks warnings |
28 | ||
29 | 376x |
result <- lapply(object, |
30 | 376x |
function(fit) { |
31 | ! |
if (inherits(fit, "try-error")) return("E") |
32 | 4391x |
sw <- fit$summary_warnings |
33 | 4391x |
swn <- names(sw) |
34 | 4391x |
if (length(sw) > 0) { |
35 | ! |
if (any(grepl("S", swn))) { |
36 | ! |
sww <<- sww + 1 |
37 | ! |
swn <- gsub("S", paste0("S", sww), swn) |
38 |
} |
|
39 | ! |
warnstring <- paste(swn, collapse = ", ") |
40 | ! |
names(sw) <- swn |
41 | ! |
all_summary_warnings <<- c(all_summary_warnings, sw) |
42 | ! |
return(warnstring) |
43 |
} else { |
|
44 | 4391x |
return("OK") |
45 |
} |
|
46 |
}) |
|
47 | 376x |
result <- unlist(result) |
48 | 376x |
dim(result) <- dim(object) |
49 | 376x |
dimnames(result) <- dimnames(object) |
50 | ||
51 | 376x |
u_swn <- unique(names(all_summary_warnings)) |
52 | 376x |
attr(result, "unique_warnings") <- all_summary_warnings[u_swn] |
53 | 376x |
class(result) <- "status.mmkin" |
54 | 376x |
return(result) |
55 |
} |
|
56 | ||
57 |
#' @rdname status |
|
58 |
#' @export |
|
59 |
print.status.mmkin <- function(x, ...) { |
|
60 | 376x |
u_w <- attr(x, "unique_warnings") |
61 | 376x |
attr(x, "unique_warnings") <- NULL |
62 | 376x |
class(x) <- NULL |
63 | 376x |
print(x, quote = FALSE) |
64 | 376x |
cat("\n") |
65 | 376x |
for (i in seq_along(u_w)) { |
66 | ! |
cat(names(u_w)[i], ": ", u_w[i], "\n", sep = "") |
67 |
} |
|
68 | 376x |
if (any(x == "OK")) cat("OK: No warnings\n") |
69 | ! |
if (any(x == "E")) cat("E: Error\n") |
70 |
} |
|
71 | ||
72 |
#' @rdname status |
|
73 |
#' @export |
|
74 |
status.mhmkin <- function(object, ...) { |
|
75 | 125x |
if (inherits(object[[1]], "saem.mmkin")) { |
76 | 125x |
test_func <- function(fit) { |
77 | 500x |
if (inherits(fit, "try-error")) { |
78 | ! |
return("E") |
79 |
} else { |
|
80 | 500x |
if (inherits(fit$so, "try-error")) { |
81 | ! |
return("E") |
82 |
} else { |
|
83 | 500x |
if (!is.null(fit$FIM_failed)) { |
84 | ! |
return_values <- c("fixed effects" = "Fth", |
85 | ! |
"random effects and error model parameters" = "FO") |
86 | ! |
return(paste(return_values[fit$FIM_failed], collapse = ", ")) |
87 |
} else { |
|
88 | 500x |
return("OK") |
89 |
} |
|
90 |
} |
|
91 |
} |
|
92 |
} |
|
93 |
} else { |
|
94 | ! |
stop("Only mhmkin objects containing saem.mmkin objects currently supported") |
95 |
} |
|
96 | 125x |
result <- lapply(object, test_func) |
97 | 125x |
result <- unlist(result) |
98 | 125x |
dim(result) <- dim(object) |
99 | 125x |
dimnames(result) <- dimnames(object) |
100 | ||
101 | 125x |
class(result) <- "status.mhmkin" |
102 | 125x |
return(result) |
103 |
} |
|
104 | ||
105 |
#' @rdname status |
|
106 |
#' @export |
|
107 |
print.status.mhmkin <- function(x, ...) { |
|
108 | 125x |
class(x) <- NULL |
109 | 125x |
print(x, quote = FALSE) |
110 | 125x |
cat("\n") |
111 | 125x |
if (any(x == "OK")) cat("OK: Fit terminated successfully\n") |
112 | ! |
if (any(x == "Fth")) cat("Fth: Could not invert FIM for fixed effects\n") |
113 | ! |
if (any(x == "FO")) cat("FO: Could not invert FIM for random effects and error model parameters\n") |
114 | ! |
if (any(x == "Fth, FO")) cat("Fth, FO: Could not invert FIM for fixed effects, nor for random effects and error model parameters\n") |
115 | ! |
if (any(x == "E")) cat("E: Error\n") |
116 |
} |
|
117 |
1 |
#' Function to calculate endpoints for further use from kinetic models fitted |
|
2 |
#' with mkinfit |
|
3 |
#' |
|
4 |
#' This function calculates DT50 and DT90 values as well as formation fractions |
|
5 |
#' from kinetic models fitted with mkinfit. If the SFORB model was specified |
|
6 |
#' for one of the parents or metabolites, the Eigenvalues are returned. These |
|
7 |
#' are equivalent to the rate constants of the DFOP model, but with the |
|
8 |
#' advantage that the SFORB model can also be used for metabolites. |
|
9 |
#' |
|
10 |
#' Additional DT50 values are calculated from the FOMC DT90 and k1 and k2 from |
|
11 |
#' HS and DFOP, as well as from Eigenvalues b1 and b2 of any SFORB models |
|
12 |
#' |
|
13 |
#' @param fit An object of class [mkinfit], [nlme.mmkin] or [saem.mmkin], or |
|
14 |
#' another object that has list components mkinmod containing an [mkinmod] |
|
15 |
#' degradation model, and two numeric vectors, bparms.optim and bparms.fixed, |
|
16 |
#' that contain parameter values for that model. |
|
17 |
#' @param covariates Numeric vector with covariate values for all variables in |
|
18 |
#' any covariate models in the object. If given, it overrides 'covariate_quantile'. |
|
19 |
#' @param covariate_quantile This argument only has an effect if the fitted |
|
20 |
#' object has covariate models. If so, the default is to show endpoints |
|
21 |
#' for the median of the covariate values (50th percentile). |
|
22 |
#' @importFrom stats optimize |
|
23 |
#' @return A list with a matrix of dissipation times named distimes, and, if |
|
24 |
#' applicable, a vector of formation fractions named ff and, if the SFORB model |
|
25 |
#' was in use, a vector of eigenvalues of these SFORB models, equivalent to |
|
26 |
#' DFOP rate constants |
|
27 |
#' @note The function is used internally by [summary.mkinfit], |
|
28 |
#' [summary.nlme.mmkin] and [summary.saem.mmkin]. |
|
29 |
#' @author Johannes Ranke |
|
30 |
#' @examples |
|
31 |
#' |
|
32 |
#' fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE) |
|
33 |
#' endpoints(fit) |
|
34 |
#' \dontrun{ |
|
35 |
#' fit_2 <- mkinfit("DFOP", FOCUS_2006_C, quiet = TRUE) |
|
36 |
#' endpoints(fit_2) |
|
37 |
#' fit_3 <- mkinfit("SFORB", FOCUS_2006_C, quiet = TRUE) |
|
38 |
#' endpoints(fit_3) |
|
39 |
#' } |
|
40 |
#' |
|
41 |
#' @export |
|
42 |
endpoints <- function(fit, covariates = NULL, covariate_quantile = 0.5) { |
|
43 | 56208x |
mkinmod <- fit$mkinmod |
44 | 56208x |
obs_vars <- names(mkinmod$spec) |
45 | ||
46 | 56208x |
if (!is.null(fit$covariate_models)) { |
47 | 110x |
if (is.null(covariates)) { |
48 | 110x |
covariates = as.data.frame( |
49 | 110x |
apply(fit$covariates, 2, quantile, |
50 | 110x |
covariate_quantile, simplify = FALSE)) |
51 |
} else { |
|
52 | ! |
covariate_m <- matrix(covariates, byrow = TRUE) |
53 | ! |
colnames(covariate_m) <- names(covariates) |
54 | ! |
rownames(covariate_m) <- "User" |
55 | ! |
covariates <- as.data.frame(covariate_m) |
56 |
} |
|
57 | 110x |
degparms_trans <- parms(fit, covariates = covariates)[, 1] |
58 | 110x |
if (inherits(fit, "saem.mmkin") & (fit$transformations == "saemix")) { |
59 | ! |
degparms <- degparms_trans |
60 |
} else { |
|
61 | 110x |
degparms <- backtransform_odeparms(degparms_trans, |
62 | 110x |
fit$mkinmod, |
63 | 110x |
transform_rates = fit$transform_rates, |
64 | 110x |
transform_fractions = fit$transform_fractions) |
65 |
} |
|
66 |
} else { |
|
67 | 56098x |
degparms <- c(fit$bparms.optim, fit$bparms.fixed) |
68 |
} |
|
69 | ||
70 |
# Set up object to return |
|
71 | 56208x |
ep <- list() |
72 | 56208x |
ep$covariates <- covariates |
73 | 56208x |
ep$ff <- vector() |
74 | 56208x |
ep$SFORB <- vector() |
75 | 56208x |
ep$distimes <- data.frame( |
76 | 56208x |
DT50 = rep(NA, length(obs_vars)), |
77 | 56208x |
DT90 = rep(NA, length(obs_vars)), |
78 | 56208x |
row.names = obs_vars) |
79 | ||
80 | 56208x |
for (obs_var in obs_vars) { |
81 | 73858x |
type = names(mkinmod$map[[obs_var]])[1] |
82 | ||
83 |
# Get formation fractions if directly fitted, and calculate remaining fraction to sink |
|
84 | 73858x |
f_names = grep(paste("^f", obs_var, sep = "_"), names(degparms), value=TRUE) |
85 | 73858x |
if (length(f_names) > 0) { |
86 | 15068x |
f_values = degparms[f_names] |
87 | 15068x |
f_to_sink = 1 - sum(f_values) |
88 | 15068x |
names(f_to_sink) = ifelse(type == "SFORB", |
89 | 15068x |
paste(obs_var, "free", "sink", sep = "_"), |
90 | 15068x |
paste(obs_var, "sink", sep = "_")) |
91 | 15068x |
for (f_name in f_names) { |
92 | 17338x |
ep$ff[[sub("f_", "", sub("_to_", "_", f_name))]] = f_values[[f_name]] |
93 |
} |
|
94 | 15068x |
ep$ff = append(ep$ff, f_to_sink) |
95 |
} |
|
96 | ||
97 |
# Get the rest |
|
98 | 73858x |
if (type == "SFO") { |
99 | 40900x |
k_names = grep(paste("^k", obs_var, sep="_"), names(degparms), value=TRUE) |
100 | 40900x |
k_tot = sum(degparms[k_names]) |
101 | 40900x |
DT50 = log(2)/k_tot |
102 | 40900x |
DT90 = log(10)/k_tot |
103 | 40900x |
if (mkinmod$use_of_ff == "min" && length(obs_vars) > 1) { |
104 | 622x |
for (k_name in k_names) |
105 |
{ |
|
106 | 932x |
ep$ff[[sub("k_", "", k_name)]] = degparms[[k_name]] / k_tot |
107 |
} |
|
108 |
} |
|
109 |
} |
|
110 | 73858x |
if (type == "FOMC") { |
111 | 1790x |
alpha = degparms["alpha"] |
112 | 1790x |
beta = degparms["beta"] |
113 | 1790x |
DT50 = beta * (2^(1/alpha) - 1) |
114 | 1790x |
DT90 = beta * (10^(1/alpha) - 1) |
115 | 1790x |
DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 |
116 | 1790x |
ep$distimes[obs_var, c("DT50back")] = DT50_back |
117 |
} |
|
118 | 73858x |
if (type == "IORE") { |
119 | 352x |
k_names = grep(paste("^k__iore", obs_var, sep="_"), names(degparms), value=TRUE) |
120 | 352x |
k_tot = sum(degparms[k_names]) |
121 |
# From the NAFTA kinetics guidance, p. 5 |
|
122 | 352x |
n = degparms[paste("N", obs_var, sep = "_")] |
123 | 352x |
k = k_tot |
124 |
# Use the initial concentration of the parent compound |
|
125 | 352x |
source_name = mkinmod$map[[1]][[1]] |
126 | 352x |
c0 = degparms[paste(source_name, "0", sep = "_")] |
127 | 352x |
alpha = 1 / (n - 1) |
128 | 352x |
beta = (c0^(1 - n))/(k * (n - 1)) |
129 | 352x |
DT50 = beta * (2^(1/alpha) - 1) |
130 | 352x |
DT90 = beta * (10^(1/alpha) - 1) |
131 | 352x |
DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 |
132 | 352x |
ep$distimes[obs_var, c("DT50back")] = DT50_back |
133 | 352x |
if (mkinmod$use_of_ff == "min") { |
134 | ! |
for (k_name in k_names) |
135 |
{ |
|
136 | ! |
ep$ff[[sub("k_", "", k_name)]] = degparms[[k_name]] / k_tot |
137 |
} |
|
138 |
} |
|
139 |
} |
|
140 | 73858x |
if (type == "DFOP") { |
141 | 27729x |
k1 = degparms["k1"] |
142 | 27729x |
k2 = degparms["k2"] |
143 | 27729x |
g = degparms["g"] |
144 | 27729x |
f <- function(log_t, x) { |
145 | 684705x |
t <- exp(log_t) |
146 | 684705x |
fraction <- g * exp( - k1 * t) + (1 - g) * exp( - k2 * t) |
147 | 684705x |
(fraction - (1 - x/100))^2 |
148 |
} |
|
149 | 27729x |
DT50_k1 = log(2)/k1 |
150 | 27729x |
DT50_k2 = log(2)/k2 |
151 | 27729x |
DT90_k1 = log(10)/k1 |
152 | 27729x |
DT90_k2 = log(10)/k2 |
153 | ||
154 | 27729x |
DT50 <- try(exp(optimize(f, c(log(DT50_k1), log(DT50_k2)), x=50)$minimum), |
155 | 27729x |
silent = TRUE) |
156 | 27729x |
DT90 <- try(exp(optimize(f, c(log(DT90_k1), log(DT90_k2)), x=90)$minimum), |
157 | 27729x |
silent = TRUE) |
158 | ! |
if (inherits(DT50, "try-error")) DT50 = NA |
159 | ! |
if (inherits(DT90, "try-error")) DT90 = NA |
160 | 27729x |
DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 |
161 | ||
162 | 27729x |
ep$distimes[obs_var, c("DT50back")] = DT50_back |
163 | 27729x |
ep$distimes[obs_var, c("DT50_k1")] = DT50_k1 |
164 | 27729x |
ep$distimes[obs_var, c("DT50_k2")] = DT50_k2 |
165 |
} |
|
166 | 73858x |
if (type == "HS") { |
167 | 318x |
k1 = degparms["k1"] |
168 | 318x |
k2 = degparms["k2"] |
169 | 318x |
tb = degparms["tb"] |
170 | 318x |
DTx <- function(x) { |
171 | 636x |
DTx.a <- (log(100/(100 - x)))/k1 |
172 | 636x |
DTx.b <- tb + (log(100/(100 - x)) - k1 * tb)/k2 |
173 | 339x |
if (DTx.a < tb) DTx <- DTx.a |
174 | 297x |
else DTx <- DTx.b |
175 | 636x |
return(DTx) |
176 |
} |
|
177 | 318x |
DT50 <- DTx(50) |
178 | 318x |
DT90 <- DTx(90) |
179 | 318x |
DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 |
180 | 318x |
DT50_k1 = log(2)/k1 |
181 | 318x |
DT50_k2 = log(2)/k2 |
182 | 318x |
ep$distimes[obs_var, c("DT50back")] = DT50_back |
183 | 318x |
ep$distimes[obs_var, c("DT50_k1")] = DT50_k1 |
184 | 318x |
ep$distimes[obs_var, c("DT50_k2")] = DT50_k2 |
185 |
} |
|
186 | 73858x |
if (type == "SFORB") { |
187 |
# FOCUS kinetics (2006), p. 60 f |
|
188 | 2616x |
k_out_names = grep(paste("^k", obs_var, "free", sep="_"), names(degparms), value=TRUE) |
189 | 2616x |
k_out_names = setdiff(k_out_names, paste("k", obs_var, "free", "bound", sep="_")) |
190 | 2616x |
k_1output = sum(degparms[k_out_names]) |
191 | 2616x |
k_12 = degparms[paste("k", obs_var, "free", "bound", sep="_")] |
192 | 2616x |
k_21 = degparms[paste("k", obs_var, "bound", "free", sep="_")] |
193 | ||
194 | 2616x |
sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21) |
195 | 2616x |
b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp |
196 | 2616x |
b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp |
197 | 2616x |
g = (k_12 + k_21 - b1)/(b2 - b1) |
198 | ||
199 | 2616x |
DT50_b1 = log(2)/b1 |
200 | 2616x |
DT50_b2 = log(2)/b2 |
201 | 2616x |
DT90_b1 = log(10)/b1 |
202 | 2616x |
DT90_b2 = log(10)/b2 |
203 | ||
204 | 2616x |
SFORB_fraction = function(t) { |
205 | 60096x |
g * exp(-b1 * t) + (1 - g) * exp(-b2 * t) |
206 |
} |
|
207 | ||
208 | 2616x |
f_50 <- function(log_t) (SFORB_fraction(exp(log_t)) - 0.5)^2 |
209 | 2616x |
log_DT50 <- try(optimize(f_50, c(log(DT50_b1), log(DT50_b2)))$minimum, |
210 | 2616x |
silent = TRUE) |
211 | 2616x |
f_90 <- function(log_t) (SFORB_fraction(exp(log_t)) - 0.1)^2 |
212 | 2616x |
log_DT90 <- try(optimize(f_90, c(log(DT90_b1), log(DT90_b2)))$minimum, |
213 | 2616x |
silent = TRUE) |
214 | ||
215 | 2616x |
DT50 = if (inherits(log_DT50, "try-error")) NA |
216 | 2616x |
else exp(log_DT50) |
217 | 2616x |
DT90 = if (inherits(log_DT90, "try-error")) NA |
218 | 2616x |
else exp(log_DT90) |
219 | ||
220 | 2616x |
DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 |
221 | ||
222 | 2616x |
for (k_out_name in k_out_names) |
223 |
{ |
|
224 | 2618x |
ep$ff[[sub("k_", "", k_out_name)]] = degparms[[k_out_name]] / k_1output |
225 |
} |
|
226 | ||
227 |
# Return the eigenvalues for comparison with DFOP rate constants |
|
228 | 2616x |
ep$SFORB[[paste(obs_var, "b1", sep="_")]] = b1 |
229 | 2616x |
ep$SFORB[[paste(obs_var, "b2", sep="_")]] = b2 |
230 |
# Return g for comparison with DFOP |
|
231 | 2616x |
ep$SFORB[[paste(obs_var, "g", sep="_")]] = g |
232 | ||
233 | 2616x |
ep$distimes[obs_var, c("DT50back")] = DT50_back |
234 | 2616x |
ep$distimes[obs_var, c(paste("DT50", obs_var, "b1", sep = "_"))] = DT50_b1 |
235 | 2616x |
ep$distimes[obs_var, c(paste("DT50", obs_var, "b2", sep = "_"))] = DT50_b2 |
236 |
} |
|
237 | 73858x |
if (type == "logistic") { |
238 |
# FOCUS kinetics (2014) p. 67 |
|
239 | 153x |
kmax = degparms["kmax"] |
240 | 153x |
k0 = degparms["k0"] |
241 | 153x |
r = degparms["r"] |
242 | 153x |
DT50 = (1/r) * log(1 - ((kmax/k0) * (1 - 2^(r/kmax)))) |
243 | 153x |
DT90 = (1/r) * log(1 - ((kmax/k0) * (1 - 10^(r/kmax)))) |
244 | ||
245 | 153x |
DT50_k0 = log(2)/k0 |
246 | 153x |
DT50_kmax = log(2)/kmax |
247 | 153x |
ep$distimes[obs_var, c("DT50_k0")] = DT50_k0 |
248 | 153x |
ep$distimes[obs_var, c("DT50_kmax")] = DT50_kmax |
249 |
} |
|
250 | 73858x |
ep$distimes[obs_var, c("DT50", "DT90")] = c(DT50, DT90) |
251 |
} |
|
252 | 38846x |
if (length(ep$ff) == 0) ep$ff <- NULL |
253 | 53592x |
if (length(ep$SFORB) == 0) ep$SFORB <- NULL |
254 | 56208x |
return(ep) |
255 |
} |
1 |
#' Function to set up a kinetic model with one or more state variables |
|
2 |
#' |
|
3 |
#' This function is usually called using a call to [mkinsub()] for each observed |
|
4 |
#' variable, specifying the corresponding submodel as well as outgoing pathways |
|
5 |
#' (see examples). |
|
6 |
#' |
|
7 |
#' For the definition of model types and their parameters, the equations given |
|
8 |
#' in the FOCUS and NAFTA guidance documents are used. |
|
9 |
#' |
|
10 |
#' For kinetic models with more than one observed variable, a symbolic solution |
|
11 |
#' of the system of differential equations is included in the resulting |
|
12 |
#' mkinmod object in some cases, speeding up the solution. |
|
13 |
#' |
|
14 |
#' If a C compiler is found by [pkgbuild::has_compiler()] and there |
|
15 |
#' is more than one observed variable in the specification, C code is generated |
|
16 |
#' for evaluating the differential equations, compiled using |
|
17 |
#' [inline::cfunction()] and added to the resulting mkinmod object. |
|
18 |
#' |
|
19 |
#' @param ... For each observed variable, a list as obtained by [mkinsub()] |
|
20 |
#' has to be specified as an argument (see examples). Currently, single |
|
21 |
#' first order kinetics "SFO", indeterminate order rate equation kinetics |
|
22 |
#' "IORE", or single first order with reversible binding "SFORB" are |
|
23 |
#' implemented for all variables, while "FOMC", "DFOP", "HS" and "logistic" |
|
24 |
#' can additionally be chosen for the first variable which is assumed to be |
|
25 |
#' the source compartment. |
|
26 |
#' Additionally, [mkinsub()] has an argument \code{to}, specifying names of |
|
27 |
#' variables to which a transfer is to be assumed in the model. |
|
28 |
#' If the argument \code{use_of_ff} is set to "min" |
|
29 |
#' and the model for the compartment is "SFO" or "SFORB", an |
|
30 |
#' additional [mkinsub()] argument can be \code{sink = FALSE}, effectively |
|
31 |
#' fixing the flux to sink to zero. |
|
32 |
#' In print.mkinmod, this argument is currently not used. |
|
33 |
#' @param use_of_ff Specification of the use of formation fractions in the |
|
34 |
#' model equations and, if applicable, the coefficient matrix. If "max", |
|
35 |
#' formation fractions are always used (default). If "min", a minimum use of |
|
36 |
#' formation fractions is made, i.e. each first-order pathway to a metabolite |
|
37 |
#' has its own rate constant. |
|
38 |
#' @param speclist The specification of the observed variables and their |
|
39 |
#' submodel types and pathways can be given as a single list using this |
|
40 |
#' argument. Default is NULL. |
|
41 |
#' @param quiet Should messages be suppressed? |
|
42 |
#' @param verbose If \code{TRUE}, passed to [inline::cfunction()] if |
|
43 |
#' applicable to give detailed information about the C function being built. |
|
44 |
#' @param name A name for the model. Should be a valid R object name. |
|
45 |
#' @param dll_dir Directory where an DLL object, if generated internally by |
|
46 |
#' [inline::cfunction()], should be saved. The DLL will only be stored in a |
|
47 |
#' permanent location for use in future sessions, if 'dll_dir' and 'name' |
|
48 |
#' are specified. This is helpful if fit objects are cached e.g. by knitr, |
|
49 |
#' as the cache remains functional across sessions if the DLL is stored in |
|
50 |
#' a user defined location. |
|
51 |
#' @param unload If a DLL from the target location in 'dll_dir' is already |
|
52 |
#' loaded, should that be unloaded first? |
|
53 |
#' @param overwrite If a file exists at the target DLL location in 'dll_dir', |
|
54 |
#' should this be overwritten? |
|
55 |
#' @importFrom methods signature |
|
56 |
#' @return A list of class \code{mkinmod} for use with [mkinfit()], |
|
57 |
#' containing, among others, |
|
58 |
#' \item{diffs}{ |
|
59 |
#' A vector of string representations of differential equations, one for |
|
60 |
#' each modelling variable. |
|
61 |
#' } |
|
62 |
#' \item{map}{ |
|
63 |
#' A list containing named character vectors for each observed variable, |
|
64 |
#' specifying the modelling variables by which it is represented. |
|
65 |
#' } |
|
66 |
#' \item{use_of_ff}{ |
|
67 |
#' The content of \code{use_of_ff} is passed on in this list component. |
|
68 |
#' } |
|
69 |
#' \item{deg_func}{ |
|
70 |
#' If generated, a function containing the solution of the degradation |
|
71 |
#' model. |
|
72 |
#' } |
|
73 |
#' \item{coefmat}{ |
|
74 |
#' The coefficient matrix, if the system of differential equations can be |
|
75 |
#' represented by one. |
|
76 |
#' } |
|
77 |
#' \item{cf}{ |
|
78 |
#' If generated, a compiled function calculating the derivatives as |
|
79 |
#' returned by cfunction. |
|
80 |
#' } |
|
81 |
#' @note The IORE submodel is not well tested for metabolites. When using this |
|
82 |
#' model for metabolites, you may want to read the note in the help |
|
83 |
#' page to [mkinfit]. |
|
84 |
#' @author Johannes Ranke |
|
85 |
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
86 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
87 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
88 |
#' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
89 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
90 |
#' |
|
91 |
#' NAFTA Technical Working Group on Pesticides (not dated) Guidance for |
|
92 |
#' Evaluating and Calculating Degradation Kinetics in Environmental Media |
|
93 |
#' @examples |
|
94 |
#' |
|
95 |
#' # Specify the SFO model (this is not needed any more, as we can now mkinfit("SFO", ...) |
|
96 |
#' SFO <- mkinmod(parent = mkinsub("SFO")) |
|
97 |
#' |
|
98 |
#' # One parent compound, one metabolite, both single first order |
|
99 |
#' SFO_SFO <- mkinmod( |
|
100 |
#' parent = mkinsub("SFO", "m1"), |
|
101 |
#' m1 = mkinsub("SFO")) |
|
102 |
#' print(SFO_SFO) |
|
103 |
#' |
|
104 |
#' \dontrun{ |
|
105 |
#' fit_sfo_sfo <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE, solution_type = "deSolve") |
|
106 |
#' |
|
107 |
#' # Now supplying compound names used for plotting, and write to user defined location |
|
108 |
#' # We need to choose a path outside the session tempdir because this gets removed |
|
109 |
#' DLL_dir <- "~/.local/share/mkin" |
|
110 |
#' if (!dir.exists(DLL_dir)) dir.create(DLL_dir) |
|
111 |
#' SFO_SFO.2 <- mkinmod( |
|
112 |
#' parent = mkinsub("SFO", "m1", full_name = "Test compound"), |
|
113 |
#' m1 = mkinsub("SFO", full_name = "Metabolite M1"), |
|
114 |
#' name = "SFO_SFO", dll_dir = DLL_dir, unload = TRUE, overwrite = TRUE) |
|
115 |
#' # Now we can save the model and restore it in a new session |
|
116 |
#' saveRDS(SFO_SFO.2, file = "~/SFO_SFO.rds") |
|
117 |
#' # Terminate the R session here if you would like to check, and then do |
|
118 |
#' library(mkin) |
|
119 |
#' SFO_SFO.3 <- readRDS("~/SFO_SFO.rds") |
|
120 |
#' fit_sfo_sfo <- mkinfit(SFO_SFO.3, FOCUS_2006_D, quiet = TRUE, solution_type = "deSolve") |
|
121 |
#' |
|
122 |
#' # Show details of creating the C function |
|
123 |
#' SFO_SFO <- mkinmod( |
|
124 |
#' parent = mkinsub("SFO", "m1"), |
|
125 |
#' m1 = mkinsub("SFO"), verbose = TRUE) |
|
126 |
#' |
|
127 |
#' # The symbolic solution which is available in this case is not |
|
128 |
#' # made for human reading but for speed of computation |
|
129 |
#' SFO_SFO$deg_func |
|
130 |
#' |
|
131 |
#' # If we have several parallel metabolites |
|
132 |
#' # (compare tests/testthat/test_synthetic_data_for_UBA_2014.R) |
|
133 |
#' m_synth_DFOP_par <- mkinmod( |
|
134 |
#' parent = mkinsub("DFOP", c("M1", "M2")), |
|
135 |
#' M1 = mkinsub("SFO"), |
|
136 |
#' M2 = mkinsub("SFO"), |
|
137 |
#' quiet = TRUE) |
|
138 |
#' |
|
139 |
#' fit_DFOP_par_c <- mkinfit(m_synth_DFOP_par, |
|
140 |
#' synthetic_data_for_UBA_2014[[12]]$data, |
|
141 |
#' quiet = TRUE) |
|
142 |
#' } |
|
143 |
#' |
|
144 |
#' @export mkinmod |
|
145 |
mkinmod <- function(..., use_of_ff = "max", name = NULL, |
|
146 |
speclist = NULL, quiet = FALSE, verbose = FALSE, dll_dir = NULL, |
|
147 |
unload = FALSE, overwrite = FALSE) |
|
148 |
{ |
|
149 | 4940x |
if (is.null(speclist)) spec <- list(...) |
150 | 3905x |
else spec <- speclist |
151 | 8845x |
obs_vars <- names(spec) |
152 | ||
153 | 8845x |
save_msg <- "You need to specify both 'name' and 'dll_dir' to save a model DLL" |
154 | 8845x |
if (!is.null(dll_dir)) { |
155 | ! |
if (!dir.exists(dll_dir)) stop(dll_dir, " does not exist") |
156 | ! |
if (is.null(name)) stop(save_msg) |
157 |
} |
|
158 | ||
159 |
# Check if any of the names of the observed variables contains any other |
|
160 | 8845x |
for (obs_var in obs_vars) { |
161 | 104x |
if (length(grep(obs_var, obs_vars)) > 1) stop("Sorry, variable names can not contain each other") |
162 | 104x |
if (grepl("_to_", obs_var)) stop("Sorry, names of observed variables can not contain _to_") |
163 | 104x |
if (obs_var == "sink") stop("Naming a compound 'sink' is not supported") |
164 |
} |
|
165 | ||
166 | 8533x |
if (!use_of_ff %in% c("min", "max")) |
167 | 104x |
stop("The use of formation fractions 'use_of_ff' can only be 'min' or 'max'") |
168 | ||
169 | 8429x |
parms <- vector() |
170 |
# }}} |
|
171 | ||
172 |
# Do not return a coefficient matrix mat when FOMC, IORE, DFOP, HS or logistic is used for the parent {{{ |
|
173 | 8429x |
if(spec[[1]]$type %in% c("FOMC", "IORE", "DFOP", "HS", "logistic")) { |
174 | 2280x |
mat = FALSE |
175 | 6149x |
} else mat = TRUE |
176 |
#}}} |
|
177 | ||
178 |
# Establish a list of differential equations as well as a map from observed {{{ |
|
179 |
# compartments to differential equations |
|
180 | 8429x |
diffs <- vector() |
181 | 8429x |
map <- list() |
182 | 8429x |
for (varname in obs_vars) |
183 |
{ |
|
184 |
# Check the type component of the compartment specification {{{ |
|
185 | ! |
if(is.null(spec[[varname]]$type)) stop( |
186 | ! |
"Every part of the model specification must be a list containing a type component") |
187 | 104x |
if(!spec[[varname]]$type %in% c("SFO", "FOMC", "IORE", "DFOP", "HS", "SFORB", "logistic")) stop( |
188 | 104x |
"Available types are SFO, FOMC, IORE, DFOP, HS, SFORB and logistic only") |
189 | 13150x |
if(spec[[varname]]$type %in% c("FOMC", "DFOP", "HS", "logistic") & match(varname, obs_vars) != 1) { |
190 | 104x |
stop(paste("Types FOMC, DFOP, HS and logistic are only implemented for the first compartment,", |
191 | 104x |
"which is assumed to be the source compartment")) |
192 |
} |
|
193 |
#}}} |
|
194 |
# New (sub)compartments (boxes) needed for the model type {{{ |
|
195 | 13046x |
new_boxes <- switch(spec[[varname]]$type, |
196 | 13046x |
SFO = varname, |
197 | 13046x |
FOMC = varname, |
198 | 13046x |
IORE = varname, |
199 | 13046x |
DFOP = varname, |
200 | 13046x |
HS = varname, |
201 | 13046x |
logistic = varname, |
202 | 13046x |
SFORB = paste(varname, c("free", "bound"), sep = "_") |
203 |
) |
|
204 | 13046x |
map[[varname]] <- new_boxes |
205 | 13046x |
names(map[[varname]]) <- rep(spec[[varname]]$type, length(new_boxes)) #}}} |
206 |
# Start a new differential equation for each new box {{{ |
|
207 | 13046x |
new_diffs <- paste("d_", new_boxes, " =", sep = "") |
208 | 13046x |
names(new_diffs) <- new_boxes |
209 | 13046x |
diffs <- c(diffs, new_diffs) #}}} |
210 |
} #}}} |
|
211 | ||
212 |
# Create content of differential equations and build parameter list {{{ |
|
213 | 8221x |
for (varname in obs_vars) |
214 |
{ |
|
215 |
# Get the name of the box(es) we are working on for the decline term(s) |
|
216 | 12838x |
box_1 = map[[varname]][[1]] # This is the only box unless type is SFORB |
217 |
# Turn on sink if this is not explicitly excluded by the user by |
|
218 |
# specifying sink=FALSE |
|
219 | 4x |
if(is.null(spec[[varname]]$sink)) spec[[varname]]$sink <- TRUE |
220 | 12838x |
if(spec[[varname]]$type %in% c("SFO", "IORE", "SFORB")) { # {{{ Add decline term |
221 | 10838x |
if (use_of_ff == "min") { # Minimum use of formation fractions |
222 | 1304x |
if(spec[[varname]]$type == "IORE" && length(spec[[varname]]$to) > 0) { |
223 | 104x |
stop("Transformation reactions from compounds modelled with IORE\n", |
224 | 104x |
"are only supported with formation fractions (use_of_ff = 'max')") |
225 |
} |
|
226 | 1200x |
if(spec[[varname]]$sink) { |
227 |
# If sink is requested, add first-order/IORE sink term |
|
228 | 952x |
k_compound_sink <- paste("k", box_1, "sink", sep = "_") |
229 | 952x |
if(spec[[varname]]$type == "IORE") { |
230 | ! |
k_compound_sink <- paste("k__iore", box_1, "sink", sep = "_") |
231 |
} |
|
232 | 952x |
parms <- c(parms, k_compound_sink) |
233 | 952x |
decline_term <- paste(k_compound_sink, "*", box_1) |
234 | 952x |
if(spec[[varname]]$type == "IORE") { |
235 | ! |
N <- paste("N", box_1, sep = "_") |
236 | ! |
parms <- c(parms, N) |
237 | ! |
decline_term <- paste0(decline_term, "^", N) |
238 |
} |
|
239 |
} else { # otherwise no decline term needed here |
|
240 | 248x |
decline_term = "0" |
241 |
} |
|
242 |
} else { # Maximum use of formation fractions |
|
243 | 9534x |
k_compound <- paste("k", box_1, sep = "_") |
244 | 9534x |
if(spec[[varname]]$type == "IORE") { |
245 | 176x |
k_compound <- paste("k__iore", box_1, sep = "_") |
246 |
} |
|
247 | 9534x |
parms <- c(parms, k_compound) |
248 | 9534x |
decline_term <- paste(k_compound, "*", box_1) |
249 | 9534x |
if(spec[[varname]]$type == "IORE") { |
250 | 176x |
N <- paste("N", box_1, sep = "_") |
251 | 176x |
parms <- c(parms, N) |
252 | 176x |
decline_term <- paste0(decline_term, "^", N) |
253 |
} |
|
254 |
} |
|
255 |
} #}}} |
|
256 | 12734x |
if(spec[[varname]]$type == "FOMC") { # {{{ Add FOMC decline term |
257 |
# From p. 53 of the FOCUS kinetics report, without the power function so it works in C |
|
258 | 381x |
decline_term <- paste("(alpha/beta) * 1/((time/beta) + 1) *", box_1) |
259 | 381x |
parms <- c(parms, "alpha", "beta") |
260 |
} #}}} |
|
261 | 12734x |
if(spec[[varname]]$type == "DFOP") { # {{{ Add DFOP decline term |
262 |
# From p. 57 of the FOCUS kinetics report |
|
263 | 1283x |
decline_term <- paste("((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * time)) / (g * exp(-k1 * time) + (1 - g) * exp(-k2 * time))) *", box_1) |
264 | 1283x |
parms <- c(parms, "k1", "k2", "g") |
265 |
} #}}} |
|
266 | 12734x |
HS_decline <- "ifelse(time <= tb, k1, k2)" # Used below for automatic translation to C |
267 | 12734x |
if(spec[[varname]]$type == "HS") { # {{{ Add HS decline term |
268 |
# From p. 55 of the FOCUS kinetics report |
|
269 | 30x |
decline_term <- paste(HS_decline, "*", box_1) |
270 | 30x |
parms <- c(parms, "k1", "k2", "tb") |
271 |
} #}}} |
|
272 | 12734x |
if(spec[[varname]]$type == "logistic") { # {{{ Add logistic decline term |
273 |
# From p. 67 of the FOCUS kinetics report (2014) |
|
274 | 306x |
decline_term <- paste("(k0 * kmax)/(k0 + (kmax - k0) * exp(-r * time)) *", box_1) |
275 | 306x |
parms <- c(parms, "kmax", "k0", "r") |
276 |
} #}}} |
|
277 |
# Add origin decline term to box 1 (usually the only box, unless type is SFORB)#{{{ |
|
278 | 12734x |
diffs[[box_1]] <- paste(diffs[[box_1]], "-", decline_term)#}}} |
279 | 12734x |
if(spec[[varname]]$type == "SFORB") { # {{{ Add SFORB reversible binding terms |
280 | 25x |
box_2 = map[[varname]][[2]] |
281 | 25x |
k_free_bound <- paste("k", varname, "free", "bound", sep = "_") |
282 | 25x |
k_bound_free <- paste("k", varname, "bound", "free", sep = "_") |
283 | 25x |
parms <- c(parms, k_free_bound, k_bound_free) |
284 | 25x |
reversible_binding_term_1 <- paste("-", k_free_bound, "*", box_1, "+", |
285 | 25x |
k_bound_free, "*", box_2) |
286 | 25x |
reversible_binding_term_2 <- paste("+", k_free_bound, "*", box_1, "-", |
287 | 25x |
k_bound_free, "*", box_2) |
288 | 25x |
diffs[[box_1]] <- paste(diffs[[box_1]], reversible_binding_term_1) |
289 | 25x |
diffs[[box_2]] <- paste(diffs[[box_2]], reversible_binding_term_2) |
290 |
} #}}} |
|
291 | ||
292 |
# Transfer between compartments#{{{ |
|
293 | 12734x |
to <- spec[[varname]]$to |
294 | 12734x |
if(!is.null(to)) { |
295 |
# Name of box from which transfer takes place |
|
296 | 4174x |
origin_box <- box_1 |
297 | ||
298 |
# Number of targets |
|
299 | 4174x |
n_targets = length(to) |
300 | ||
301 |
# Add transfer terms to listed compartments |
|
302 | 4174x |
for (target in to) { |
303 | ! |
if (!target %in% obs_vars) stop("You did not specify a submodel for target variable ", target) |
304 | 4813x |
target_box <- switch(spec[[target]]$type, |
305 | 4813x |
SFO = target, |
306 | 4813x |
IORE = target, |
307 | 4813x |
SFORB = paste(target, "free", sep = "_")) |
308 | 4813x |
if (use_of_ff == "min" && spec[[varname]]$type %in% c("SFO", "SFORB")) |
309 |
{ |
|
310 | 601x |
k_from_to <- paste("k", origin_box, target_box, sep = "_") |
311 | 601x |
parms <- c(parms, k_from_to) |
312 | 601x |
diffs[[origin_box]] <- paste(diffs[[origin_box]], "-", |
313 | 601x |
k_from_to, "*", origin_box) |
314 | 601x |
diffs[[target_box]] <- paste(diffs[[target_box]], "+", |
315 | 601x |
k_from_to, "*", origin_box) |
316 |
} else { |
|
317 |
# Do not introduce a formation fraction if this is the only target |
|
318 | 4212x |
if (spec[[varname]]$sink == FALSE && n_targets == 1) { |
319 | 689x |
diffs[[target_box]] <- paste(diffs[[target_box]], "+", |
320 | 689x |
decline_term) |
321 |
} else { |
|
322 | 3523x |
fraction_to_target = paste("f", origin_box, "to", target, sep = "_") |
323 | 3523x |
parms <- c(parms, fraction_to_target) |
324 | 3523x |
diffs[[target_box]] <- paste(diffs[[target_box]], "+", |
325 | 3523x |
fraction_to_target, "*", decline_term) |
326 |
} |
|
327 |
} |
|
328 |
} |
|
329 |
} #}}} |
|
330 |
} #}}} |
|
331 | ||
332 | 8117x |
model <- list(diffs = diffs, parms = parms, map = map, spec = spec, use_of_ff = use_of_ff, name = name) |
333 | ||
334 |
# Create coefficient matrix if possible #{{{ |
|
335 | 8117x |
if (mat) { |
336 | 5941x |
boxes <- names(diffs) |
337 | 5941x |
n <- length(boxes) |
338 | 5941x |
m <- matrix(nrow=n, ncol=n, dimnames=list(boxes, boxes)) |
339 | ||
340 | 5941x |
if (use_of_ff == "min") { # {{{ Minimum use of formation fractions |
341 | 600x |
for (from in boxes) { |
342 | 1201x |
for (to in boxes) { |
343 | 2405x |
if (from == to) { # diagonal elements |
344 | 1201x |
k.candidate = paste("k", from, c(boxes, "sink"), sep = "_") |
345 | 1201x |
k.candidate = sub("free.*bound", "free_bound", k.candidate) |
346 | 1201x |
k.candidate = sub("bound.*free", "bound_free", k.candidate) |
347 | 1201x |
k.effective = intersect(model$parms, k.candidate) |
348 | 1201x |
m[from,to] = ifelse(length(k.effective) > 0, |
349 | 1201x |
paste("-", k.effective, collapse = " "), "0") |
350 | ||
351 |
} else { # off-diagonal elements |
|
352 | 1204x |
k.candidate = paste("k", from, to, sep = "_") |
353 | 1204x |
if (sub("_free$", "", from) == sub("_bound$", "", to)) { |
354 | 1x |
k.candidate = paste("k", sub("_free$", "_free_bound", from), sep = "_") |
355 |
} |
|
356 | 1204x |
if (sub("_bound$", "", from) == sub("_free$", "", to)) { |
357 | 1x |
k.candidate = paste("k", sub("_bound$", "_bound_free", from), sep = "_") |
358 |
} |
|
359 | 1204x |
k.effective = intersect(model$parms, k.candidate) |
360 | 1204x |
m[to, from] = ifelse(length(k.effective) > 0, |
361 | 1204x |
k.effective, "0") |
362 |
} |
|
363 |
} |
|
364 |
} # }}} |
|
365 |
} else { # {{{ Use formation fractions where possible |
|
366 | 5341x |
for (from in boxes) { |
367 | 8074x |
for (to in boxes) { |
368 | 15220x |
if (from == to) { # diagonal elements |
369 | 8074x |
k.candidate = paste("k", from, sep = "_") |
370 | 8074x |
m[from,to] = ifelse(k.candidate %in% model$parms, |
371 | 8074x |
paste("-", k.candidate), "0") |
372 | 8074x |
if(grepl("_free", from)) { # add transfer to bound compartment for SFORB |
373 | 24x |
m[from,to] = paste(m[from,to], "-", paste("k", from, "bound", sep = "_")) |
374 |
} |
|
375 | 8074x |
if(grepl("_bound", from)) { # add backtransfer to free compartment for SFORB |
376 | 24x |
m[from,to] = paste("- k", from, "free", sep = "_") |
377 |
} |
|
378 | 8074x |
m[from,to] = m[from,to] |
379 |
} else { # off-diagonal elements |
|
380 | 7146x |
f.candidate = paste("f", from, "to", to, sep = "_") |
381 | 7146x |
k.candidate = paste("k", from, to, sep = "_") |
382 | 7146x |
k.candidate = sub("free.*bound", "free_bound", k.candidate) |
383 | 7146x |
k.candidate = sub("bound.*free", "bound_free", k.candidate) |
384 | 7146x |
m[to, from] = ifelse(f.candidate %in% model$parms, |
385 | 7146x |
paste(f.candidate, " * k_", from, sep = ""), |
386 | 7146x |
ifelse(k.candidate %in% model$parms, k.candidate, "0")) |
387 |
# Special case: singular pathway and no sink |
|
388 | 7146x |
if (spec[[from]]$sink == FALSE && length(spec[[from]]$to) == 1 && to %in% spec[[from]]$to) { |
389 | 689x |
m[to, from] = paste("k", from, sep = "_") |
390 |
} |
|
391 |
} |
|
392 |
} |
|
393 |
} |
|
394 |
} # }}} |
|
395 | 5941x |
model$coefmat <- m |
396 |
}#}}} |
|
397 | ||
398 |
# Try to create a function compiled from C code if there is more than one observed variable {{{ |
|
399 |
# and a compiler is available |
|
400 | 8117x |
if (length(obs_vars) > 1 & pkgbuild::has_compiler()) { |
401 | ||
402 |
# Translate the R code for the derivatives to C code |
|
403 | 3728x |
diffs.C <- paste(diffs, collapse = ";\n") |
404 | 3728x |
diffs.C <- paste0(diffs.C, ";") |
405 | ||
406 |
# HS |
|
407 | 3728x |
diffs.C <- gsub(HS_decline, "(time <= tb ? k1 : k2)", diffs.C, fixed = TRUE) |
408 | ||
409 | 3728x |
for (i in seq_along(diffs)) { |
410 | 8347x |
state_var <- names(diffs)[i] |
411 | ||
412 |
# IORE |
|
413 | 8347x |
if (state_var %in% obs_vars) { |
414 | 8343x |
if (spec[[state_var]]$type == "IORE") { |
415 | ! |
diffs.C <- gsub(paste0(state_var, "^N_", state_var), |
416 | ! |
paste0("pow(y[", i - 1, "], N_", state_var, ")"), |
417 | ! |
diffs.C, fixed = TRUE) |
418 |
} |
|
419 |
} |
|
420 | ||
421 |
# Replace d_... terms by f[i-1] |
|
422 |
# First line |
|
423 | 8347x |
pattern <- paste0("^d_", state_var) |
424 | 8347x |
replacement <- paste0("\nf[", i - 1, "]") |
425 | 8347x |
diffs.C <- gsub(pattern, replacement, diffs.C) |
426 |
# Other lines |
|
427 | 8347x |
pattern <- paste0("\\nd_", state_var) |
428 | 8347x |
replacement <- paste0("\nf[", i - 1, "]") |
429 | 8347x |
diffs.C <- gsub(pattern, replacement, diffs.C) |
430 | ||
431 |
# Replace names of observed variables by y[i], |
|
432 |
# making the implicit assumption that the observed variables only occur after "* " |
|
433 | 8347x |
pattern <- paste0("\\* ", state_var) |
434 | 8347x |
replacement <- paste0("* y[", i - 1, "]") |
435 | 8347x |
diffs.C <- gsub(pattern, replacement, diffs.C) |
436 |
} |
|
437 | ||
438 | 3728x |
derivs_sig <- signature(n = "integer", t = "numeric", y = "numeric", |
439 | 3728x |
f = "numeric", rpar = "numeric", ipar = "integer") |
440 | ||
441 |
# Declare the time variable in the body of the function if it is used |
|
442 | 3728x |
derivs_code <- if (spec[[1]]$type %in% c("FOMC", "DFOP", "HS")) { |
443 | 1060x |
paste0("double time = *t;\n", diffs.C) |
444 |
} else { |
|
445 | 2668x |
diffs.C |
446 |
} |
|
447 | ||
448 |
# Define the function initializing the parameters |
|
449 | 3728x |
npar <- length(parms) |
450 | 3728x |
initpar_code <- paste0( |
451 | 3728x |
"static double parms [", npar, "];\n", |
452 | 3728x |
paste0("#define ", parms, " parms[", 0:(npar - 1), "]\n", collapse = ""), |
453 | 3728x |
"\n", |
454 | 3728x |
"void initpar(void (* odeparms)(int *, double *)) {\n", |
455 | 3728x |
" int N = ", npar, ";\n", |
456 | 3728x |
" odeparms(&N, parms);\n", |
457 | 3728x |
"}\n\n") |
458 | ||
459 |
# Try to build a shared library |
|
460 | 3728x |
model$cf <- try(inline::cfunction(derivs_sig, derivs_code, |
461 | 3728x |
otherdefs = initpar_code, |
462 | 3728x |
verbose = verbose, name = "diffs", |
463 | 3728x |
convention = ".C", language = "C"), |
464 | 3728x |
silent = TRUE) |
465 | ||
466 | 3728x |
if (!inherits(model$cf, "try-error")) { |
467 | 495x |
if (!quiet) message("Temporary DLL for differentials generated and loaded") |
468 | 3728x |
if (!is.null(dll_dir)) { |
469 |
# We suppress warnings, as we get a warning about a path "(embedding)" |
|
470 |
# under Windows, at least when using RStudio |
|
471 | 247x |
suppressWarnings(inline::moveDLL(model$cf, name, dll_dir, |
472 | 247x |
unload = unload, overwrite = overwrite, verbose = !quiet)) |
473 |
} |
|
474 | 3728x |
model$dll_info <- inline::getDynLib(model$cf) |
475 |
} |
|
476 |
} |
|
477 |
# }}} |
|
478 | ||
479 |
# Attach a degradation function if an analytical solution is available |
|
480 | 8117x |
model$deg_func <- create_deg_func(spec, use_of_ff) |
481 | ||
482 | 8117x |
class(model) <- "mkinmod" |
483 | 8117x |
return(model) |
484 |
} |
|
485 | ||
486 |
#' Print mkinmod objects |
|
487 |
#' |
|
488 |
#' Print mkinmod objects in a way that the user finds his way to get to its |
|
489 |
#' components. |
|
490 |
#' |
|
491 |
#' @rdname mkinmod |
|
492 |
#' @param x An \code{\link{mkinmod}} object. |
|
493 |
#' @export |
|
494 |
print.mkinmod <- function(x, ...) { |
|
495 | 104x |
cat("<mkinmod> model generated with\n") |
496 | 104x |
cat("Use of formation fractions $use_of_ff:", x$use_of_ff, "\n") |
497 | 104x |
cat("Specification $spec:\n") |
498 | 104x |
for (obs in names(x$spec)) { |
499 | 208x |
cat("$", obs, "\n", sep = "") |
500 | 208x |
spl <- x$spec[[obs]] |
501 | 208x |
cat("$type:", spl$type) |
502 | 104x |
if (!is.null(spl$to) && length(spl$to)) cat("; $to: ", paste(spl$to, collapse = ", "), sep = "") |
503 | 208x |
cat("; $sink: ", spl$sink, sep = "") |
504 | ! |
if (!is.null(spl$full_name)) if (!is.na(spl$full_name)) cat("; $full_name:", spl$full_name) |
505 | 208x |
cat("\n") |
506 |
} |
|
507 | 104x |
if (is.matrix(x$coefmat)) cat("Coefficient matrix $coefmat available\n") |
508 | ! |
if (!is.null(x$cf)) cat("Compiled model $cf available\n") |
509 | 104x |
cat("Differential equations:\n") |
510 | 104x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]]) |
511 | 104x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
512 |
} |
|
513 |
# vim: set foldmethod=marker ts=2 sw=2 expandtab: |
1 |
#' Fit nonlinear mixed-effects models built from one or more kinetic |
|
2 |
#' degradation models and one or more error models |
|
3 |
#' |
|
4 |
#' The name of the methods expresses that (**m**ultiple) **h**ierarchichal |
|
5 |
#' (also known as multilevel) **m**ulticompartment **kin**etic models are |
|
6 |
#' fitted. Our kinetic models are nonlinear, so we can use various nonlinear |
|
7 |
#' mixed-effects model fitting functions. |
|
8 |
#' |
|
9 |
#' @param objects A list of [mmkin] objects containing fits of the same |
|
10 |
#' degradation models to the same data, but using different error models. |
|
11 |
#' Alternatively, a single [mmkin] object containing fits of several |
|
12 |
#' degradation models to the same data |
|
13 |
#' @param backend The backend to be used for fitting. Currently, only saemix is |
|
14 |
#' supported |
|
15 |
#' @param no_random_effect Default is NULL and will be passed to [saem]. If a |
|
16 |
#' character vector is supplied, it will be passed to all calls to [saem], |
|
17 |
#' which will exclude random effects for all matching parameters. Alternatively, |
|
18 |
#' a list of character vectors or an object of class [illparms.mhmkin] can be |
|
19 |
#' specified. They have to have the same dimensions that the return object of |
|
20 |
#' the current call will have, i.e. the number of rows must match the number |
|
21 |
#' of degradation models in the mmkin object(s), and the number of columns must |
|
22 |
#' match the number of error models used in the mmkin object(s). |
|
23 |
#' @param algorithm The algorithm to be used for fitting (currently not used) |
|
24 |
#' @param \dots Further arguments that will be passed to the nonlinear mixed-effects |
|
25 |
#' model fitting function. |
|
26 |
#' @param cores The number of cores to be used for multicore processing. This |
|
27 |
#' is only used when the \code{cluster} argument is \code{NULL}. On Windows |
|
28 |
#' machines, cores > 1 is not supported, you need to use the \code{cluster} |
|
29 |
#' argument to use multiple logical processors. Per default, all cores detected |
|
30 |
#' by [parallel::detectCores()] are used, except on Windows where the default |
|
31 |
#' is 1. |
|
32 |
#' @param cluster A cluster as returned by [makeCluster] to be used for |
|
33 |
#' parallel execution. |
|
34 |
#' @importFrom parallel mclapply parLapply detectCores |
|
35 |
#' @return A two-dimensional [array] of fit objects and/or try-errors that can |
|
36 |
#' be indexed using the degradation model names for the first index (row index) |
|
37 |
#' and the error model names for the second index (column index), with class |
|
38 |
#' attribute 'mhmkin'. |
|
39 |
#' @author Johannes Ranke |
|
40 |
#' @seealso \code{\link{[.mhmkin}} for subsetting [mhmkin] objects |
|
41 |
#' @export |
|
42 |
mhmkin <- function(objects, ...) { |
|
43 | 375x |
UseMethod("mhmkin") |
44 |
} |
|
45 | ||
46 |
#' @export |
|
47 |
#' @rdname mhmkin |
|
48 |
mhmkin.mmkin <- function(objects, ...) { |
|
49 | ! |
mhmkin(list(objects), ...) |
50 |
} |
|
51 | ||
52 |
#' @export |
|
53 |
#' @rdname mhmkin |
|
54 |
#' @examples |
|
55 |
#' \dontrun{ |
|
56 |
#' # We start with separate evaluations of all the first six datasets with two |
|
57 |
#' # degradation models and two error models |
|
58 |
#' f_sep_const <- mmkin(c("SFO", "FOMC"), ds_fomc[1:6], cores = 2, quiet = TRUE) |
|
59 |
#' f_sep_tc <- update(f_sep_const, error_model = "tc") |
|
60 |
#' # The mhmkin function sets up hierarchical degradation models aka |
|
61 |
#' # nonlinear mixed-effects models for all four combinations, specifying |
|
62 |
#' # uncorrelated random effects for all degradation parameters |
|
63 |
#' f_saem_1 <- mhmkin(list(f_sep_const, f_sep_tc), cores = 2) |
|
64 |
#' status(f_saem_1) |
|
65 |
#' # The 'illparms' function shows that in all hierarchical fits, at least |
|
66 |
#' # one random effect is ill-defined (the confidence interval for the |
|
67 |
#' # random effect expressed as standard deviation includes zero) |
|
68 |
#' illparms(f_saem_1) |
|
69 |
#' # Therefore we repeat the fits, excluding the ill-defined random effects |
|
70 |
#' f_saem_2 <- update(f_saem_1, no_random_effect = illparms(f_saem_1)) |
|
71 |
#' status(f_saem_2) |
|
72 |
#' illparms(f_saem_2) |
|
73 |
#' # Model comparisons show that FOMC with two-component error is preferable, |
|
74 |
#' # and confirms our reduction of the default parameter model |
|
75 |
#' anova(f_saem_1) |
|
76 |
#' anova(f_saem_2) |
|
77 |
#' # The convergence plot for the selected model looks fine |
|
78 |
#' saemix::plot(f_saem_2[["FOMC", "tc"]]$so, plot.type = "convergence") |
|
79 |
#' # The plot of predictions versus data shows that we have a pretty data-rich |
|
80 |
#' # situation with homogeneous distribution of residuals, because we used the |
|
81 |
#' # same degradation model, error model and parameter distribution model that |
|
82 |
#' # was used in the data generation. |
|
83 |
#' plot(f_saem_2[["FOMC", "tc"]]) |
|
84 |
#' # We can specify the same parameter model reductions manually |
|
85 |
#' no_ranef <- list("parent_0", "log_beta", "parent_0", c("parent_0", "log_beta")) |
|
86 |
#' dim(no_ranef) <- c(2, 2) |
|
87 |
#' f_saem_2m <- update(f_saem_1, no_random_effect = no_ranef) |
|
88 |
#' anova(f_saem_2m) |
|
89 |
#' } |
|
90 |
mhmkin.list <- function(objects, backend = "saemix", algorithm = "saem", |
|
91 |
no_random_effect = NULL, |
|
92 |
..., |
|
93 |
cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), cluster = NULL) |
|
94 |
{ |
|
95 | 375x |
call <- match.call() |
96 | 375x |
dot_args <- list(...) |
97 | 375x |
backend_function <- switch(backend, |
98 | 375x |
saemix = "saem" |
99 |
) |
|
100 | ||
101 | 375x |
deg_models <- lapply(objects[[1]][, 1], function(x) x$mkinmod) |
102 | 375x |
names(deg_models) <- dimnames(objects[[1]])$model |
103 | 375x |
n.deg <- length(deg_models) |
104 | ||
105 | 375x |
ds <- lapply(objects[[1]][1, ], function(x) x$data) |
106 | ||
107 | 375x |
for (other in objects[-1]) { |
108 |
# Check if the degradation models in all objects are the same |
|
109 | 375x |
for (deg_model_name in names(deg_models)) { |
110 | 750x |
if (!all.equal(other[[deg_model_name, 1]]$mkinmod$spec, |
111 | 750x |
deg_models[[deg_model_name]]$spec)) |
112 |
{ |
|
113 | ! |
stop("The mmkin objects have to be based on the same degradation models") |
114 |
} |
|
115 |
} |
|
116 |
# Check if they have been fitted to the same dataset |
|
117 | 375x |
other_object_ds <- lapply(other[1, ], function(x) x$data) |
118 | 375x |
for (i in 1:length(ds)) { |
119 | 2250x |
if (!all.equal(ds[[i]][c("time", "variable", "observed")], |
120 | 2250x |
other_object_ds[[i]][c("time", "variable", "observed")])) |
121 |
{ |
|
122 | ! |
stop("The mmkin objects have to be fitted to the same datasets") |
123 |
} |
|
124 |
} |
|
125 |
} |
|
126 | ||
127 | 375x |
n.o <- length(objects) |
128 | ||
129 | 375x |
error_models = sapply(objects, function(x) x[[1]]$err_mod) |
130 | 375x |
n.e <- length(error_models) |
131 | ||
132 | 375x |
n.fits <- n.deg * n.e |
133 | 375x |
fit_indices <- matrix(1:n.fits, ncol = n.e) |
134 | 375x |
dimnames(fit_indices) <- list(degradation = names(deg_models), |
135 | 375x |
error = error_models) |
136 | ||
137 | 375x |
if (is.null(no_random_effect) || is.null(dim(no_random_effect))) { |
138 | 129x |
no_ranef <- rep(list(no_random_effect), n.fits) |
139 | 129x |
dim(no_ranef) <- dim(fit_indices) |
140 |
} else { |
|
141 | 246x |
if (!identical(dim(no_random_effect), dim(fit_indices))) { |
142 | ! |
stop("Dimensions of argument 'no_random_effect' are not suitable") |
143 |
} |
|
144 | 246x |
if (is(no_random_effect, "illparms.mhmkin")) { |
145 | 125x |
no_ranef_dim <- dim(no_random_effect) |
146 | 125x |
no_ranef <- lapply(no_random_effect, function(x) { |
147 | 500x |
no_ranef_split <- strsplit(x, ", ") |
148 | 500x |
ret <- sapply(no_ranef_split, function(y) { |
149 | 500x |
gsub("sd\\((.*)\\)", "\\1", y) |
150 |
}) |
|
151 | 500x |
return(ret) |
152 |
}) |
|
153 | 125x |
dim(no_ranef) <- no_ranef_dim |
154 |
} else { |
|
155 | 121x |
no_ranef <- no_random_effect |
156 |
} |
|
157 |
} |
|
158 | ||
159 | 375x |
fit_function <- function(fit_index) { |
160 | 12x |
w <- which(fit_indices == fit_index, arr.ind = TRUE) |
161 | 12x |
deg_index <- w[1] |
162 | 12x |
error_index <- w[2] |
163 | 12x |
mmkin_row <- objects[[error_index]][deg_index, ] |
164 | 12x |
res <- try(do.call(backend_function, |
165 | 12x |
args = c( |
166 | 12x |
list(mmkin_row), |
167 | 12x |
dot_args, |
168 | 12x |
list(no_random_effect = no_ranef[[deg_index, error_index]])))) |
169 | 12x |
return(res) |
170 |
} |
|
171 | ||
172 | ||
173 | 375x |
fit_time <- system.time({ |
174 | 375x |
if (is.null(cluster)) { |
175 | 375x |
results <- parallel::mclapply(as.list(1:n.fits), fit_function, |
176 | 375x |
mc.cores = cores, mc.preschedule = FALSE) |
177 |
} else { |
|
178 | ! |
results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function) |
179 |
} |
|
180 |
}) |
|
181 | ||
182 | 363x |
attributes(results) <- attributes(fit_indices) |
183 | 363x |
attr(results, "call") <- call |
184 | 363x |
attr(results, "time") <- fit_time |
185 | 363x |
class(results) <- switch(backend, |
186 | 363x |
saemix = c("mhmkin.saem.mmkin", "mhmkin") |
187 |
) |
|
188 | 363x |
return(results) |
189 |
} |
|
190 | ||
191 |
#' Subsetting method for mhmkin objects |
|
192 |
#' |
|
193 |
#' @param x An [mhmkin] object. |
|
194 |
#' @param i Row index selecting the fits for specific models |
|
195 |
#' @param j Column index selecting the fits to specific datasets |
|
196 |
#' @param drop If FALSE, the method always returns an mhmkin object, otherwise |
|
197 |
#' either a list of fit objects or a single fit object. |
|
198 |
#' @return An object inheriting from \code{\link{mhmkin}}. |
|
199 |
#' @rdname mhmkin |
|
200 |
#' @export |
|
201 |
`[.mhmkin` <- function(x, i, j, ..., drop = FALSE) { |
|
202 | ! |
original_class <- class(x) |
203 | ! |
class(x) <- NULL |
204 | ! |
x_sub <- x[i, j, drop = drop] |
205 | ||
206 | ! |
if (!drop) { |
207 | ! |
class(x_sub) <- original_class |
208 |
} |
|
209 | ! |
return(x_sub) |
210 |
} |
|
211 | ||
212 |
#' Print method for mhmkin objects |
|
213 |
#' |
|
214 |
#' @rdname mhmkin |
|
215 |
#' @export |
|
216 |
print.mhmkin <- function(x, ...) { |
|
217 | 125x |
cat("<mhmkin> object\n") |
218 | 125x |
cat("Status of individual fits:\n\n") |
219 | 125x |
print(status(x)) |
220 |
} |
|
221 | ||
222 |
#' Check if fit within an mhmkin object failed |
|
223 |
#' @param x The object to be checked |
|
224 |
check_failed <- function(x) { |
|
225 | 1936x |
if (inherits(x, "try-error")) { |
226 | ! |
return(TRUE) |
227 |
} else { |
|
228 | 1936x |
if (inherits(x$so, "try-error")) { |
229 | ! |
return(TRUE) |
230 |
} else { |
|
231 | 1936x |
return(FALSE) |
232 |
} |
|
233 |
} |
|
234 |
} |
|
235 | ||
236 |
#' @export |
|
237 |
AIC.mhmkin <- function(object, ..., k = 2) { |
|
238 | 125x |
res <- sapply(object, function(x) { |
239 | ! |
if (check_failed(x)) return(NA) |
240 | 500x |
else return(AIC(x$so, k = k)) |
241 |
}) |
|
242 | 125x |
dim(res) <- dim(object) |
243 | 125x |
dimnames(res) <- dimnames(object) |
244 | 125x |
return(res) |
245 |
} |
|
246 | ||
247 |
#' @export |
|
248 |
BIC.mhmkin <- function(object, ...) { |
|
249 | 125x |
res <- sapply(object, function(x) { |
250 | ! |
if (check_failed(x)) return(NA) |
251 | 500x |
else return(BIC(x$so)) |
252 |
}) |
|
253 | 125x |
dim(res) <- dim(object) |
254 | 125x |
dimnames(res) <- dimnames(object) |
255 | 125x |
return(res) |
256 |
} |
|
257 | ||
258 |
#' @export |
|
259 |
update.mhmkin <- function(object, ..., evaluate = TRUE) { |
|
260 | 246x |
call <- attr(object, "call") |
261 |
# For some reason we get mhkin.list in call[[1]] when using mhmkin from the |
|
262 |
# loaded package so we need to fix this so we do not have to export |
|
263 |
# mhmkin.list in addition to the S3 method mhmkin |
|
264 | 246x |
call[[1]] <- mhmkin |
265 | ||
266 | 246x |
update_arguments <- match.call(expand.dots = FALSE)$... |
267 | ||
268 | 246x |
if (length(update_arguments) > 0) { |
269 | 246x |
update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) |
270 |
} |
|
271 | ||
272 | 246x |
for (a in names(update_arguments)[update_arguments_in_call]) { |
273 | ! |
call[[a]] <- update_arguments[[a]] |
274 |
} |
|
275 | ||
276 | 246x |
update_arguments_not_in_call <- !update_arguments_in_call |
277 | 246x |
if(any(update_arguments_not_in_call)) { |
278 | 246x |
call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) |
279 | 246x |
call <- as.call(call) |
280 |
} |
|
281 | 246x |
if(evaluate) eval(call, parent.frame()) |
282 | ! |
else call |
283 |
} |
|
284 | ||
285 |
#' @export |
|
286 |
anova.mhmkin <- function(object, ..., |
|
287 |
method = c("is", "lin", "gq"), test = FALSE, model.names = "auto") { |
|
288 | 234x |
if (identical(model.names, "auto")) { |
289 | 234x |
model.names <- outer(rownames(object), colnames(object), paste) |
290 |
} |
|
291 | 234x |
failed_index <- which(sapply(object, check_failed), arr.ind = TRUE) |
292 | 234x |
if (length(failed_index > 0)) { |
293 | ! |
rlang::inject(anova(!!!(object[-failed_index]), method = method, test = test, |
294 | ! |
model.names = model.names[-failed_index])) |
295 |
} else { |
|
296 | 234x |
rlang::inject(anova(!!!(object), method = method, test = test, |
297 | 234x |
model.names = model.names)) |
298 |
} |
|
299 |
} |
|
300 |
1 |
#' Evaluate parent kinetics using the NAFTA guidance |
|
2 |
#' |
|
3 |
#' The function fits the SFO, IORE and DFOP models using \code{\link{mmkin}} |
|
4 |
#' and returns an object of class \code{nafta} that has methods for printing |
|
5 |
#' and plotting. |
|
6 |
#' |
|
7 |
#' @param ds A dataframe that must contain one variable called "time" with the |
|
8 |
#' time values specified by the \code{time} argument, one column called |
|
9 |
#' "name" with the grouping of the observed values, and finally one column of |
|
10 |
#' observed values called "value". |
|
11 |
#' @param title Optional title of the dataset |
|
12 |
#' @param quiet Should the evaluation text be shown? |
|
13 |
#' @param \dots Further arguments passed to \code{\link{mmkin}} (not for the |
|
14 |
#' printing method). |
|
15 |
#' @importFrom stats qf |
|
16 |
#' @return An list of class \code{nafta}. The list element named "mmkin" is the |
|
17 |
#' \code{\link{mmkin}} object containing the fits of the three models. The |
|
18 |
#' list element named "title" contains the title of the dataset used. The |
|
19 |
#' list element "data" contains the dataset used in the fits. |
|
20 |
#' @author Johannes Ranke |
|
21 |
#' @source NAFTA (2011) Guidance for evaluating and calculating degradation |
|
22 |
#' kinetics in environmental media. NAFTA Technical Working Group on |
|
23 |
#' Pesticides |
|
24 |
#' \url{https://www.epa.gov/pesticide-science-and-assessing-pesticide-risks/guidance-evaluating-and-calculating-degradation} |
|
25 |
#' accessed 2019-02-22 |
|
26 |
#' |
|
27 |
#' US EPA (2015) Standard Operating Procedure for Using the NAFTA Guidance to |
|
28 |
#' Calculate Representative Half-life Values and Characterizing Pesticide |
|
29 |
#' Degradation |
|
30 |
#' \url{https://www.epa.gov/pesticide-science-and-assessing-pesticide-risks/standard-operating-procedure-using-nafta-guidance} |
|
31 |
#' @examples |
|
32 |
#' |
|
33 |
#' nafta_evaluation <- nafta(NAFTA_SOP_Appendix_D, cores = 1) |
|
34 |
#' print(nafta_evaluation) |
|
35 |
#' plot(nafta_evaluation) |
|
36 |
#' |
|
37 |
#' @export |
|
38 |
nafta <- function(ds, title = NA, quiet = FALSE, ...) { |
|
39 | 264x |
if (length(levels(ds$name)) > 1) { |
40 | 88x |
stop("The NAFTA procedure is only defined for decline data for a single compound") |
41 |
} |
|
42 | 176x |
n <- nrow(subset(ds, !is.na(value))) |
43 | 176x |
models <- c("SFO", "IORE", "DFOP") |
44 | ||
45 | 176x |
result <- list(title = title, data = ds) |
46 | 176x |
result$mmkin <- mmkin(models, list(ds), quiet = TRUE, ...) |
47 | ||
48 | 176x |
distimes <- lapply(result$mmkin, function(x) as.numeric(endpoints(x)$distimes["parent", ])) |
49 | ||
50 | 176x |
result$distimes <- matrix(NA, nrow = 3, ncol = 3, |
51 | 176x |
dimnames = list(models, c("DT50", "DT90", "DT50_rep"))) |
52 | 176x |
result$distimes["SFO", ] <- distimes[[1]][c(1, 2, 1)] |
53 | 176x |
result$distimes["IORE", ] <- distimes[[2]][c(1, 2, 3)] |
54 | 176x |
result$distimes["DFOP", ] <- distimes[[3]][c(1, 2, 5)] |
55 | ||
56 |
# Get parameters with statistics |
|
57 | 176x |
result$parameters <- lapply(result$mmkin, function(x) { |
58 | 528x |
summary(x)$bpar[, c(1, 4:6)] |
59 |
}) |
|
60 | 176x |
names(result$parameters) <- models |
61 | ||
62 |
# Compare the sum of squared residuals (SSR) to the upper bound of the |
|
63 |
# confidence region of the SSR for the IORE model |
|
64 | 176x |
result$S <- sapply(result$mmkin, function(x) sum(x$data$residual^2)) |
65 | 176x |
names(result$S) <- c("SFO", "IORE", "DFOP") |
66 |
# Equation (3) on p. 3 |
|
67 | 176x |
p <- 3 |
68 | 176x |
result$S["IORE"] |
69 | 176x |
result$S_c <- result$S[["IORE"]] * (1 + p/(n - p) * qf(0.5, p, n - p)) |
70 | ||
71 | 176x |
result$t_rep <- .evaluate_nafta_results(result$S, result$S_c, |
72 | 176x |
result$distimes, quiet = quiet) |
73 | ||
74 | 176x |
class(result) <- "nafta" |
75 | 176x |
return(result) |
76 |
} |
|
77 | ||
78 |
#' Plot the results of the three models used in the NAFTA scheme. |
|
79 |
#' |
|
80 |
#' The plots are ordered with increasing complexity of the model in this |
|
81 |
#' function (SFO, then IORE, then DFOP). |
|
82 |
#' |
|
83 |
#' Calls \code{\link{plot.mmkin}}. |
|
84 |
#' |
|
85 |
#' @param x An object of class \code{\link{nafta}}. |
|
86 |
#' @param legend Should a legend be added? |
|
87 |
#' @param main Possibility to override the main title of the plot. |
|
88 |
#' @param \dots Further arguments passed to \code{\link{plot.mmkin}}. |
|
89 |
#' @return The function is called for its side effect. |
|
90 |
#' @author Johannes Ranke |
|
91 |
#' @export |
|
92 |
plot.nafta <- function(x, legend = FALSE, main = "auto", ...) { |
|
93 | 176x |
if (main == "auto") { |
94 | ! |
if (is.na(x$title)) main = "" |
95 | 176x |
else main = x$title |
96 |
} |
|
97 | 176x |
plot(x$mmkin, ..., legend = legend, main = main) |
98 |
} |
|
99 | ||
100 |
#' Print nafta objects |
|
101 |
#' |
|
102 |
#' Print nafta objects. The results for the three models are printed in the |
|
103 |
#' order of increasing model complexity, i.e. SFO, then IORE, and finally DFOP. |
|
104 |
#' |
|
105 |
#' @param x An \code{\link{nafta}} object. |
|
106 |
#' @param digits Number of digits to be used for printing parameters and |
|
107 |
#' dissipation times. |
|
108 |
#' @rdname nafta |
|
109 |
#' @export |
|
110 |
print.nafta <- function(x, quiet = TRUE, digits = 3, ...) { |
|
111 | 176x |
cat("Sums of squares:\n") |
112 | 176x |
print(x$S) |
113 | 176x |
cat("\nCritical sum of squares for checking the SFO model:\n") |
114 | 176x |
print(x$S_c) |
115 | 176x |
cat("\nParameters:\n") |
116 | 176x |
print(x$parameters, digits = digits) |
117 | 176x |
t_rep <- .evaluate_nafta_results(x$S, x$S_c, x$distimes, quiet = quiet) |
118 | 176x |
cat("\nDTx values:\n") |
119 | 176x |
print(signif(x$distimes, digits = digits)) |
120 | 176x |
cat("\nRepresentative half-life:\n") |
121 | 176x |
print(round(t_rep, 2)) |
122 |
} |
|
123 | ||
124 |
.evaluate_nafta_results <- function(S, S_c, distimes, quiet = FALSE) { |
|
125 | 352x |
t_SFO <- distimes["IORE", "DT50"] |
126 | 352x |
t_IORE <- distimes["IORE", "DT50_rep"] |
127 | 352x |
t_DFOP2 <- distimes["DFOP", "DT50_rep"] |
128 | ||
129 | 352x |
if (S["SFO"] < S_c) { |
130 | ! |
if (!quiet) { |
131 | ! |
message("S_SFO is lower than the critical value S_c, use the SFO model") |
132 |
} |
|
133 | ! |
t_rep <- t_SFO |
134 |
} else { |
|
135 | 352x |
if (!quiet) { |
136 | 88x |
message("The SFO model is rejected as S_SFO is equal or higher than the critical value S_c") |
137 |
} |
|
138 | 352x |
if (t_IORE < t_DFOP2) { |
139 | 176x |
if (!quiet) { |
140 | 88x |
message("The half-life obtained from the IORE model may be used") |
141 |
} |
|
142 | 176x |
t_rep <- t_IORE |
143 |
} else { |
|
144 | 176x |
if (!quiet) { |
145 | ! |
message("The representative half-life of the IORE model is longer than the one corresponding") |
146 | ! |
message("to the terminal degradation rate found with the DFOP model.") |
147 | ! |
message("The representative half-life obtained from the DFOP model may be used") |
148 |
} |
|
149 | 176x |
t_rep <- t_DFOP2 |
150 |
} |
|
151 |
} |
|
152 | 352x |
return(t_rep) |
153 |
} |
1 |
#' Summary method for class "nlme.mmkin" |
|
2 |
#' |
|
3 |
#' Lists model equations, initial parameter values, optimised parameters |
|
4 |
#' for fixed effects (population), random effects (deviations from the |
|
5 |
#' population mean) and residual error model, as well as the resulting |
|
6 |
#' endpoints such as formation fractions and DT50 values. Optionally |
|
7 |
#' (default is FALSE), the data are listed in full. |
|
8 |
#' |
|
9 |
#' @param object an object of class [nlme.mmkin] |
|
10 |
#' @param x an object of class [summary.nlme.mmkin] |
|
11 |
#' @param data logical, indicating whether the full data should be included in |
|
12 |
#' the summary. |
|
13 |
#' @param verbose Should the summary be verbose? |
|
14 |
#' @param distimes logical, indicating whether DT50 and DT90 values should be |
|
15 |
#' included. |
|
16 |
#' @param alpha error level for confidence interval estimation from the t |
|
17 |
#' distribution |
|
18 |
#' @param digits Number of digits to use for printing |
|
19 |
#' @param \dots optional arguments passed to methods like \code{print}. |
|
20 |
#' @return The summary function returns a list based on the [nlme] object |
|
21 |
#' obtained in the fit, with at least the following additional components |
|
22 |
#' \item{nlmeversion, mkinversion, Rversion}{The nlme, mkin and R versions used} |
|
23 |
#' \item{date.fit, date.summary}{The dates where the fit and the summary were |
|
24 |
#' produced} |
|
25 |
#' \item{diffs}{The differential equations used in the degradation model} |
|
26 |
#' \item{use_of_ff}{Was maximum or minimum use made of formation fractions} |
|
27 |
#' \item{data}{The data} |
|
28 |
#' \item{confint_trans}{Transformed parameters as used in the optimisation, with confidence intervals} |
|
29 |
#' \item{confint_back}{Backtransformed parameters, with confidence intervals if available} |
|
30 |
#' \item{ff}{The estimated formation fractions derived from the fitted |
|
31 |
#' model.} |
|
32 |
#' \item{distimes}{The DT50 and DT90 values for each observed variable.} |
|
33 |
#' \item{SFORB}{If applicable, eigenvalues of SFORB components of the model.} |
|
34 |
#' The print method is called for its side effect, i.e. printing the summary. |
|
35 |
#' @importFrom stats predict |
|
36 |
#' @author Johannes Ranke for the mkin specific parts |
|
37 |
#' José Pinheiro and Douglas Bates for the components inherited from nlme |
|
38 |
#' @examples |
|
39 |
#' |
|
40 |
#' # Generate five datasets following SFO kinetics |
|
41 |
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
42 |
#' dt50_sfo_in_pop <- 50 |
|
43 |
#' k_in_pop <- log(2) / dt50_sfo_in_pop |
|
44 |
#' set.seed(1234) |
|
45 |
#' k_in <- rlnorm(5, log(k_in_pop), 0.5) |
|
46 |
#' SFO <- mkinmod(parent = mkinsub("SFO")) |
|
47 |
#' |
|
48 |
#' pred_sfo <- function(k) { |
|
49 |
#' mkinpredict(SFO, |
|
50 |
#' c(k_parent = k), |
|
51 |
#' c(parent = 100), |
|
52 |
#' sampling_times) |
|
53 |
#' } |
|
54 |
#' |
|
55 |
#' ds_sfo_mean <- lapply(k_in, pred_sfo) |
|
56 |
#' names(ds_sfo_mean) <- paste("ds", 1:5) |
|
57 |
#' |
|
58 |
#' set.seed(12345) |
|
59 |
#' ds_sfo_syn <- lapply(ds_sfo_mean, function(ds) { |
|
60 |
#' add_err(ds, |
|
61 |
#' sdfunc = function(value) sqrt(1^2 + value^2 * 0.07^2), |
|
62 |
#' n = 1)[[1]] |
|
63 |
#' }) |
|
64 |
#' |
|
65 |
#' \dontrun{ |
|
66 |
#' # Evaluate using mmkin and nlme |
|
67 |
#' library(nlme) |
|
68 |
#' f_mmkin <- mmkin("SFO", ds_sfo_syn, quiet = TRUE, error_model = "tc", cores = 1) |
|
69 |
#' f_nlme <- nlme(f_mmkin) |
|
70 |
#' summary(f_nlme, data = TRUE) |
|
71 |
#' } |
|
72 |
#' |
|
73 |
#' @export |
|
74 |
summary.nlme.mmkin <- function(object, data = FALSE, verbose = FALSE, distimes = TRUE, alpha = 0.05, ...) { |
|
75 | ||
76 | 319x |
mod_vars <- names(object$mkinmod$diffs) |
77 | ||
78 | 319x |
confint_trans <- intervals(object, which = "fixed", level = 1 - alpha)$fixed |
79 | 319x |
attr(confint_trans, "label") <- NULL |
80 | 319x |
pnames <- rownames(confint_trans) |
81 | ||
82 | 319x |
bp <- backtransform_odeparms(confint_trans[, "est."], object$mkinmod, |
83 | 319x |
object$transform_rates, object$transform_fractions) |
84 | 319x |
bpnames <- names(bp) |
85 | ||
86 |
# variance-covariance estimates for fixed effects (from summary.lme) |
|
87 | 319x |
fixed <- fixef(object) |
88 | 319x |
stdFixed <- sqrt(diag(as.matrix(object$varFix))) |
89 | 319x |
object$corFixed <- array( |
90 | 319x |
t(object$varFix/stdFixed)/stdFixed, |
91 | 319x |
dim(object$varFix), |
92 | 319x |
list(names(fixed), names(fixed))) |
93 | ||
94 |
# Transform boundaries of CI for one parameter at a time, |
|
95 |
# with the exception of sets of formation fractions (single fractions are OK). |
|
96 | 319x |
f_names_skip <- character(0) |
97 | 319x |
for (box in mod_vars) { # Figure out sets of fractions to skip |
98 | 436x |
f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE) |
99 | 436x |
n_paths <- length(f_names) |
100 | ! |
if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names) |
101 |
} |
|
102 | ||
103 | 319x |
confint_back <- matrix(NA, nrow = length(bp), ncol = 3, |
104 | 319x |
dimnames = list(bpnames, colnames(confint_trans))) |
105 | 319x |
confint_back[, "est."] <- bp |
106 | ||
107 | 319x |
for (pname in pnames) { |
108 | 1410x |
if (!pname %in% f_names_skip) { |
109 | 1410x |
par.lower <- confint_trans[pname, "lower"] |
110 | 1410x |
par.upper <- confint_trans[pname, "upper"] |
111 | 1410x |
names(par.lower) <- names(par.upper) <- pname |
112 | 1410x |
bpl <- backtransform_odeparms(par.lower, object$mkinmod, |
113 | 1410x |
object$transform_rates, |
114 | 1410x |
object$transform_fractions) |
115 | 1410x |
bpu <- backtransform_odeparms(par.upper, object$mkinmod, |
116 | 1410x |
object$transform_rates, |
117 | 1410x |
object$transform_fractions) |
118 | 1410x |
confint_back[names(bpl), "lower"] <- bpl |
119 | 1410x |
confint_back[names(bpu), "upper"] <- bpu |
120 |
} |
|
121 |
} |
|
122 | ||
123 | 319x |
object$confint_trans <- confint_trans |
124 | 319x |
object$confint_back <- confint_back |
125 | ||
126 | 319x |
object$date.summary = date() |
127 | 319x |
object$use_of_ff = object$mkinmod$use_of_ff |
128 | 319x |
object$error_model_algorithm = object$mmkin[[1]]$error_model_algorithm |
129 | 319x |
err_mod = object$mmkin[[1]]$err_mod |
130 | ||
131 | 319x |
object$diffs <- object$mkinmod$diffs |
132 | 319x |
object$print_data <- data |
133 | 319x |
object$data[["observed"]] <- object$data[["value"]] |
134 | 319x |
object$data[["value"]] <- NULL |
135 | 319x |
object$data[["predicted"]] <- predict(object) |
136 | 319x |
object$data[["residual"]] <- residuals(object, type = "response") |
137 | 319x |
if (is.null(object$modelStruct$varStruct)) { |
138 | ! |
object$data[["std"]] <- object$sigma |
139 |
} else { |
|
140 | 319x |
object$data[["std"]] <- 1/attr(object$modelStruct$varStruct, "weights") |
141 |
} |
|
142 | 319x |
object$data[["standardized"]] <- residuals(object, type = "pearson") |
143 | 319x |
object$verbose <- verbose |
144 | ||
145 | 319x |
object$fixed <- object$mmkin[[1]]$fixed |
146 | 319x |
object$AIC = AIC(object) |
147 | 319x |
object$BIC = BIC(object) |
148 | 319x |
object$logLik = logLik(object) |
149 | ||
150 | 319x |
ep <- endpoints(object) |
151 | 319x |
if (length(ep$ff) != 0) |
152 | 117x |
object$ff <- ep$ff |
153 | 319x |
if (distimes) object$distimes <- ep$distimes |
154 | ! |
if (length(ep$SFORB) != 0) object$SFORB <- ep$SFORB |
155 | 319x |
class(object) <- c("summary.nlme.mmkin", "nlme.mmkin", "nlme", "lme") |
156 | 319x |
return(object) |
157 |
} |
|
158 | ||
159 |
#' @rdname summary.nlme.mmkin |
|
160 |
#' @export |
|
161 |
print.summary.nlme.mmkin <- function(x, digits = max(3, getOption("digits") - 3), verbose = x$verbose, ...) { |
|
162 | 117x |
cat("nlme version used for fitting: ", x$nlmeversion, "\n") |
163 | 117x |
cat("mkin version used for pre-fitting: ", x$mkinversion, "\n") |
164 | 117x |
cat("R version used for fitting: ", x$Rversion, "\n") |
165 | ||
166 | 117x |
cat("Date of fit: ", x$date.fit, "\n") |
167 | 117x |
cat("Date of summary:", x$date.summary, "\n") |
168 | ||
169 | 117x |
cat("\nEquations:\n") |
170 | 117x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]]) |
171 | 117x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
172 | ||
173 | 117x |
cat("\nData:\n") |
174 | 117x |
cat(nrow(x$data), "observations of", |
175 | 117x |
length(unique(x$data$name)), "variable(s) grouped in", |
176 | 117x |
length(unique(x$data$ds)), "datasets\n") |
177 | ||
178 | 117x |
cat("\nModel predictions using solution type", x$solution_type, "\n") |
179 | ||
180 | 117x |
cat("\nFitted in", x$time[["elapsed"]], "s using", x$numIter, "iterations\n") |
181 | ||
182 | 117x |
cat("\nVariance model: ") |
183 | 117x |
cat(switch(x$err_mod, |
184 | 117x |
const = "Constant variance", |
185 | 117x |
obs = "Variance unique to each observed variable", |
186 | 117x |
tc = "Two-component variance function"), "\n") |
187 | ||
188 | 117x |
cat("\nMean of starting values for individual parameters:\n") |
189 | 117x |
print(x$mean_dp_start, digits = digits) |
190 | ||
191 | 117x |
cat("\nFixed degradation parameter values:\n") |
192 | 117x |
if(length(x$fixed$value) == 0) cat("None\n") |
193 | ! |
else print(x$fixed, digits = digits) |
194 | ||
195 | 117x |
cat("\nResults:\n\n") |
196 | 117x |
print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik, |
197 | 117x |
row.names = " "), digits = digits, ...) |
198 | ||
199 | 117x |
cat("\nOptimised, transformed parameters with symmetric confidence intervals:\n") |
200 | 117x |
print(x$confint_trans, digits = digits, ...) |
201 | ||
202 | 117x |
if (nrow(x$confint_trans) > 1) { |
203 | 117x |
corr <- x$corFixed |
204 | 117x |
class(corr) <- "correlation" |
205 | 117x |
print(corr, title = "\nCorrelation:", rdig = digits, ...) |
206 |
} |
|
207 | ||
208 | 117x |
cat("\n") # Random effects |
209 | 117x |
print(summary(x$modelStruct), sigma = x$sigma, |
210 | 117x |
reEstimates = x$coef$random, digits = digits, verbose = verbose, ...) |
211 | ||
212 | 117x |
cat("\nBacktransformed parameters with asymmetric confidence intervals:\n") |
213 | 117x |
print(x$confint_back, digits = digits, ...) |
214 | ||
215 | ||
216 | 117x |
printSFORB <- !is.null(x$SFORB) |
217 | 117x |
if(printSFORB){ |
218 | ! |
cat("\nEstimated Eigenvalues of SFORB model(s):\n") |
219 | ! |
print(x$SFORB, digits = digits,...) |
220 |
} |
|
221 | ||
222 | 117x |
printff <- !is.null(x$ff) |
223 | 117x |
if(printff){ |
224 | ! |
cat("\nResulting formation fractions:\n") |
225 | ! |
print(data.frame(ff = x$ff), digits = digits, ...) |
226 |
} |
|
227 | ||
228 | 117x |
printdistimes <- !is.null(x$distimes) |
229 | 117x |
if(printdistimes){ |
230 | 117x |
cat("\nEstimated disappearance times:\n") |
231 | 117x |
print(x$distimes, digits = digits, ...) |
232 |
} |
|
233 | ||
234 | 117x |
if (x$print_data){ |
235 | ! |
cat("\nData:\n") |
236 | ! |
print(format(x$data, digits = digits, ...), row.names = FALSE) |
237 |
} |
|
238 | ||
239 | 117x |
invisible(x) |
240 |
} |
1 |
utils::globalVariables(c("variable", "residual")) |
|
2 | ||
3 |
#' Function to plot squared residuals and the error model for an mkin object |
|
4 |
#' |
|
5 |
#' This function plots the squared residuals for the specified subset of the |
|
6 |
#' observed variables from an mkinfit object. In addition, one or more dashed |
|
7 |
#' line(s) show the fitted error model. A combined plot of the fitted model |
|
8 |
#' and this error model plot can be obtained with \code{\link{plot.mkinfit}} |
|
9 |
#' using the argument \code{show_errplot = TRUE}. |
|
10 |
#' |
|
11 |
#' @param object A fit represented in an \code{\link{mkinfit}} object. |
|
12 |
#' @param obs_vars A character vector of names of the observed variables for |
|
13 |
#' which residuals should be plotted. Defaults to all observed variables in |
|
14 |
#' the model |
|
15 |
#' @param xlim plot range in x direction. |
|
16 |
#' @param xlab Label for the x axis. |
|
17 |
#' @param ylab Label for the y axis. |
|
18 |
#' @param maxy Maximum value of the residuals. This is used for the scaling of |
|
19 |
#' the y axis and defaults to "auto". |
|
20 |
#' @param legend Should a legend be plotted? |
|
21 |
#' @param lpos Where should the legend be placed? Default is "topright". Will |
|
22 |
#' be passed on to \code{\link{legend}}. |
|
23 |
#' @param col_obs Colors for the observed variables. |
|
24 |
#' @param pch_obs Symbols to be used for the observed variables. |
|
25 |
#' @param frame Should a frame be drawn around the plots? |
|
26 |
#' @param \dots further arguments passed to \code{\link{plot}}. |
|
27 |
#' @return Nothing is returned by this function, as it is called for its side |
|
28 |
#' effect, namely to produce a plot. |
|
29 |
#' @author Johannes Ranke |
|
30 |
#' @seealso \code{\link{mkinplot}}, for a way to plot the data and the fitted |
|
31 |
#' lines of the mkinfit object. |
|
32 |
#' @keywords hplot |
|
33 |
#' @examples |
|
34 |
#' |
|
35 |
#' \dontrun{ |
|
36 |
#' model <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO")) |
|
37 |
#' fit <- mkinfit(model, FOCUS_2006_D, error_model = "tc", quiet = TRUE) |
|
38 |
#' mkinerrplot(fit) |
|
39 |
#' } |
|
40 |
#' |
|
41 |
#' @export |
|
42 |
mkinerrplot <- function (object, |
|
43 |
obs_vars = names(object$mkinmod$map), |
|
44 |
xlim = c(0, 1.1 * max(object$data$predicted)), |
|
45 |
xlab = "Predicted", ylab = "Squared residual", |
|
46 |
maxy = "auto", legend= TRUE, lpos = "topright", |
|
47 |
col_obs = "auto", pch_obs = "auto", |
|
48 |
frame = TRUE, |
|
49 |
...) |
|
50 |
{ |
|
51 | 275x |
obs_vars_all <- as.character(unique(object$data$variable)) |
52 | ||
53 | 275x |
if (length(obs_vars) > 0){ |
54 | 275x |
obs_vars <- intersect(obs_vars_all, obs_vars) |
55 | ! |
} else obs_vars <- obs_vars_all |
56 | ||
57 | 275x |
residuals <- subset(object$data, variable %in% obs_vars, residual) |
58 | ||
59 | 275x |
if (maxy == "auto") maxy = max(residuals^2, na.rm = TRUE) |
60 | ||
61 |
# Set colors and symbols |
|
62 | 275x |
if (col_obs[1] == "auto") { |
63 | 70x |
col_obs <- 1:length(obs_vars) |
64 |
} |
|
65 | ||
66 | 275x |
if (pch_obs[1] == "auto") { |
67 | 70x |
pch_obs <- 1:length(obs_vars) |
68 |
} |
|
69 | 275x |
names(col_obs) <- names(pch_obs) <- obs_vars |
70 | ||
71 | 275x |
plot(0, type = "n", |
72 | 275x |
xlab = xlab, ylab = ylab, |
73 | 275x |
xlim = xlim, |
74 | 275x |
ylim = c(0, 1.2 * maxy), frame = frame, ...) |
75 | ||
76 | 275x |
for(obs_var in obs_vars){ |
77 | 410x |
residuals_plot <- subset(object$data, variable == obs_var, c("predicted", "residual")) |
78 | 410x |
points(residuals_plot[["predicted"]], |
79 | 410x |
residuals_plot[["residual"]]^2, |
80 | 410x |
pch = pch_obs[obs_var], col = col_obs[obs_var]) |
81 |
} |
|
82 | ||
83 | 275x |
if (object$err_mod == "const") { |
84 | 140x |
abline(h = object$errparms^2, lty = 2, col = 1) |
85 |
} |
|
86 | 275x |
if (object$err_mod == "obs") { |
87 | 65x |
for (obs_var in obs_vars) { |
88 | 130x |
sigma_name = paste0("sigma_", obs_var) |
89 | 130x |
abline(h = object$errparms[sigma_name]^2, lty = 2, |
90 | 130x |
col = col_obs[obs_var]) |
91 |
} |
|
92 |
} |
|
93 | 275x |
if (object$err_mod == "tc") { |
94 | 70x |
sigma_plot <- function(predicted) { |
95 | 70x |
sigma_twocomp(predicted, |
96 | 70x |
sigma_low = object$errparms[1], |
97 | 70x |
rsd_high = object$errparms[2])^2 |
98 |
} |
|
99 | 70x |
plot(sigma_plot, from = 0, to = max(object$data$predicted), |
100 | 70x |
add = TRUE, lty = 2, col = 1) |
101 |
} |
|
102 | ||
103 | 275x |
if (legend == TRUE) { |
104 | 70x |
legend(lpos, inset = c(0.05, 0.05), legend = obs_vars, |
105 | 70x |
col = col_obs[obs_vars], pch = pch_obs[obs_vars]) |
106 |
} |
|
107 |
} |
1 |
#' Plot parameter variability of multistart objects |
|
2 |
#' |
|
3 |
#' Produces a boxplot with all parameters from the multiple runs, scaled |
|
4 |
#' either by the parameters of the run with the highest likelihood, |
|
5 |
#' or by their medians as proposed in the paper by Duchesne et al. (2021). |
|
6 |
#' |
|
7 |
#' Starting values of degradation model parameters and error model parameters |
|
8 |
#' are shown as green circles. The results obtained in the original run |
|
9 |
#' are shown as red circles. |
|
10 |
#' |
|
11 |
#' @param object The [multistart] object |
|
12 |
#' @param llmin The minimum likelihood of objects to be shown |
|
13 |
#' @param llquant Fractional value for selecting only the fits with higher |
|
14 |
#' likelihoods. Overrides 'llmin'. |
|
15 |
#' @param scale By default, scale parameters using the best |
|
16 |
#' available fit. |
|
17 |
#' If 'median', parameters are scaled using the median parameters from all fits. |
|
18 |
#' @param main Title of the plot |
|
19 |
#' @param lpos Positioning of the legend. |
|
20 |
#' @param \dots Passed to [boxplot] |
|
21 |
#' @references Duchesne R, Guillemin A, Gandrillon O, Crauste F. Practical |
|
22 |
#' identifiability in the frame of nonlinear mixed effects models: the example |
|
23 |
#' of the in vitro erythropoiesis. BMC Bioinformatics. 2021 Oct 4;22(1):478. |
|
24 |
#' doi: 10.1186/s12859-021-04373-4. |
|
25 |
#' @seealso [multistart] |
|
26 |
#' @importFrom stats median quantile |
|
27 |
#' @export |
|
28 |
parplot <- function(object, ...) { |
|
29 | 176x |
UseMethod("parplot") |
30 |
} |
|
31 | ||
32 |
#' @rdname parplot |
|
33 |
#' @export |
|
34 |
parplot.multistart.saem.mmkin <- function(object, llmin = -Inf, llquant = NA, |
|
35 |
scale = c("best", "median"), |
|
36 |
lpos = "bottomleft", main = "", ...) |
|
37 |
{ |
|
38 | 176x |
oldpar <- par(no.readonly = TRUE) |
39 | 176x |
on.exit(par(oldpar, no.readonly = TRUE)) |
40 | ||
41 | 176x |
orig <- attr(object, "orig") |
42 | 176x |
orig_parms <- parms(orig) |
43 | 176x |
start_degparms <- orig$mean_dp_start |
44 | 176x |
all_parms <- parms(object, exclude_failed = FALSE) |
45 | ||
46 | 176x |
if (inherits(object, "multistart.saem.mmkin")) { |
47 | 176x |
llfunc <- function(object) { |
48 | ! |
if (inherits(object$so, "try-error")) return(NA) |
49 | 1408x |
else return(logLik(object$so)) |
50 |
} |
|
51 |
} else { |
|
52 | ! |
stop("parplot is only implemented for multistart.saem.mmkin objects") |
53 |
} |
|
54 | 176x |
ll <- sapply(object, llfunc) |
55 | 176x |
if (!is.na(llquant[1])) { |
56 | ! |
if (llmin != -Inf) warning("Overriding 'llmin' because 'llquant' was specified") |
57 | 88x |
llmin <- quantile(ll, 1 - llquant) |
58 |
} |
|
59 | 176x |
selected <- which(ll > llmin) |
60 | 176x |
selected_parms <- all_parms[selected, ] |
61 | ||
62 | 176x |
par(las = 1) |
63 | 176x |
if (orig$transformations == "mkin") { |
64 | 88x |
degparm_names_transformed <- names(start_degparms) |
65 | 88x |
degparm_index <- which(names(orig_parms) %in% degparm_names_transformed) |
66 | 88x |
orig_parms[degparm_names_transformed] <- backtransform_odeparms( |
67 | 88x |
orig_parms[degparm_names_transformed], |
68 | 88x |
orig$mmkin[[1]]$mkinmod, |
69 | 88x |
transform_rates = orig$mmkin[[1]]$transform_rates, |
70 | 88x |
transform_fractions = orig$mmkin[[1]]$transform_fractions) |
71 | 88x |
start_degparms <- backtransform_odeparms(start_degparms, |
72 | 88x |
orig$mmkin[[1]]$mkinmod, |
73 | 88x |
transform_rates = orig$mmkin[[1]]$transform_rates, |
74 | 88x |
transform_fractions = orig$mmkin[[1]]$transform_fractions) |
75 | 88x |
degparm_names <- names(start_degparms) |
76 | ||
77 | 88x |
names(orig_parms) <- c(degparm_names, names(orig_parms[-degparm_index])) |
78 | ||
79 | 88x |
selected_parms[, degparm_names_transformed] <- |
80 | 88x |
t(apply(selected_parms[, degparm_names_transformed], 1, backtransform_odeparms, |
81 | 88x |
orig$mmkin[[1]]$mkinmod, |
82 | 88x |
transform_rates = orig$mmkin[[1]]$transform_rates, |
83 | 88x |
transform_fractions = orig$mmkin[[1]]$transform_fractions)) |
84 | 88x |
colnames(selected_parms)[1:length(degparm_names)] <- degparm_names |
85 |
} |
|
86 | ||
87 | 176x |
start_errparms <- orig$so@model@error.init |
88 | 176x |
names(start_errparms) <- orig$so@model@name.sigma |
89 | ||
90 | 176x |
start_omegaparms <- orig$so@model@omega.init |
91 | ||
92 | 176x |
start_parms <- c(start_degparms, start_errparms) |
93 | ||
94 | 176x |
scale <- match.arg(scale) |
95 | 176x |
parm_scale <- switch(scale, |
96 | 176x |
best = selected_parms[which.best(object[selected]), ], |
97 | 176x |
median = apply(selected_parms, 2, median) |
98 |
) |
|
99 | ||
100 |
# Boxplots of all scaled parameters |
|
101 | 176x |
selected_scaled_parms <- t(apply(selected_parms, 1, function(x) x / parm_scale)) |
102 | 176x |
boxplot(selected_scaled_parms, log = "y", main = main, , |
103 | 176x |
ylab = "Normalised parameters", ...) |
104 | ||
105 |
# Show starting parameters |
|
106 | 176x |
start_scaled_parms <- rep(NA_real_, length(orig_parms)) |
107 | 176x |
names(start_scaled_parms) <- names(orig_parms) |
108 | 176x |
start_scaled_parms[names(start_parms)] <- |
109 | 176x |
start_parms / parm_scale[names(start_parms)] |
110 | 176x |
points(start_scaled_parms, col = 3, cex = 3) |
111 | ||
112 |
# Show parameters of original run |
|
113 | 176x |
orig_scaled_parms <- orig_parms / parm_scale |
114 | 176x |
points(orig_scaled_parms, col = 2, cex = 2) |
115 | ||
116 | 176x |
abline(h = 1, lty = 2) |
117 | ||
118 | 176x |
legend(lpos, inset = c(0.05, 0.05), bty = "n", |
119 | 176x |
pch = 1, col = 3:1, lty = c(NA, NA, 1), |
120 | 176x |
legend = c( |
121 | 176x |
"Original start", |
122 | 176x |
"Original results", |
123 | 176x |
"Multistart runs")) |
124 |
} |
1 |
utils::globalVariables("ds") |
|
2 | ||
3 |
#' Plot predictions from a fitted nonlinear mixed model obtained via an mmkin row object |
|
4 |
#' |
|
5 |
#' @param x An object of class [mixed.mmkin], [saem.mmkin] or [nlme.mmkin] |
|
6 |
#' @param i A numeric index to select datasets for which to plot the individual predictions, |
|
7 |
#' in case plots get too large |
|
8 |
#' @inheritParams plot.mkinfit |
|
9 |
#' @param standardized Should the residuals be standardized? Only takes effect if |
|
10 |
#' `resplot = "time"`. |
|
11 |
#' @param pop_curves Per default, one population curve is drawn in case |
|
12 |
#' population parameters are fitted by the model, e.g. for saem objects. |
|
13 |
#' In case there is a covariate model, the behaviour depends on the value |
|
14 |
#' of 'covariates' |
|
15 |
#' @param covariates Data frame with covariate values for all variables in |
|
16 |
#' any covariate models in the object. If given, it overrides 'covariate_quantiles'. |
|
17 |
#' Each line in the data frame will result in a line drawn for the population. |
|
18 |
#' Rownames are used in the legend to label the lines. |
|
19 |
#' @param covariate_quantiles This argument only has an effect if the fitted |
|
20 |
#' object has covariate models. If so, the default is to show three population |
|
21 |
#' curves, for the 5th percentile, the 50th percentile and the 95th percentile |
|
22 |
#' of the covariate values used for fitting the model. |
|
23 |
#' @note Covariate models are currently only supported for saem.mmkin objects. |
|
24 |
#' @param pred_over Named list of alternative predictions as obtained |
|
25 |
#' from [mkinpredict] with a compatible [mkinmod]. |
|
26 |
#' @param test_log_parms Passed to [mean_degparms] in the case of an |
|
27 |
#' [mixed.mmkin] object |
|
28 |
#' @param conf.level Passed to [mean_degparms] in the case of an |
|
29 |
#' [mixed.mmkin] object |
|
30 |
#' @param default_log_parms Passed to [mean_degparms] in the case of an |
|
31 |
#' [mixed.mmkin] object |
|
32 |
#' @param rel.height.legend The relative height of the legend shown on top |
|
33 |
#' @param rel.height.bottom The relative height of the bottom plot row |
|
34 |
#' @param ymax Vector of maximum y axis values |
|
35 |
#' @param ncol.legend Number of columns to use in the legend |
|
36 |
#' @param nrow.legend Number of rows to use in the legend |
|
37 |
#' @param resplot Should the residuals plotted against time or against |
|
38 |
#' predicted values? |
|
39 |
#' @param col_ds Colors used for plotting the observed data and the |
|
40 |
#' corresponding model prediction lines for the different datasets. |
|
41 |
#' @param pch_ds Symbols to be used for plotting the data. |
|
42 |
#' @param lty_ds Line types to be used for the model predictions. |
|
43 |
#' @importFrom stats coefficients |
|
44 |
#' @return The function is called for its side effect. |
|
45 |
#' @author Johannes Ranke |
|
46 |
#' @examples |
|
47 |
#' ds <- lapply(experimental_data_for_UBA_2019[6:10], |
|
48 |
#' function(x) x$data[c("name", "time", "value")]) |
|
49 |
#' names(ds) <- paste0("ds ", 6:10) |
|
50 |
#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"), |
|
51 |
#' A1 = mkinsub("SFO"), quiet = TRUE) |
|
52 |
#' \dontrun{ |
|
53 |
#' f <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE) |
|
54 |
#' plot(f[, 3:4], standardized = TRUE) |
|
55 |
#' |
|
56 |
#' # For this fit we need to increase pnlsMaxiter, and we increase the |
|
57 |
#' # tolerance in order to speed up the fit for this example evaluation |
|
58 |
#' # It still takes 20 seconds to run |
|
59 |
#' f_nlme <- nlme(f, control = list(pnlsMaxIter = 120, tolerance = 1e-3)) |
|
60 |
#' plot(f_nlme) |
|
61 |
#' |
|
62 |
#' f_saem <- saem(f, transformations = "saemix") |
|
63 |
#' plot(f_saem) |
|
64 |
#' |
|
65 |
#' f_obs <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE, error_model = "obs") |
|
66 |
#' f_nlmix <- nlmix(f_obs) |
|
67 |
#' plot(f_nlmix) |
|
68 |
#' |
|
69 |
#' # We can overlay the two variants if we generate predictions |
|
70 |
#' pred_nlme <- mkinpredict(dfop_sfo, |
|
71 |
#' f_nlme$bparms.optim[-1], |
|
72 |
#' c(parent = f_nlme$bparms.optim[[1]], A1 = 0), |
|
73 |
#' seq(0, 180, by = 0.2)) |
|
74 |
#' plot(f_saem, pred_over = list(nlme = pred_nlme)) |
|
75 |
#' } |
|
76 |
#' @export |
|
77 |
plot.mixed.mmkin <- function(x, |
|
78 |
i = 1:ncol(x$mmkin), |
|
79 |
obs_vars = names(x$mkinmod$map), |
|
80 |
standardized = TRUE, |
|
81 |
covariates = NULL, |
|
82 |
covariate_quantiles = c(0.5, 0.05, 0.95), |
|
83 |
xlab = "Time", |
|
84 |
xlim = range(x$data$time), |
|
85 |
resplot = c("predicted", "time"), |
|
86 |
pop_curves = "auto", |
|
87 |
pred_over = NULL, |
|
88 |
test_log_parms = FALSE, |
|
89 |
conf.level = 0.6, |
|
90 |
default_log_parms = NA, |
|
91 |
ymax = "auto", maxabs = "auto", |
|
92 |
ncol.legend = ifelse(length(i) <= 3, length(i) + 1, ifelse(length(i) <= 8, 3, 4)), |
|
93 |
nrow.legend = ceiling((length(i) + 1) / ncol.legend), |
|
94 |
rel.height.legend = 0.02 + 0.07 * nrow.legend, |
|
95 |
rel.height.bottom = 1.1, |
|
96 |
pch_ds = 1:length(i), |
|
97 |
col_ds = pch_ds + 1, |
|
98 |
lty_ds = col_ds, |
|
99 |
frame = TRUE, ... |
|
100 |
) |
|
101 |
{ |
|
102 |
# Prepare parameters and data |
|
103 | 283x |
fit_1 <- x$mmkin[[1]] |
104 | 283x |
ds_names <- colnames(x$mmkin) |
105 | ||
106 | 283x |
backtransform = TRUE |
107 | ||
108 | 283x |
if (identical(class(x), "mixed.mmkin")) { |
109 | 65x |
if (identical(pop_curves, "auto")) { |
110 | ! |
pop_curves <- FALSE |
111 |
} else { |
|
112 | 65x |
pop_curves <- TRUE |
113 |
} |
|
114 | 65x |
if (pop_curves) { |
115 | 65x |
degparms_pop <- mean_degparms(x$mmkin, test_log_parms = test_log_parms, |
116 | 65x |
conf.level = conf.level, default_log_parms = default_log_parms) |
117 |
} |
|
118 | ||
119 | 65x |
degparms_tmp <- parms(x$mmkin, transformed = TRUE) |
120 | 65x |
degparms_i <- as.data.frame(t(degparms_tmp[setdiff(rownames(degparms_tmp), names(fit_1$errparms)), ])) |
121 | 65x |
residual_type = ifelse(standardized, "standardized", "residual") |
122 | 65x |
residuals <- x$data[[residual_type]] |
123 |
} |
|
124 | ||
125 | 283x |
if (inherits(x, "nlme.mmkin")) { |
126 | 65x |
if (identical(pop_curves, "auto")) { |
127 | 65x |
pop_curves <- TRUE |
128 |
} else { |
|
129 | ! |
pop_curves <- FALSE |
130 |
} |
|
131 | 65x |
degparms_i <- coefficients(x) |
132 | 65x |
degparms_pop <- nlme::fixef(x) |
133 | 65x |
residuals <- residuals(x, |
134 | 65x |
type = ifelse(standardized, "pearson", "response")) |
135 |
} |
|
136 | ||
137 | 283x |
if (inherits(x, "saem.mmkin")) { |
138 | 65x |
if (x$transformations == "saemix") backtransform = FALSE |
139 | 153x |
psi <- saemix::psi(x$so) |
140 | 153x |
rownames(psi) <- x$saemix_ds_order |
141 | 153x |
degparms_i <- psi[ds_names, ] |
142 | 153x |
degparms_i_names <- colnames(degparms_i) |
143 | 153x |
residual_type = ifelse(standardized, "standardized", "residual") |
144 | 153x |
residuals <- x$data[[residual_type]] |
145 | ||
146 | 153x |
if (identical(pop_curves, "auto")) { |
147 | 153x |
if (length(x$covariate_models) == 0) { |
148 | 153x |
degparms_pop <- x$so@results@fixed.effects |
149 | 153x |
names(degparms_pop) <- degparms_i_names |
150 | 153x |
pop_curves <- TRUE |
151 |
} else { |
|
152 | ! |
if (is.null(covariates)) { |
153 | ! |
covariates = as.data.frame( |
154 | ! |
apply(x$covariates, 2, quantile, |
155 | ! |
covariate_quantiles, simplify = FALSE)) |
156 | ! |
rownames(covariates) <- paste( |
157 | ! |
ifelse(length(x$covariate_models) == 1, |
158 | ! |
"Covariate", "Covariates"), |
159 | ! |
rownames(covariates)) |
160 |
} |
|
161 | ! |
degparms_pop <- parms(x, covariates = covariates) |
162 | ! |
pop_curves <- TRUE |
163 |
} |
|
164 |
} else { |
|
165 | ! |
pop_curves <- FALSE |
166 |
} |
|
167 |
} |
|
168 | ||
169 | 283x |
if (pop_curves) { |
170 |
# Make sure degparms_pop is a matrix, columns corresponding to population curve(s) |
|
171 | 283x |
if (is.null(dim(degparms_pop))) { |
172 | 283x |
degparms_pop <- matrix(degparms_pop, ncol = 1, |
173 | 283x |
dimnames = list(names(degparms_pop), "Population")) |
174 |
} |
|
175 |
} |
|
176 | ||
177 | 283x |
degparms_fixed <- fit_1$fixed$value |
178 | 283x |
names(degparms_fixed) <- rownames(fit_1$fixed) |
179 | 283x |
degparms_all <- cbind(as.matrix(degparms_i), |
180 | 283x |
matrix(rep(degparms_fixed, nrow(degparms_i)), |
181 | 283x |
ncol = length(degparms_fixed), |
182 | 283x |
nrow = nrow(degparms_i), byrow = TRUE)) |
183 | 283x |
degparms_all_names <- c(names(degparms_i), names(degparms_fixed)) |
184 | 283x |
colnames(degparms_all) <- degparms_all_names |
185 | ||
186 | 283x |
odeini_names <- grep("_0$", degparms_all_names, value = TRUE) |
187 | 283x |
odeparms_names <- setdiff(degparms_all_names, odeini_names) |
188 | ||
189 | 283x |
observed <- cbind(x$data[c("ds", "name", "time", "value")], |
190 | 283x |
residual = residuals) |
191 | ||
192 | 283x |
solution_type = fit_1$solution_type |
193 | ||
194 | 283x |
outtimes <- sort(unique(c(x$data$time, |
195 | 283x |
seq(xlim[1], xlim[2], length.out = 50)))) |
196 | ||
197 | 283x |
pred_list <- lapply(i, function(ds_i) { |
198 | 2945x |
odeparms_trans <- degparms_all[ds_i, odeparms_names] |
199 | 2945x |
names(odeparms_trans) <- odeparms_names # needed if only one odeparm |
200 | 2945x |
if (backtransform) { |
201 | 2620x |
odeparms <- backtransform_odeparms(odeparms_trans, |
202 | 2620x |
x$mkinmod, |
203 | 2620x |
transform_rates = fit_1$transform_rates, |
204 | 2620x |
transform_fractions = fit_1$transform_fractions) |
205 |
} else { |
|
206 | 325x |
odeparms <- odeparms_trans |
207 |
} |
|
208 | ||
209 | 2945x |
odeini <- degparms_all[ds_i, odeini_names] |
210 | 2945x |
names(odeini) <- gsub("_0", "", odeini_names) |
211 | ||
212 | 2945x |
out <- mkinpredict(x$mkinmod, odeparms, odeini, |
213 | 2945x |
outtimes, solution_type = solution_type, |
214 | 2945x |
atol = fit_1$atol, rtol = fit_1$rtol) |
215 |
}) |
|
216 | 283x |
names(pred_list) <- ds_names[i] |
217 | 283x |
pred_ds <- vctrs::vec_rbind(!!!pred_list, .names_to = "ds") |
218 | ||
219 | 283x |
if (pop_curves) { |
220 | 283x |
pred_list_pop <- lapply(1:ncol(degparms_pop), function(cov_i) { |
221 | 283x |
degparms_all_pop_i <- c(degparms_pop[, cov_i], degparms_fixed) |
222 | 283x |
odeparms_pop_trans_i <- degparms_all_pop_i[odeparms_names] |
223 | 283x |
names(odeparms_pop_trans_i) <- odeparms_names # needed if only one odeparm |
224 | 283x |
if (backtransform) { |
225 | 218x |
odeparms_pop_i <- backtransform_odeparms(odeparms_pop_trans_i, |
226 | 218x |
x$mkinmod, |
227 | 218x |
transform_rates = fit_1$transform_rates, |
228 | 218x |
transform_fractions = fit_1$transform_fractions) |
229 |
} else { |
|
230 | 65x |
odeparms_pop_i <- odeparms_pop_trans_i |
231 |
} |
|
232 | ||
233 | 283x |
odeini <- degparms_all_pop_i[odeini_names] |
234 | 283x |
names(odeini) <- gsub("_0", "", odeini_names) |
235 | ||
236 | 283x |
out <- mkinpredict(x$mkinmod, odeparms_pop_i, odeini, |
237 | 283x |
outtimes, solution_type = solution_type, |
238 | 283x |
atol = fit_1$atol, rtol = fit_1$rtol) |
239 |
}) |
|
240 | 283x |
names(pred_list_pop) <- colnames(degparms_pop) |
241 | ||
242 |
} else { |
|
243 | ! |
pred_list_pop <- NULL |
244 |
} |
|
245 | ||
246 |
# Start of graphical section |
|
247 | 283x |
oldpar <- par(no.readonly = TRUE) |
248 | 283x |
on.exit(par(oldpar, no.readonly = TRUE)) |
249 | ||
250 | 283x |
n_plot_rows = length(obs_vars) |
251 | 283x |
n_plots = n_plot_rows * 2 |
252 | ||
253 |
# Set relative plot heights, so the first plot row is the norm |
|
254 | 283x |
rel.heights <- if (n_plot_rows > 1) { |
255 | 218x |
c(rel.height.legend, c(rep(1, n_plot_rows - 1), rel.height.bottom)) |
256 |
} else { |
|
257 | 65x |
c(rel.height.legend, 1) |
258 |
} |
|
259 | ||
260 | 283x |
layout_matrix = matrix(c(1, 1, 2:(n_plots + 1)), |
261 | 283x |
n_plot_rows + 1, 2, byrow = TRUE) |
262 | 283x |
layout(layout_matrix, heights = rel.heights) |
263 | ||
264 | 283x |
par(mar = c(0.1, 2.1, 0.1, 2.1)) |
265 | ||
266 |
# Empty plot with legend |
|
267 | ! |
if (!is.null(pred_over)) lty_over <- seq(2, length.out = length(pred_over)) |
268 | 283x |
else lty_over <- NULL |
269 | 283x |
if (pop_curves) { |
270 | 283x |
if (is.null(covariates)) { |
271 | 283x |
lty_pop <- 1 |
272 | 283x |
names(lty_pop) <- "Population" |
273 |
} else { |
|
274 | ! |
lty_pop <- 1:nrow(covariates) |
275 | ! |
names(lty_pop) <- rownames(covariates) |
276 |
} |
|
277 |
} else { |
|
278 | ! |
lty_pop <- NULL |
279 |
} |
|
280 | 283x |
n_pop_over <- length(lty_pop) + length(lty_over) |
281 | ||
282 | 283x |
plot(0, type = "n", axes = FALSE, ann = FALSE) |
283 | 283x |
legend("center", bty = "n", ncol = ncol.legend, |
284 | 283x |
legend = c(names(lty_pop), names(pred_over), ds_names[i]), |
285 | 283x |
lty = c(lty_pop, lty_over, lty_ds), |
286 | 283x |
lwd = c(rep(2, n_pop_over), rep(1, length(i))), |
287 | 283x |
col = c(rep(1, n_pop_over), col_ds), |
288 | 283x |
pch = c(rep(NA, n_pop_over), pch_ds)) |
289 | ||
290 | 283x |
resplot <- match.arg(resplot) |
291 | ||
292 |
# Loop plot rows |
|
293 | 283x |
for (plot_row in 1:n_plot_rows) { |
294 | ||
295 | 501x |
obs_var <- obs_vars[plot_row] |
296 | 501x |
observed_row <- subset(observed, name == obs_var) |
297 | ||
298 |
# Set ylim to sensible default, or use ymax |
|
299 | 501x |
if (identical(ymax, "auto")) { |
300 | 501x |
ylim_row = c(0, |
301 | 501x |
max(c(observed_row$value, pred_ds[[obs_var]]), na.rm = TRUE)) |
302 |
} else { |
|
303 | ! |
ylim_row = c(0, ymax[plot_row]) |
304 |
} |
|
305 | ||
306 |
# Margins for bottom row of plots when we have more than one row |
|
307 |
# This is the only row that needs to show the x axis legend |
|
308 | 501x |
if (plot_row == n_plot_rows) { |
309 | 283x |
par(mar = c(5.1, 4.1, 1.1, 2.1)) |
310 |
} else { |
|
311 | 218x |
par(mar = c(3.0, 4.1, 1.1, 2.1)) |
312 |
} |
|
313 | ||
314 | 501x |
plot(0, type = "n", |
315 | 501x |
xlim = xlim, ylim = ylim_row, |
316 | 501x |
xlab = xlab, ylab = paste("Residues", obs_var), frame = frame) |
317 | ||
318 | 501x |
if (!is.null(pred_over)) { |
319 | ! |
for (i_over in seq_along(pred_over)) { |
320 | ! |
pred_frame <- as.data.frame(pred_over[[i_over]]) |
321 | ! |
lines(pred_frame$time, pred_frame[[obs_var]], |
322 | ! |
lwd = 2, lty = lty_over[i_over]) |
323 |
} |
|
324 |
} |
|
325 | ||
326 | 501x |
for (ds_i in seq_along(i)) { |
327 | 4915x |
points(subset(observed_row, ds == ds_names[ds_i], c("time", "value")), |
328 | 4915x |
col = col_ds[ds_i], pch = pch_ds[ds_i]) |
329 | 4915x |
lines(subset(pred_ds, ds == ds_names[ds_i], c("time", obs_var)), |
330 | 4915x |
col = col_ds[ds_i], lty = lty_ds[ds_i]) |
331 |
} |
|
332 | ||
333 | 501x |
if (pop_curves) { |
334 | 501x |
for (cov_i in seq_along(pred_list_pop)) { |
335 | 501x |
cov_name <- names(pred_list_pop)[cov_i] |
336 | 501x |
lines( |
337 | 501x |
pred_list_pop[[cov_i]][, "time"], |
338 | 501x |
pred_list_pop[[cov_i]][, obs_var], |
339 | 501x |
type = "l", lwd = 2, lty = lty_pop[cov_i]) |
340 |
} |
|
341 |
} |
|
342 | ||
343 | 501x |
if (identical(maxabs, "auto")) { |
344 | 283x |
maxabs = max(abs(observed_row$residual), na.rm = TRUE) |
345 |
} |
|
346 | ||
347 | 501x |
if (identical(resplot, "time")) { |
348 | ! |
plot(0, type = "n", xlim = xlim, xlab = "Time", |
349 | ! |
ylim = c(-1.2 * maxabs, 1.2 * maxabs), |
350 | ! |
ylab = if (standardized) "Standardized residual" else "Residual", |
351 | ! |
frame = frame) |
352 | ||
353 | ! |
abline(h = 0, lty = 2) |
354 | ||
355 | ! |
for (ds_i in seq_along(i)) { |
356 | ! |
points(subset(observed_row, ds == ds_names[ds_i], c("time", "residual")), |
357 | ! |
col = col_ds[ds_i], pch = pch_ds[ds_i]) |
358 |
} |
|
359 |
} |
|
360 | ||
361 | 501x |
if (identical(resplot, "predicted")) { |
362 | 501x |
plot(0, type = "n", |
363 | 501x |
xlim = c(0, max(pred_ds[[obs_var]])), |
364 | 501x |
xlab = "Predicted", |
365 | 501x |
ylim = c(-1.2 * maxabs, 1.2 * maxabs), |
366 | 501x |
ylab = if (standardized) "Standardized residual" else "Residual", |
367 | 501x |
frame = frame) |
368 | ||
369 | 501x |
abline(h = 0, lty = 2) |
370 | ||
371 | 501x |
for (ds_i in seq_along(i)) { |
372 | 4915x |
observed_row_ds <- merge( |
373 | 4915x |
subset(observed_row, ds == ds_names[ds_i], c("time", "residual")), |
374 | 4915x |
subset(pred_ds, ds == ds_names[ds_i], c("time", obs_var))) |
375 | 4915x |
points(observed_row_ds[c(3, 2)], |
376 | 4915x |
col = col_ds[ds_i], pch = pch_ds[ds_i]) |
377 |
} |
|
378 |
} |
|
379 |
} |
|
380 |
} |
1 |
#' Summary method for class "mkinfit" |
|
2 |
#' |
|
3 |
#' Lists model equations, initial parameter values, optimised parameters with |
|
4 |
#' some uncertainty statistics, the chi2 error levels calculated according to |
|
5 |
#' FOCUS guidance (2006) as defined therein, formation fractions, DT50 values |
|
6 |
#' and optionally the data, consisting of observed, predicted and residual |
|
7 |
#' values. |
|
8 |
#' |
|
9 |
#' @param object an object of class [mkinfit]. |
|
10 |
#' @param x an object of class \code{summary.mkinfit}. |
|
11 |
#' @param data logical, indicating whether the data should be included in the |
|
12 |
#' summary. |
|
13 |
#' @param distimes logical, indicating whether DT50 and DT90 values should be |
|
14 |
#' included. |
|
15 |
#' @param alpha error level for confidence interval estimation from t |
|
16 |
#' distribution |
|
17 |
#' @param digits Number of digits to use for printing |
|
18 |
#' @param \dots optional arguments passed to methods like \code{print}. |
|
19 |
#' @importFrom stats qt pt cov2cor |
|
20 |
#' @return The summary function returns a list with components, among others |
|
21 |
#' \item{version, Rversion}{The mkin and R versions used} |
|
22 |
#' \item{date.fit, date.summary}{The dates where the fit and the summary were |
|
23 |
#' produced} |
|
24 |
#' \item{diffs}{The differential equations used in the model} |
|
25 |
#' \item{use_of_ff}{Was maximum or minimum use made of formation fractions} |
|
26 |
#' \item{bpar}{Optimised and backtransformed |
|
27 |
#' parameters} |
|
28 |
#' \item{data}{The data (see Description above).} |
|
29 |
#' \item{start}{The starting values and bounds, if applicable, for optimised |
|
30 |
#' parameters.} |
|
31 |
#' \item{fixed}{The values of fixed parameters.} |
|
32 |
#' \item{errmin }{The chi2 error levels for |
|
33 |
#' each observed variable.} |
|
34 |
#' \item{bparms.ode}{All backtransformed ODE |
|
35 |
#' parameters, for use as starting parameters for related models.} |
|
36 |
#' \item{errparms}{Error model parameters.} |
|
37 |
#' \item{ff}{The estimated formation fractions derived from the fitted |
|
38 |
#' model.} |
|
39 |
#' \item{distimes}{The DT50 and DT90 values for each observed variable.} |
|
40 |
#' \item{SFORB}{If applicable, eigenvalues and fractional eigenvector component |
|
41 |
#' g of SFORB systems in the model.} |
|
42 |
#' The print method is called for its side effect, i.e. printing the summary. |
|
43 |
#' @author Johannes Ranke |
|
44 |
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
45 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
46 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
47 |
#' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
48 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
49 |
#' @examples |
|
50 |
#' |
|
51 |
#' summary(mkinfit("SFO", FOCUS_2006_A, quiet = TRUE)) |
|
52 |
#' |
|
53 |
#' @export |
|
54 |
summary.mkinfit <- function(object, data = TRUE, distimes = TRUE, alpha = 0.05, ...) { |
|
55 | 52158x |
param <- object$par |
56 | 52158x |
pnames <- names(param) |
57 | 52158x |
bpnames <- names(object$bparms.optim) |
58 | 52158x |
epnames <- names(object$errparms) |
59 | 52158x |
p <- length(param) |
60 | 52158x |
mod_vars <- names(object$mkinmod$diffs) |
61 | 52158x |
covar <- try(solve(object$hessian), silent = TRUE) |
62 | 52158x |
covar_notrans <- try(solve(object$hessian_notrans), silent = TRUE) |
63 | 52158x |
rdf <- object$df.residual |
64 | ||
65 | 52158x |
if (!is.numeric(covar) | is.na(covar[1])) { |
66 | ! |
covar <- NULL |
67 | ! |
se <- lci <- uci <- rep(NA, p) |
68 |
} else { |
|
69 | 52158x |
rownames(covar) <- colnames(covar) <- pnames |
70 | 52158x |
se <- sqrt(diag(covar)) |
71 | 52158x |
lci <- param + qt(alpha/2, rdf) * se |
72 | 52158x |
uci <- param + qt(1-alpha/2, rdf) * se |
73 |
} |
|
74 | ||
75 | 52158x |
beparms.optim <- c(object$bparms.optim, object$par[epnames]) |
76 | 52158x |
if (!is.numeric(covar_notrans) | is.na(covar_notrans[1])) { |
77 | 88x |
covar_notrans <- NULL |
78 | 88x |
se_notrans <- tval <- pval <- rep(NA, p) |
79 |
} else { |
|
80 | 52070x |
rownames(covar_notrans) <- colnames(covar_notrans) <- c(bpnames, epnames) |
81 | 52070x |
se_notrans <- sqrt(diag(covar_notrans)) |
82 | 52070x |
tval <- beparms.optim / se_notrans |
83 | 52070x |
pval <- pt(abs(tval), rdf, lower.tail = FALSE) |
84 |
} |
|
85 | ||
86 | 52158x |
names(se) <- pnames |
87 | ||
88 | 52158x |
param <- cbind(param, se, lci, uci) |
89 | 52158x |
dimnames(param) <- list(pnames, c("Estimate", "Std. Error", "Lower", "Upper")) |
90 | ||
91 | 52158x |
bparam <- cbind(Estimate = beparms.optim, se_notrans, |
92 | 52158x |
"t value" = tval, "Pr(>t)" = pval, Lower = NA, Upper = NA) |
93 | ||
94 |
# Transform boundaries of CI for one parameter at a time, |
|
95 |
# with the exception of sets of formation fractions (single fractions are OK). |
|
96 | 52158x |
f_names_skip <- character(0) |
97 | 52158x |
for (box in mod_vars) { # Figure out sets of fractions to skip |
98 | 70671x |
f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE) |
99 | 70671x |
n_paths <- length(f_names) |
100 | 1135x |
if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names) |
101 |
} |
|
102 | ||
103 | 52158x |
for (pname in pnames) { |
104 | 293621x |
if (!pname %in% f_names_skip) { |
105 | 290217x |
par.lower <- param[pname, "Lower"] |
106 | 290217x |
par.upper <- param[pname, "Upper"] |
107 | 290217x |
names(par.lower) <- names(par.upper) <- pname |
108 | 290217x |
bpl <- backtransform_odeparms(par.lower, object$mkinmod, |
109 | 290217x |
object$transform_rates, |
110 | 290217x |
object$transform_fractions) |
111 | 290217x |
bpu <- backtransform_odeparms(par.upper, object$mkinmod, |
112 | 290217x |
object$transform_rates, |
113 | 290217x |
object$transform_fractions) |
114 | 290217x |
bparam[names(bpl), "Lower"] <- bpl |
115 | 290217x |
bparam[names(bpu), "Upper"] <- bpu |
116 |
} |
|
117 |
} |
|
118 | 52158x |
bparam[epnames, c("Lower", "Upper")] <- param[epnames, c("Lower", "Upper")] |
119 | ||
120 | 52158x |
ans <- list( |
121 | 52158x |
version = as.character(utils::packageVersion("mkin")), |
122 | 52158x |
Rversion = paste(R.version$major, R.version$minor, sep="."), |
123 | 52158x |
date.fit = object$date, |
124 | 52158x |
date.summary = date(), |
125 | 52158x |
solution_type = object$solution_type, |
126 | 52158x |
warnings = object$summary_warnings, |
127 | 52158x |
use_of_ff = object$mkinmod$use_of_ff, |
128 | 52158x |
error_model_algorithm = object$error_model_algorithm, |
129 | 52158x |
df = c(p, rdf), |
130 | 52158x |
covar = covar, |
131 | 52158x |
covar_notrans = covar_notrans, |
132 | 52158x |
err_mod = object$err_mod, |
133 | 52158x |
niter = object$iterations, |
134 | 52158x |
calls = object$calls, |
135 | 52158x |
time = object$time, |
136 | 52158x |
par = param, |
137 | 52158x |
bpar = bparam) |
138 | ||
139 | 52158x |
if (!is.null(object$version)) { |
140 | 52158x |
ans$fit_version <- object$version |
141 | 52158x |
ans$fit_Rversion <- object$Rversion |
142 | 52158x |
if (ans$fit_version >= "0.9.49.6") { |
143 | 52156x |
ans$AIC = AIC(object) |
144 | 52156x |
ans$BIC = BIC(object) |
145 | 52156x |
ans$logLik = logLik(object) |
146 |
} |
|
147 |
} |
|
148 | ||
149 | 52158x |
ans$diffs <- object$mkinmod$diffs |
150 | 52158x |
if(data) ans$data <- object$data |
151 | 52158x |
ans$start <- object$start |
152 | 52158x |
ans$start_transformed <- object$start_transformed |
153 | ||
154 | 52158x |
ans$fixed <- object$fixed |
155 | ||
156 | 52158x |
ans$errmin <- mkinerrmin(object, alpha = 0.05) |
157 | ||
158 | 52158x |
if (object$calls > 0) { |
159 | 52158x |
if (!is.null(ans$covar)){ |
160 | 52158x |
Corr <- cov2cor(ans$covar) |
161 | 52158x |
rownames(Corr) <- colnames(Corr) <- rownames(ans$par) |
162 | 52158x |
ans$Corr <- Corr |
163 |
} else { |
|
164 | ! |
warning("Could not calculate correlation; no covariance matrix") |
165 |
} |
|
166 |
} |
|
167 | ||
168 | 52158x |
ans$bparms.ode <- object$bparms.ode |
169 | 52158x |
ans$shapiro.p <- object$shapiro.p |
170 | 52158x |
ep <- endpoints(object) |
171 | 52158x |
if (length(ep$ff) != 0) |
172 | 15612x |
ans$ff <- ep$ff |
173 | 52158x |
if (distimes) ans$distimes <- ep$distimes |
174 | 2442x |
if (length(ep$SFORB) != 0) ans$SFORB <- ep$SFORB |
175 | 43972x |
if (!is.null(object$d_3_message)) ans$d_3_message <- object$d_3_message |
176 | 52158x |
class(ans) <- "summary.mkinfit" |
177 | 52158x |
return(ans) |
178 |
} |
|
179 | ||
180 |
#' @rdname summary.mkinfit |
|
181 |
#' @export |
|
182 |
print.summary.mkinfit <- function(x, digits = max(3, getOption("digits") - 3), ...) { |
|
183 | 4x |
if (is.null(x$fit_version)) { |
184 | ! |
cat("mkin version: ", x$version, "\n") |
185 | ! |
cat("R version: ", x$Rversion, "\n") |
186 |
} else { |
|
187 | 4x |
cat("mkin version used for fitting: ", x$fit_version, "\n") |
188 | 4x |
cat("R version used for fitting: ", x$fit_Rversion, "\n") |
189 |
} |
|
190 | ||
191 | 4x |
cat("Date of fit: ", x$date.fit, "\n") |
192 | 4x |
cat("Date of summary:", x$date.summary, "\n") |
193 | ||
194 | 4x |
cat("\nEquations:\n") |
195 | 4x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]]) |
196 | 4x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
197 | 4x |
df <- x$df |
198 | 4x |
rdf <- df[2] |
199 | ||
200 | 4x |
cat("\nModel predictions using solution type", x$solution_type, "\n") |
201 | ||
202 | 4x |
cat("\nFitted using", x$calls, "model solutions performed in", x$time[["elapsed"]], "s\n") |
203 | ||
204 | 4x |
if (!is.null(x$err_mod)) { |
205 | 4x |
cat("\nError model: ") |
206 | 4x |
cat(switch(x$err_mod, |
207 | 4x |
const = "Constant variance", |
208 | 4x |
obs = "Variance unique to each observed variable", |
209 | 4x |
tc = "Two-component variance function"), "\n") |
210 | ||
211 | 4x |
cat("\nError model algorithm:", x$error_model_algorithm, "\n") |
212 | ! |
if (!is.null(x$d_3_message)) cat(x$d_3_message, "\n") |
213 |
} |
|
214 | ||
215 | 4x |
cat("\nStarting values for parameters to be optimised:\n") |
216 | 4x |
print(x$start) |
217 | ||
218 | 4x |
cat("\nStarting values for the transformed parameters actually optimised:\n") |
219 | 4x |
print(x$start_transformed) |
220 | ||
221 | 4x |
cat("\nFixed parameter values:\n") |
222 | 1x |
if(length(x$fixed$value) == 0) cat("None\n") |
223 | 3x |
else print(x$fixed) |
224 | ||
225 |
# We used to only have one warning - show this for summarising old objects |
|
226 | ! |
if (!is.null(x[["warning"]])) cat("\n\nWarning:", x$warning, "\n\n") |
227 | ||
228 | 4x |
if (length(x$warnings) > 0) { |
229 | ! |
cat("\n\nWarning(s):", "\n") |
230 | ! |
cat(x$warnings, sep = "\n") |
231 |
} |
|
232 | ||
233 | 4x |
if (!is.null(x$AIC)) { |
234 | 4x |
cat("\nResults:\n\n") |
235 | 4x |
print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik, |
236 | 4x |
row.names = " ")) |
237 |
} |
|
238 | ||
239 | 4x |
cat("\nOptimised, transformed parameters with symmetric confidence intervals:\n") |
240 | 4x |
print(signif(x$par, digits = digits)) |
241 | ||
242 | 4x |
if (x$calls > 0) { |
243 | 4x |
cat("\nParameter correlation:\n") |
244 | 4x |
if (!is.null(x$covar)){ |
245 | 4x |
print(x$Corr, digits = digits, ...) |
246 |
} else { |
|
247 | ! |
cat("No covariance matrix") |
248 |
} |
|
249 |
} |
|
250 | ||
251 | 4x |
cat("\nBacktransformed parameters:\n") |
252 | 4x |
cat("Confidence intervals for internally transformed parameters are asymmetric.\n") |
253 | 4x |
if ((x$version) < "0.9-36") { |
254 | ! |
cat("To get the usual (questionable) t-test, upgrade mkin and repeat the fit.\n") |
255 | ! |
print(signif(x$bpar, digits = digits)) |
256 |
} else { |
|
257 | 4x |
cat("t-test (unrealistically) based on the assumption of normal distribution\n") |
258 | 4x |
cat("for estimators of untransformed parameters.\n") |
259 | 4x |
print(signif(x$bpar[, c(1, 3, 4, 5, 6)], digits = digits)) |
260 |
} |
|
261 | ||
262 | 4x |
cat("\nFOCUS Chi2 error levels in percent:\n") |
263 | 4x |
x$errmin$err.min <- 100 * x$errmin$err.min |
264 | 4x |
print(x$errmin, digits=digits,...) |
265 | ||
266 | 4x |
printSFORB <- !is.null(x$SFORB) |
267 | 4x |
if(printSFORB){ |
268 | 1x |
cat("\nEstimated Eigenvalues and DFOP g parameter of SFORB model(s):\n") |
269 | 1x |
print(x$SFORB, digits=digits,...) |
270 |
} |
|
271 | ||
272 | 4x |
printff <- !is.null(x$ff) |
273 | 4x |
if(printff){ |
274 | 3x |
cat("\nResulting formation fractions:\n") |
275 | 3x |
print(data.frame(ff = x$ff), digits=digits,...) |
276 |
} |
|
277 | ||
278 | 4x |
printdistimes <- !is.null(x$distimes) |
279 | 4x |
if(printdistimes){ |
280 | 4x |
cat("\nEstimated disappearance times:\n") |
281 | 4x |
print(x$distimes, digits=digits,...) |
282 |
} |
|
283 | ||
284 | 4x |
printdata <- !is.null(x$data) |
285 | 4x |
if (printdata){ |
286 | 4x |
cat("\nData:\n") |
287 | 4x |
print(format(x$data, digits = digits, ...), row.names = FALSE) |
288 |
} |
|
289 | ||
290 | 4x |
invisible(x) |
291 |
} |
1 |
utils::globalVariables(c("name", "time", "value")) |
|
2 | ||
3 |
#' Fit a kinetic model to data with one or more state variables |
|
4 |
#' |
|
5 |
#' This function maximises the likelihood of the observed data using the Port |
|
6 |
#' algorithm [stats::nlminb()], and the specified initial or fixed |
|
7 |
#' parameters and starting values. In each step of the optimisation, the |
|
8 |
#' kinetic model is solved using the function [mkinpredict()], except |
|
9 |
#' if an analytical solution is implemented, in which case the model is solved |
|
10 |
#' using the degradation function in the [mkinmod] object. The |
|
11 |
#' parameters of the selected error model are fitted simultaneously with the |
|
12 |
#' degradation model parameters, as both of them are arguments of the |
|
13 |
#' likelihood function. |
|
14 |
#' |
|
15 |
#' Per default, parameters in the kinetic models are internally transformed in |
|
16 |
#' order to better satisfy the assumption of a normal distribution of their |
|
17 |
#' estimators. |
|
18 |
#' |
|
19 |
#' @param mkinmod A list of class [mkinmod], containing the kinetic |
|
20 |
#' model to be fitted to the data, or one of the shorthand names ("SFO", |
|
21 |
#' "FOMC", "DFOP", "HS", "SFORB", "IORE"). If a shorthand name is given, a |
|
22 |
#' parent only degradation model is generated for the variable with the |
|
23 |
#' highest value in \code{observed}. |
|
24 |
#' @param observed A dataframe with the observed data. The first column called |
|
25 |
#' "name" must contain the name of the observed variable for each data point. |
|
26 |
#' The second column must contain the times of observation, named "time". |
|
27 |
#' The third column must be named "value" and contain the observed values. |
|
28 |
#' Zero values in the "value" column will be removed, with a warning, in |
|
29 |
#' order to avoid problems with fitting the two-component error model. This |
|
30 |
#' is not expected to be a problem, because in general, values of zero are |
|
31 |
#' not observed in degradation data, because there is a lower limit of |
|
32 |
#' detection. |
|
33 |
#' @param parms.ini A named vector of initial values for the parameters, |
|
34 |
#' including parameters to be optimised and potentially also fixed parameters |
|
35 |
#' as indicated by \code{fixed_parms}. If set to "auto", initial values for |
|
36 |
#' rate constants are set to default values. Using parameter names that are |
|
37 |
#' not in the model gives an error. |
|
38 |
#' |
|
39 |
#' It is possible to only specify a subset of the parameters that the model |
|
40 |
#' needs. You can use the parameter lists "bparms.ode" from a previously |
|
41 |
#' fitted model, which contains the differential equation parameters from |
|
42 |
#' this model. This works nicely if the models are nested. An example is |
|
43 |
#' given below. |
|
44 |
#' @param state.ini A named vector of initial values for the state variables of |
|
45 |
#' the model. In case the observed variables are represented by more than one |
|
46 |
#' model variable, the names will differ from the names of the observed |
|
47 |
#' variables (see \code{map} component of [mkinmod]). The default |
|
48 |
#' is to set the initial value of the first model variable to the mean of the |
|
49 |
#' time zero values for the variable with the maximum observed value, and all |
|
50 |
#' others to 0. If this variable has no time zero observations, its initial |
|
51 |
#' value is set to 100. |
|
52 |
#' @param err.ini A named vector of initial values for the error model |
|
53 |
#' parameters to be optimised. If set to "auto", initial values are set to |
|
54 |
#' default values. Otherwise, inital values for all error model parameters |
|
55 |
#' must be given. |
|
56 |
#' @param fixed_parms The names of parameters that should not be optimised but |
|
57 |
#' rather kept at the values specified in \code{parms.ini}. Alternatively, |
|
58 |
#' a named numeric vector of parameters to be fixed, regardless of the values |
|
59 |
#' in parms.ini. |
|
60 |
#' @param fixed_initials The names of model variables for which the initial |
|
61 |
#' state at time 0 should be excluded from the optimisation. Defaults to all |
|
62 |
#' state variables except for the first one. |
|
63 |
#' @param from_max_mean If this is set to TRUE, and the model has only one |
|
64 |
#' observed variable, then data before the time of the maximum observed value |
|
65 |
#' (after averaging for each sampling time) are discarded, and this time is |
|
66 |
#' subtracted from all remaining time values, so the time of the maximum |
|
67 |
#' observed mean value is the new time zero. |
|
68 |
#' @param solution_type If set to "eigen", the solution of the system of |
|
69 |
#' differential equations is based on the spectral decomposition of the |
|
70 |
#' coefficient matrix in cases that this is possible. If set to "deSolve", a |
|
71 |
#' numerical [ode solver from package deSolve][deSolve::ode()] is used. If |
|
72 |
#' set to "analytical", an analytical solution of the model is used. This is |
|
73 |
#' only implemented for relatively simple degradation models. The default is |
|
74 |
#' "auto", which uses "analytical" if possible, otherwise "deSolve" if a |
|
75 |
#' compiler is present, and "eigen" if no compiler is present and the model |
|
76 |
#' can be expressed using eigenvalues and eigenvectors. |
|
77 |
#' @param method.ode The solution method passed via [mkinpredict()] |
|
78 |
#' to [deSolve::ode()] in case the solution type is "deSolve". The default |
|
79 |
#' "lsoda" is performant, but sometimes fails to converge. |
|
80 |
#' @param use_compiled If set to \code{FALSE}, no compiled version of the |
|
81 |
#' [mkinmod] model is used in the calls to [mkinpredict()] even if a compiled |
|
82 |
#' version is present. |
|
83 |
#' @param control A list of control arguments passed to [stats::nlminb()]. |
|
84 |
#' @param transform_rates Boolean specifying if kinetic rate constants should |
|
85 |
#' be transformed in the model specification used in the fitting for better |
|
86 |
#' compliance with the assumption of normal distribution of the estimator. If |
|
87 |
#' TRUE, also alpha and beta parameters of the FOMC model are |
|
88 |
#' log-transformed, as well as k1 and k2 rate constants for the DFOP and HS |
|
89 |
#' models and the break point tb of the HS model. If FALSE, zero is used as |
|
90 |
#' a lower bound for the rates in the optimisation. |
|
91 |
#' @param transform_fractions Boolean specifying if formation fractions |
|
92 |
#' should be transformed in the model specification used in the fitting for |
|
93 |
#' better compliance with the assumption of normal distribution of the |
|
94 |
#' estimator. The default (TRUE) is to do transformations. If TRUE, |
|
95 |
#' the g parameter of the DFOP model is also transformed. Transformations |
|
96 |
#' are described in [transform_odeparms]. |
|
97 |
#' @param quiet Suppress printing out the current value of the negative |
|
98 |
#' log-likelihood after each improvement? |
|
99 |
#' @param atol Absolute error tolerance, passed to [deSolve::ode()]. Default |
|
100 |
#' is 1e-8, which is lower than the default in the [deSolve::lsoda()] |
|
101 |
#' function which is used per default. |
|
102 |
#' @param rtol Absolute error tolerance, passed to [deSolve::ode()]. Default |
|
103 |
#' is 1e-10, much lower than in [deSolve::lsoda()]. |
|
104 |
#' @param error_model If the error model is "const", a constant standard |
|
105 |
#' deviation is assumed. |
|
106 |
#' |
|
107 |
#' If the error model is "obs", each observed variable is assumed to have its |
|
108 |
#' own variance. |
|
109 |
#' |
|
110 |
#' If the error model is "tc" (two-component error model), a two component |
|
111 |
#' error model similar to the one described by Rocke and Lorenzato (1995) is |
|
112 |
#' used for setting up the likelihood function. Note that this model |
|
113 |
#' deviates from the model by Rocke and Lorenzato, as their model implies |
|
114 |
#' that the errors follow a lognormal distribution for large values, not a |
|
115 |
#' normal distribution as assumed by this method. |
|
116 |
#' @param error_model_algorithm If "auto", the selected algorithm depends on |
|
117 |
#' the error model. If the error model is "const", unweighted nonlinear |
|
118 |
#' least squares fitting ("OLS") is selected. If the error model is "obs", or |
|
119 |
#' "tc", the "d_3" algorithm is selected. |
|
120 |
#' |
|
121 |
#' The algorithm "d_3" will directly minimize the negative log-likelihood |
|
122 |
#' and independently also use the three step algorithm described below. |
|
123 |
#' The fit with the higher likelihood is returned. |
|
124 |
#' |
|
125 |
#' The algorithm "direct" will directly minimize the negative log-likelihood. |
|
126 |
#' |
|
127 |
#' The algorithm "twostep" will minimize the negative log-likelihood after an |
|
128 |
#' initial unweighted least squares optimisation step. |
|
129 |
#' |
|
130 |
#' The algorithm "threestep" starts with unweighted least squares, then |
|
131 |
#' optimizes only the error model using the degradation model parameters |
|
132 |
#' found, and then minimizes the negative log-likelihood with free |
|
133 |
#' degradation and error model parameters. |
|
134 |
#' |
|
135 |
#' The algorithm "fourstep" starts with unweighted least squares, then |
|
136 |
#' optimizes only the error model using the degradation model parameters |
|
137 |
#' found, then optimizes the degradation model again with fixed error model |
|
138 |
#' parameters, and finally minimizes the negative log-likelihood with free |
|
139 |
#' degradation and error model parameters. |
|
140 |
#' |
|
141 |
#' The algorithm "IRLS" (Iteratively Reweighted Least Squares) starts with |
|
142 |
#' unweighted least squares, and then iterates optimization of the error |
|
143 |
#' model parameters and subsequent optimization of the degradation model |
|
144 |
#' using those error model parameters, until the error model parameters |
|
145 |
#' converge. |
|
146 |
#' @param reweight.tol Tolerance for the convergence criterion calculated from |
|
147 |
#' the error model parameters in IRLS fits. |
|
148 |
#' @param reweight.max.iter Maximum number of iterations in IRLS fits. |
|
149 |
#' @param trace_parms Should a trace of the parameter values be listed? |
|
150 |
#' @param test_residuals Should the residuals be tested for normal distribution? |
|
151 |
#' @param \dots Further arguments that will be passed on to |
|
152 |
#' [deSolve::ode()]. |
|
153 |
#' @importFrom stats nlminb aggregate dist shapiro.test |
|
154 |
#' @return A list with "mkinfit" in the class attribute. |
|
155 |
#' @note When using the "IORE" submodel for metabolites, fitting with |
|
156 |
#' "transform_rates = TRUE" (the default) often leads to failures of the |
|
157 |
#' numerical ODE solver. In this situation it may help to switch off the |
|
158 |
#' internal rate transformation. |
|
159 |
#' @author Johannes Ranke |
|
160 |
#' @seealso [summary.mkinfit], [plot.mkinfit], [parms] and [lrtest]. |
|
161 |
#' |
|
162 |
#' Comparisons of models fitted to the same data can be made using |
|
163 |
#' \code{\link{AIC}} by virtue of the method \code{\link{logLik.mkinfit}}. |
|
164 |
#' |
|
165 |
#' Fitting of several models to several datasets in a single call to |
|
166 |
#' \code{\link{mmkin}}. |
|
167 |
#' @references Rocke DM and Lorenzato S (1995) A two-component model |
|
168 |
#' for measurement error in analytical chemistry. *Technometrics* 37(2), 176-184. |
|
169 |
#' |
|
170 |
#' Ranke J and Meinecke S (2019) Error Models for the Kinetic Evaluation of Chemical |
|
171 |
#' Degradation Data. *Environments* 6(12) 124 |
|
172 |
#' \doi{10.3390/environments6120124}. |
|
173 |
#' @examples |
|
174 |
#' |
|
175 |
#' # Use shorthand notation for parent only degradation |
|
176 |
#' fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE) |
|
177 |
#' summary(fit) |
|
178 |
#' |
|
179 |
#' # One parent compound, one metabolite, both single first order. |
|
180 |
#' # We remove zero values from FOCUS dataset D in order to avoid warnings |
|
181 |
#' FOCUS_D <- subset(FOCUS_2006_D, value != 0) |
|
182 |
#' # Use mkinsub for convenience in model formulation. Pathway to sink included per default. |
|
183 |
#' SFO_SFO <- mkinmod( |
|
184 |
#' parent = mkinsub("SFO", "m1"), |
|
185 |
#' m1 = mkinsub("SFO")) |
|
186 |
#' |
|
187 |
#' # Fit the model quietly to the FOCUS example dataset D using defaults |
|
188 |
#' fit <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE) |
|
189 |
#' plot_sep(fit) |
|
190 |
#' # As lower parent values appear to have lower variance, we try an alternative error model |
|
191 |
#' fit.tc <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc") |
|
192 |
#' # This avoids the warning, and the likelihood ratio test confirms it is preferable |
|
193 |
#' lrtest(fit.tc, fit) |
|
194 |
#' # We can also allow for different variances of parent and metabolite as error model |
|
195 |
#' fit.obs <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "obs") |
|
196 |
#' # The two-component error model has significantly higher likelihood |
|
197 |
#' lrtest(fit.obs, fit.tc) |
|
198 |
#' parms(fit.tc) |
|
199 |
#' endpoints(fit.tc) |
|
200 |
#' |
|
201 |
#' # We can show a quick (only one replication) benchmark for this case, as we |
|
202 |
#' # have several alternative solution methods for the model. We skip |
|
203 |
#' # uncompiled deSolve, as it is so slow. More benchmarks are found in the |
|
204 |
#' # benchmark vignette |
|
205 |
#' \dontrun{ |
|
206 |
#' if(require(rbenchmark)) { |
|
207 |
#' benchmark(replications = 1, order = "relative", columns = c("test", "relative", "elapsed"), |
|
208 |
#' deSolve_compiled = mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc", |
|
209 |
#' solution_type = "deSolve", use_compiled = TRUE), |
|
210 |
#' eigen = mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc", |
|
211 |
#' solution_type = "eigen"), |
|
212 |
#' analytical = mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc", |
|
213 |
#' solution_type = "analytical")) |
|
214 |
#' } |
|
215 |
#' } |
|
216 |
#' |
|
217 |
#' # Use stepwise fitting, using optimised parameters from parent only fit, FOMC-SFO |
|
218 |
#' \dontrun{ |
|
219 |
#' FOMC_SFO <- mkinmod( |
|
220 |
#' parent = mkinsub("FOMC", "m1"), |
|
221 |
#' m1 = mkinsub("SFO")) |
|
222 |
#' fit.FOMC_SFO <- mkinfit(FOMC_SFO, FOCUS_D, quiet = TRUE) |
|
223 |
#' # Again, we get a warning and try a more sophisticated error model |
|
224 |
#' fit.FOMC_SFO.tc <- mkinfit(FOMC_SFO, FOCUS_D, quiet = TRUE, error_model = "tc") |
|
225 |
#' # This model has a higher likelihood, but not significantly so |
|
226 |
#' lrtest(fit.tc, fit.FOMC_SFO.tc) |
|
227 |
#' # Also, the missing standard error for log_beta and the t-tests for alpha |
|
228 |
#' # and beta indicate overparameterisation |
|
229 |
#' summary(fit.FOMC_SFO.tc, data = FALSE) |
|
230 |
#' |
|
231 |
#' # We can easily use starting parameters from the parent only fit (only for illustration) |
|
232 |
#' fit.FOMC = mkinfit("FOMC", FOCUS_2006_D, quiet = TRUE, error_model = "tc") |
|
233 |
#' fit.FOMC_SFO <- mkinfit(FOMC_SFO, FOCUS_D, quiet = TRUE, |
|
234 |
#' parms.ini = fit.FOMC$bparms.ode, error_model = "tc") |
|
235 |
#' } |
|
236 |
#' @export |
|
237 |
mkinfit <- function(mkinmod, observed, |
|
238 |
parms.ini = "auto", |
|
239 |
state.ini = "auto", |
|
240 |
err.ini = "auto", |
|
241 |
fixed_parms = NULL, |
|
242 |
fixed_initials = names(mkinmod$diffs)[-1], |
|
243 |
from_max_mean = FALSE, |
|
244 |
solution_type = c("auto", "analytical", "eigen", "deSolve"), |
|
245 |
method.ode = "lsoda", |
|
246 |
use_compiled = "auto", |
|
247 |
control = list(eval.max = 300, iter.max = 200), |
|
248 |
transform_rates = TRUE, |
|
249 |
transform_fractions = TRUE, |
|
250 |
quiet = FALSE, |
|
251 |
atol = 1e-8, rtol = 1e-10, |
|
252 |
error_model = c("const", "obs", "tc"), |
|
253 |
error_model_algorithm = c("auto", "d_3", "direct", "twostep", "threestep", "fourstep", "IRLS", "OLS"), |
|
254 |
reweight.tol = 1e-8, reweight.max.iter = 10, |
|
255 |
trace_parms = FALSE, |
|
256 |
test_residuals = FALSE, |
|
257 |
...) |
|
258 |
{ |
|
259 | 9202x |
call <- match.call() |
260 | ||
261 | 9202x |
summary_warnings <- character() |
262 | ||
263 |
# Derive the name used for the model |
|
264 | 9202x |
if (is.character(mkinmod)) { |
265 | 4009x |
mkinmod_name <- mkinmod |
266 |
} else { |
|
267 | 5193x |
if (is.null(mkinmod$name)) { |
268 | 5071x |
mkinmod_name <- deparse(substitute(mkinmod)) |
269 |
} else { |
|
270 | 18x |
mkinmod_name <- mkinmod$name |
271 |
} |
|
272 |
} |
|
273 | ||
274 |
# Check mkinmod and generate a model for the variable whith the highest value |
|
275 |
# if a suitable string is given |
|
276 | 9098x |
parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE", "logistic") |
277 | 9098x |
if (!inherits(mkinmod, "mkinmod")) { |
278 | 4009x |
presumed_parent_name = observed[which.max(observed$value), "name"] |
279 | 4009x |
if (mkinmod[[1]] %in% parent_models_available) { |
280 | 3905x |
speclist <- list(list(type = mkinmod, sink = TRUE)) |
281 | 3905x |
names(speclist) <- presumed_parent_name |
282 | 3905x |
mkinmod <- mkinmod(speclist = speclist, use_of_ff = "max") |
283 |
} else { |
|
284 | 104x |
stop("Argument mkinmod must be of class mkinmod or a string containing one of\n ", |
285 | 104x |
paste(parent_models_available, collapse = ", ")) |
286 |
} |
|
287 |
} |
|
288 | ||
289 |
# Get the names of the state variables in the model |
|
290 | 8994x |
mod_vars <- names(mkinmod$diffs) |
291 | ||
292 |
# Get the names of observed variables |
|
293 | 8994x |
obs_vars <- names(mkinmod$spec) |
294 | ||
295 |
# Subset observed data with names of observed data in the model and remove NA values |
|
296 | 8994x |
observed <- subset(observed, name %in% obs_vars) |
297 | 8994x |
observed <- subset(observed, !is.na(value)) |
298 | ||
299 |
# Also remove zero values to avoid instabilities (e.g. of the 'tc' error model) |
|
300 | 8994x |
if (any(observed$value == 0)) { |
301 | 529x |
zero_warning <- "Observations with value of zero were removed from the data" |
302 | 529x |
summary_warnings <- c(summary_warnings, Z = zero_warning) |
303 | 529x |
warning(zero_warning) |
304 | 529x |
observed <- subset(observed, value != 0) |
305 |
} |
|
306 | ||
307 |
# Sort observed values for efficient analytical predictions |
|
308 | 8994x |
observed$name <- ordered(observed$name, levels = obs_vars) |
309 | 8994x |
observed <- observed[order(observed$name, observed$time), ] |
310 | ||
311 |
# Obtain data for decline from maximum mean value if requested |
|
312 | 8994x |
if (from_max_mean) { |
313 |
# This is only used for simple decline models |
|
314 | 459x |
if (length(obs_vars) > 1) |
315 | 153x |
stop("Decline from maximum is only implemented for models with a single observed variable") |
316 | 306x |
observed$name <- as.character(observed$name) |
317 | ||
318 | 306x |
means <- aggregate(value ~ time, data = observed, mean, na.rm=TRUE) |
319 | 306x |
t_of_max <- means[which.max(means$value), "time"] |
320 | 306x |
observed <- subset(observed, time >= t_of_max) |
321 | 306x |
observed$time <- observed$time - t_of_max |
322 |
} |
|
323 | ||
324 |
# Number observations used for fitting |
|
325 | 8841x |
n_observed <- nrow(observed) |
326 | ||
327 |
# Define starting values for parameters where not specified by the user |
|
328 | 8371x |
if (parms.ini[[1]] == "auto") parms.ini = vector() |
329 | ||
330 |
# Override parms.ini for parameters given as a numeric vector in |
|
331 |
# fixed_parms |
|
332 | 8841x |
if (is.numeric(fixed_parms)) { |
333 | 3x |
fixed_parm_names <- names(fixed_parms) |
334 | 3x |
parms.ini[fixed_parm_names] <- fixed_parms |
335 | 3x |
fixed_parms <- fixed_parm_names |
336 |
} |
|
337 | ||
338 |
# Warn for inital parameter specifications that are not in the model |
|
339 | 8841x |
wrongpar.names <- setdiff(names(parms.ini), mkinmod$parms) |
340 | 8841x |
if (length(wrongpar.names) > 0) { |
341 | 257x |
warning("Initial parameter(s) ", paste(wrongpar.names, collapse = ", "), |
342 | 257x |
" not used in the model") |
343 | 257x |
parms.ini <- parms.ini[setdiff(names(parms.ini), wrongpar.names)] |
344 |
} |
|
345 | ||
346 |
# Warn that the sum of formation fractions may exceed one if they are not |
|
347 |
# fitted in the transformed way |
|
348 | 8841x |
if (mkinmod$use_of_ff == "max" & transform_fractions == FALSE) { |
349 | 410x |
warning("The sum of formation fractions may exceed one if you do not use ", |
350 | 410x |
"transform_fractions = TRUE." ) |
351 | 410x |
for (box in mod_vars) { |
352 |
# Stop if formation fractions are not transformed and we have no sink |
|
353 | 716x |
if (mkinmod$spec[[box]]$sink == FALSE) { |
354 | 104x |
stop("If formation fractions are not transformed during the fitting, ", |
355 | 104x |
"it is not supported to turn off pathways to sink.\n ", |
356 | 104x |
"Consider turning on the transformation of formation fractions or ", |
357 | 104x |
"setting up a model with use_of_ff = 'min'.\n") |
358 |
} |
|
359 |
} |
|
360 |
} |
|
361 | ||
362 |
# Do not allow fixing formation fractions if we are using the ilr transformation, |
|
363 |
# this is not supported |
|
364 | 8737x |
if (transform_fractions == TRUE && length(fixed_parms) > 0) { |
365 | 107x |
if (any(grepl("^f_", fixed_parms))) { |
366 | 104x |
stop("Fixing formation fractions is not supported when using the ilr ", |
367 | 104x |
"transformation.") |
368 |
} |
|
369 |
} |
|
370 | ||
371 |
# Set initial parameter values, including a small increment (salt) |
|
372 |
# to avoid linear dependencies (singular matrix) in Eigenvalue based solutions |
|
373 | 8633x |
k_salt = 0 |
374 | 8633x |
defaultpar.names <- setdiff(mkinmod$parms, names(parms.ini)) |
375 | 8633x |
for (parmname in defaultpar.names) { |
376 |
# Default values for rate constants, depending on the parameterisation |
|
377 | 20999x |
if (grepl("^k", parmname)) { |
378 | 15908x |
parms.ini[parmname] = 0.1 + k_salt |
379 | 15908x |
k_salt = k_salt + 1e-4 |
380 |
} |
|
381 |
# Default values for rate constants for reversible binding |
|
382 | 26x |
if (grepl("free_bound$", parmname)) parms.ini[parmname] = 0.1 |
383 | 26x |
if (grepl("bound_free$", parmname)) parms.ini[parmname] = 0.02 |
384 |
# Default values for IORE exponents |
|
385 | 176x |
if (grepl("^N", parmname)) parms.ini[parmname] = 1.1 |
386 |
# Default values for the FOMC, DFOP and HS models |
|
387 | 238x |
if (parmname == "alpha") parms.ini[parmname] = 1 |
388 | 238x |
if (parmname == "beta") parms.ini[parmname] = 10 |
389 | 1014x |
if (parmname == "k1") parms.ini[parmname] = 0.1 |
390 | 1013x |
if (parmname == "k2") parms.ini[parmname] = 0.01 |
391 | 30x |
if (parmname == "tb") parms.ini[parmname] = 5 |
392 | 984x |
if (parmname == "g") parms.ini[parmname] = 0.5 |
393 | 153x |
if (parmname == "kmax") parms.ini[parmname] = 0.1 |
394 | 153x |
if (parmname == "k0") parms.ini[parmname] = 0.0001 |
395 | 153x |
if (parmname == "r") parms.ini[parmname] = 0.2 |
396 |
} |
|
397 |
# Default values for formation fractions in case they are present |
|
398 | 8633x |
for (obs_var in obs_vars) { |
399 | 13865x |
origin <- mkinmod$map[[obs_var]][[1]] |
400 | 13865x |
f_names <- mkinmod$parms[grep(paste0("^f_", origin), mkinmod$parms)] |
401 | 13865x |
if (length(f_names) > 0) { |
402 |
# We need to differentiate between default and specified fractions |
|
403 |
# and set the unspecified to 1 - sum(specified)/n_unspecified |
|
404 | 3365x |
f_default_names <- intersect(f_names, defaultpar.names) |
405 | 3365x |
f_specified_names <- setdiff(f_names, defaultpar.names) |
406 | 3365x |
sum_f_specified = sum(parms.ini[f_specified_names]) |
407 | 3365x |
if (sum_f_specified > 1) { |
408 | 104x |
stop("Starting values for the formation fractions originating from ", |
409 | 104x |
origin, " sum up to more than 1.") |
410 |
} |
|
411 | 3260x |
if (mkinmod$spec[[obs_var]]$sink) n_unspecified = length(f_default_names) + 1 |
412 |
else { |
|
413 | 1x |
n_unspecified = length(f_default_names) |
414 |
} |
|
415 | 3261x |
parms.ini[f_default_names] <- (1 - sum_f_specified) / n_unspecified |
416 |
} |
|
417 |
} |
|
418 | ||
419 |
# Set default for state.ini if appropriate |
|
420 | 8529x |
parent_name = names(mkinmod$spec)[[1]] |
421 | 8529x |
parent_time_0 = subset(observed, time == 0 & name == parent_name)$value |
422 | 8529x |
parent_time_0_mean = mean(parent_time_0, na.rm = TRUE) |
423 | 8529x |
if (is.na(parent_time_0_mean)) { |
424 | 2x |
state.ini_auto = c(100, rep(0, length(mkinmod$diffs) - 1)) |
425 |
} else { |
|
426 | 8527x |
state.ini_auto = c(parent_time_0_mean, rep(0, length(mkinmod$diffs) - 1)) |
427 |
} |
|
428 | 8529x |
names(state.ini_auto) <- mod_vars |
429 | ||
430 | 8529x |
if (state.ini[1] == "auto") { |
431 | 8316x |
state.ini_used <- state.ini_auto |
432 |
} else { |
|
433 | 213x |
state.ini_used <- state.ini_auto |
434 | 213x |
state.ini_good <- intersect(names(mkinmod$diffs), names(state.ini)) |
435 | 213x |
state.ini_used[state.ini_good] <- state.ini[state.ini_good] |
436 |
} |
|
437 | 8529x |
state.ini <- state.ini_used |
438 | ||
439 |
# Name the inital state variable values if they are not named yet |
|
440 | ! |
if(is.null(names(state.ini))) names(state.ini) <- mod_vars |
441 | ||
442 |
# Transform initial parameter values for fitting |
|
443 | 8529x |
transparms.ini <- transform_odeparms(parms.ini, mkinmod, |
444 | 8529x |
transform_rates = transform_rates, |
445 | 8529x |
transform_fractions = transform_fractions) |
446 | ||
447 |
# Parameters to be optimised: |
|
448 |
# Kinetic parameters in parms.ini whose names are not in fixed_parms |
|
449 | 8529x |
parms.fixed <- parms.ini[fixed_parms] |
450 | 8529x |
parms.optim <- parms.ini[setdiff(names(parms.ini), fixed_parms)] |
451 | ||
452 | 8529x |
transparms.fixed <- transform_odeparms(parms.fixed, mkinmod, |
453 | 8529x |
transform_rates = transform_rates, |
454 | 8529x |
transform_fractions = transform_fractions) |
455 | 8529x |
transparms.optim <- transform_odeparms(parms.optim, mkinmod, |
456 | 8529x |
transform_rates = transform_rates, |
457 | 8529x |
transform_fractions = transform_fractions) |
458 | ||
459 |
# Inital state variables in state.ini whose names are not in fixed_initials |
|
460 | 8529x |
state.ini.fixed <- state.ini[fixed_initials] |
461 | 8529x |
state.ini.optim <- state.ini[setdiff(names(state.ini), fixed_initials)] |
462 | ||
463 |
# Preserve names of state variables before renaming initial state variable |
|
464 |
# parameters |
|
465 | 8529x |
state.ini.optim.boxnames <- names(state.ini.optim) |
466 | 8529x |
state.ini.fixed.boxnames <- names(state.ini.fixed) |
467 | 8529x |
if(length(state.ini.optim) > 0) { |
468 | 8529x |
names(state.ini.optim) <- paste(names(state.ini.optim), "0", sep="_") |
469 |
} |
|
470 | 8529x |
if(length(state.ini.fixed) > 0) { |
471 | 4509x |
names(state.ini.fixed) <- paste(names(state.ini.fixed), "0", sep="_") |
472 |
} |
|
473 | ||
474 |
# Decide if the solution of the model can be based on a simple analytical |
|
475 |
# formula, the spectral decomposition of the matrix (fundamental system) |
|
476 |
# or a numeric ode solver from the deSolve package |
|
477 |
# Prefer deSolve over eigen if a compiled model is present and use_compiled |
|
478 |
# is not set to FALSE |
|
479 | 8529x |
solution_type = match.arg(solution_type) |
480 | 8529x |
if (solution_type == "analytical" && !is.function(mkinmod$deg_func)) |
481 | 105x |
stop("Analytical solution not implemented for this model.") |
482 | 8424x |
if (solution_type == "eigen" && !is.matrix(mkinmod$coefmat)) |
483 | 104x |
stop("Eigenvalue based solution not possible, coefficient matrix not present.") |
484 | 8320x |
if (solution_type == "auto") { |
485 | 6190x |
if (length(mkinmod$spec) == 1 || is.function(mkinmod$deg_func)) { |
486 | 5434x |
solution_type = "analytical" |
487 |
} else { |
|
488 | 756x |
if (!is.null(mkinmod$cf) & use_compiled[1] != FALSE) { |
489 | 756x |
solution_type = "deSolve" |
490 |
} else { |
|
491 | ! |
if (is.matrix(mkinmod$coefmat)) { |
492 | ! |
solution_type = "eigen" |
493 | ! |
if (max(observed$value, na.rm = TRUE) < 0.1) { |
494 | ! |
stop("The combination of small observed values (all < 0.1) and solution_type = eigen is error-prone") |
495 |
} |
|
496 |
} else { |
|
497 | ! |
solution_type = "deSolve" |
498 |
} |
|
499 |
} |
|
500 |
} |
|
501 |
} |
|
502 | ||
503 |
# Get native symbol before iterations info for speed |
|
504 | 8320x |
use_symbols = FALSE |
505 | 8320x |
if (solution_type == "deSolve" & use_compiled[1] != FALSE) { |
506 | 2144x |
mkinmod[["symbols"]] <- try( |
507 | 2144x |
deSolve::checkDLL(dllname = mkinmod$dll_info[["name"]], |
508 | 2144x |
func = "diffs", initfunc = "initpar", |
509 | 2144x |
jacfunc = NULL, nout = 0, outnames = NULL)) |
510 | 2144x |
if (!inherits(mkinmod[["symbols"]], "try-error")) { |
511 | 2144x |
use_symbols = TRUE |
512 |
} |
|
513 |
} |
|
514 | ||
515 |
# Get the error model and the algorithm for fitting |
|
516 | 8320x |
err_mod <- match.arg(error_model) |
517 | 8320x |
error_model_algorithm = match.arg(error_model_algorithm) |
518 | 8320x |
if (error_model_algorithm == "OLS") { |
519 | ! |
if (err_mod != "const") stop("OLS is only appropriate for constant variance") |
520 |
} |
|
521 | 8320x |
if (error_model_algorithm == "auto") { |
522 | 6692x |
error_model_algorithm = switch(err_mod, |
523 | 6692x |
const = "OLS", obs = "d_3", tc = "d_3") |
524 |
} |
|
525 | 8320x |
errparm_names <- switch(err_mod, |
526 | 8320x |
"const" = "sigma", |
527 | 8320x |
"obs" = paste0("sigma_", obs_vars), |
528 | 8320x |
"tc" = c("sigma_low", "rsd_high")) |
529 | 8320x |
errparm_names_optim <- if (error_model_algorithm == "OLS") NULL else errparm_names |
530 | ||
531 |
# Define starting values for the error model |
|
532 | 8320x |
if (err.ini[1] != "auto") { |
533 | ! |
if (!identical(names(err.ini), errparm_names)) { |
534 | ! |
stop("Please supply initial values for error model components ", paste(errparm_names, collapse = ", ")) |
535 |
} else { |
|
536 | ! |
errparms = err.ini |
537 |
} |
|
538 |
} else { |
|
539 | 8320x |
if (err_mod == "const") { |
540 | 6410x |
errparms = 3 |
541 |
} |
|
542 | 8320x |
if (err_mod == "obs") { |
543 | 317x |
errparms = rep(3, length(obs_vars)) |
544 |
} |
|
545 | 8320x |
if (err_mod == "tc") { |
546 | 1593x |
errparms <- c(sigma_low = 0.1, rsd_high = 0.1) |
547 |
} |
|
548 | 8320x |
names(errparms) <- errparm_names |
549 |
} |
|
550 | 8320x |
if (error_model_algorithm == "OLS") { |
551 | 6410x |
errparms_optim <- NULL |
552 |
} else { |
|
553 | 1910x |
errparms_optim <- errparms |
554 |
} |
|
555 | ||
556 |
# Unique outtimes for model solution. |
|
557 | 8320x |
outtimes <- sort(unique(observed$time)) |
558 | ||
559 |
# Define the objective function for optimisation, including (back)transformations |
|
560 | 8320x |
cost_function <- function(P, trans = TRUE, OLS = FALSE, fixed_degparms = FALSE, fixed_errparms = FALSE, update_data = TRUE, ...) |
561 |
{ |
|
562 | 4086568x |
assign("calls", calls + 1, inherits = TRUE) # Increase the model solution counter |
563 | ||
564 |
#browser() |
|
565 | ||
566 |
# Trace parameter values if requested and if we are actually optimising |
|
567 | 3224x |
if(trace_parms & update_data) cat(format(P, width = 10, digits = 6), "\n") |
568 | ||
569 |
# Determine local parameter values for the cost estimation |
|
570 | 4086568x |
if (is.numeric(fixed_degparms)) { |
571 | 94746x |
cost_degparms <- fixed_degparms |
572 | 94746x |
cost_errparms <- P |
573 | 94746x |
degparms_fixed = TRUE |
574 |
} else { |
|
575 | 3991822x |
degparms_fixed = FALSE |
576 |
} |
|
577 | ||
578 | 4086568x |
if (is.numeric(fixed_errparms)) { |
579 | 4725x |
cost_degparms <- P |
580 | 4725x |
cost_errparms <- fixed_errparms |
581 | 4725x |
errparms_fixed = TRUE |
582 |
} else { |
|
583 | 4081843x |
errparms_fixed = FALSE |
584 |
} |
|
585 | ||
586 | 4086568x |
if (OLS) { |
587 | 1063145x |
cost_degparms <- P |
588 | 1063145x |
cost_errparms <- numeric(0) |
589 |
} |
|
590 | ||
591 | 4086568x |
if (!OLS & !degparms_fixed & !errparms_fixed) { |
592 | 2923952x |
cost_degparms <- P[1:(length(P) - length(errparms))] |
593 | 2923952x |
cost_errparms <- P[(length(cost_degparms) + 1):length(P)] |
594 |
} |
|
595 | ||
596 |
# Initial states for t0 |
|
597 | 4086568x |
if(length(state.ini.optim) > 0) { |
598 | 4086568x |
odeini <- c(cost_degparms[1:length(state.ini.optim)], state.ini.fixed) |
599 | 4086568x |
names(odeini) <- c(state.ini.optim.boxnames, state.ini.fixed.boxnames) |
600 |
} else { |
|
601 | ! |
odeini <- state.ini.fixed |
602 | ! |
names(odeini) <- state.ini.fixed.boxnames |
603 |
} |
|
604 | ||
605 | 4086568x |
odeparms.optim <- cost_degparms[(length(state.ini.optim) + 1):length(cost_degparms)] |
606 | ||
607 | 4086568x |
if (trans == TRUE) { |
608 | 2580794x |
odeparms <- c(odeparms.optim, transparms.fixed) |
609 | 2580794x |
parms <- backtransform_odeparms(odeparms, mkinmod, |
610 | 2580794x |
transform_rates = transform_rates, |
611 | 2580794x |
transform_fractions = transform_fractions) |
612 |
} else { |
|
613 | 1505774x |
parms <- c(odeparms.optim, parms.fixed) |
614 |
} |
|
615 | ||
616 |
# Solve the system with current parameter values |
|
617 | 4086568x |
if (solution_type == "analytical") { |
618 | 2562380x |
observed$predicted <- mkinmod$deg_func(observed, odeini, parms) |
619 |
} else { |
|
620 | 1524188x |
out <- mkinpredict(mkinmod, parms, |
621 | 1524188x |
odeini, outtimes, |
622 | 1524188x |
solution_type = solution_type, |
623 | 1524188x |
use_compiled = use_compiled, |
624 | 1524188x |
use_symbols = use_symbols, |
625 | 1524188x |
method.ode = method.ode, |
626 | 1524188x |
atol = atol, rtol = rtol, |
627 |
...) |
|
628 | ||
629 | 1524188x |
observed_index <- cbind(as.character(observed$time), as.character(observed$name)) |
630 | 1524188x |
observed$predicted <- out[observed_index] |
631 |
} |
|
632 | ||
633 |
# Define standard deviation for each observation |
|
634 | 4086568x |
if (err_mod == "const") { |
635 | 2789021x |
observed$std <- if (OLS) NA else cost_errparms["sigma"] |
636 |
} |
|
637 | 4086568x |
if (err_mod == "obs") { |
638 | 366137x |
std_names <- paste0("sigma_", observed$name) |
639 | 366137x |
observed$std <- cost_errparms[std_names] |
640 |
} |
|
641 | 4086568x |
if (err_mod == "tc") { |
642 | 931410x |
observed$std <- sqrt(cost_errparms["sigma_low"]^2 + observed$predicted^2 * cost_errparms["rsd_high"]^2) |
643 |
} |
|
644 | ||
645 |
# Calculate model cost |
|
646 | 4086568x |
if (OLS) { |
647 |
# Cost is the sum of squared residuals |
|
648 | 1063145x |
cost <- with(observed, sum((value - predicted)^2)) |
649 |
} else { |
|
650 |
# Cost is the negative log-likelihood |
|
651 | 3023423x |
cost <- - with(observed, |
652 | 3023423x |
sum(dnorm(x = value, mean = predicted, sd = std, log = TRUE))) |
653 |
} |
|
654 | ||
655 |
# We update the current cost and data during the optimisation, not |
|
656 |
# during hessian calculations |
|
657 | 4086568x |
if (update_data) { |
658 | ||
659 | 1622188x |
assign("current_data", observed, inherits = TRUE) |
660 | ||
661 | 1622188x |
if (cost < cost.current) { |
662 | 594930x |
assign("cost.current", cost, inherits = TRUE) |
663 | 1768x |
if (!quiet) message(ifelse(OLS, "Sum of squared residuals", "Negative log-likelihood"), |
664 | 1768x |
" at call ", calls, ": ", signif(cost.current, 6), "\n") |
665 |
} |
|
666 |
} |
|
667 | 4086415x |
return(cost) |
668 |
} |
|
669 | ||
670 | 8320x |
names_optim <- c(names(state.ini.optim), |
671 | 8320x |
names(transparms.optim), |
672 | 8320x |
errparm_names_optim) |
673 | 8320x |
n_optim <- length(names_optim) |
674 | ||
675 |
# Define lower and upper bounds other than -Inf and Inf for parameters |
|
676 |
# for which no internal transformation is requested in the call to mkinfit |
|
677 |
# and for optimised error model parameters |
|
678 | 8320x |
lower <- rep(-Inf, n_optim) |
679 | 8320x |
upper <- rep(Inf, n_optim) |
680 | 8320x |
names(lower) <- names(upper) <- names_optim |
681 | ||
682 |
# IORE exponents are not transformed, but need a lower bound |
|
683 | 8320x |
index_N <- grep("^N", names(lower)) |
684 | 8320x |
lower[index_N] <- 0 |
685 | ||
686 | 8320x |
if (!transform_rates) { |
687 | 553x |
index_k <- grep("^k_", names(lower)) |
688 | 553x |
lower[index_k] <- 0 |
689 | 553x |
index_k__iore <- grep("^k__iore_", names(lower)) |
690 | 553x |
lower[index_k__iore] <- 0 |
691 | 553x |
other_rate_parms <- intersect(c("alpha", "beta", "k1", "k2", "tb", "r"), names(lower)) |
692 | 553x |
lower[other_rate_parms] <- 0 |
693 |
} |
|
694 | ||
695 | 8320x |
if (!transform_fractions) { |
696 | 306x |
index_f <- grep("^f_", names(upper)) |
697 | 306x |
lower[index_f] <- 0 |
698 | 306x |
upper[index_f] <- 1 |
699 | 306x |
other_fraction_parms <- intersect(c("g"), names(upper)) |
700 | 306x |
lower[other_fraction_parms] <- 0 |
701 | 306x |
upper[other_fraction_parms] <- 1 |
702 |
} |
|
703 | ||
704 | 8320x |
if (err_mod == "const") { |
705 | 6410x |
if (error_model_algorithm != "OLS") { |
706 | ! |
lower["sigma"] <- 0 |
707 |
} |
|
708 |
} |
|
709 | 8320x |
if (err_mod == "obs") { |
710 | 317x |
index_sigma <- grep("^sigma_", names(lower)) |
711 | 317x |
lower[index_sigma] <- 0 |
712 |
} |
|
713 | 8320x |
if (err_mod == "tc") { |
714 | 1593x |
lower["sigma_low"] <- 0 |
715 | 1593x |
lower["rsd_high"] <- 0 |
716 |
} |
|
717 | ||
718 |
# Counter for cost function evaluations |
|
719 | 8320x |
calls = 0 |
720 | 8320x |
cost.current <- Inf |
721 | 8320x |
out_predicted <- NA |
722 | 8320x |
current_data <- NA |
723 | ||
724 |
# Show parameter names if tracing is requested |
|
725 | 104x |
if(trace_parms) cat(format(names_optim, width = 10), "\n") |
726 | ||
727 |
#browser() |
|
728 | ||
729 |
# Do the fit and take the time until the hessians are calculated |
|
730 | 8320x |
fit_time <- system.time({ |
731 | 8320x |
degparms <- c(state.ini.optim, transparms.optim) |
732 | 8320x |
n_degparms <- length(degparms) |
733 | 8320x |
degparms_index <- seq(1, n_degparms) |
734 | 8320x |
errparms_index <- seq(n_degparms + 1, length.out = length(errparms)) |
735 | ||
736 | 8320x |
if (error_model_algorithm == "d_3") { |
737 | ! |
if (!quiet) message("Directly optimising the complete model") |
738 | 471x |
parms.start <- c(degparms, errparms) |
739 | 471x |
fit_direct <- try(nlminb(parms.start, cost_function, |
740 | 471x |
lower = lower[names(parms.start)], |
741 | 471x |
upper = upper[names(parms.start)], |
742 | 471x |
control = control, ...)) |
743 | 471x |
if (!inherits(fit_direct, "try-error")) { |
744 | 471x |
fit_direct$logLik <- - cost.current |
745 | 471x |
cost.current <- Inf # reset to avoid conflict with the OLS step |
746 | 471x |
data_direct <- current_data # We need this later if it was better |
747 | 471x |
direct_failed = FALSE |
748 |
} else { |
|
749 | ! |
direct_failed = TRUE |
750 |
} |
|
751 |
} |
|
752 | 8320x |
if (error_model_algorithm != "direct") { |
753 | 104x |
if (!quiet) message("Ordinary least squares optimisation") |
754 | 7884x |
fit <- nlminb(degparms, cost_function, control = control, |
755 | 7884x |
lower = lower[names(degparms)], |
756 | 7884x |
upper = upper[names(degparms)], OLS = TRUE, ...) |
757 | 7731x |
degparms <- fit$par |
758 | ||
759 |
# Get the maximum likelihood estimate for sigma at the optimum parameter values |
|
760 | 7731x |
current_data$residual <- current_data$value - current_data$predicted |
761 | 7731x |
sigma_mle <- sqrt(sum(current_data$residual^2)/nrow(current_data)) |
762 | ||
763 |
# Use that estimate for the constant variance, or as first guess if err_mod = "obs" |
|
764 | 7731x |
if (err_mod != "tc") { |
765 | 6327x |
errparms[names(errparms)] <- sigma_mle |
766 |
} |
|
767 | 7731x |
fit$par <- c(fit$par, errparms) |
768 | ||
769 | 7731x |
cost.current <- cost_function(c(degparms, errparms), OLS = FALSE) |
770 | 7731x |
fit$logLik <- - cost.current |
771 |
} |
|
772 | 8167x |
if (error_model_algorithm %in% c("threestep", "fourstep", "d_3")) { |
773 | ! |
if (!quiet) message("Optimising the error model") |
774 | 1096x |
fit <- nlminb(errparms, cost_function, control = control, |
775 | 1096x |
lower = lower[names(errparms)], |
776 | 1096x |
upper = upper[names(errparms)], |
777 | 1096x |
fixed_degparms = degparms, ...) |
778 | 1096x |
errparms <- fit$par |
779 |
} |
|
780 | 8167x |
if (error_model_algorithm == "fourstep") { |
781 | ! |
if (!quiet) message("Optimising the degradation model") |
782 | 189x |
fit <- nlminb(degparms, cost_function, control = control, |
783 | 189x |
lower = lower[names(degparms)], |
784 | 189x |
upper = upper[names(degparms)], |
785 | 189x |
fixed_errparms = errparms, ...) |
786 | 189x |
degparms <- fit$par |
787 |
} |
|
788 | 8167x |
if (error_model_algorithm %in% |
789 | 8167x |
c("direct", "twostep", "threestep", "fourstep", "d_3")) { |
790 | ! |
if (!quiet) message("Optimising the complete model") |
791 | 1721x |
parms.start <- c(degparms, errparms) |
792 | 1721x |
fit <- nlminb(parms.start, cost_function, |
793 | 1721x |
lower = lower[names(parms.start)], |
794 | 1721x |
upper = upper[names(parms.start)], |
795 | 1721x |
control = control, ...) |
796 | 1721x |
degparms <- fit$par[degparms_index] |
797 | 1721x |
errparms <- fit$par[errparms_index] |
798 | 1721x |
fit$logLik <- - cost.current |
799 | ||
800 | 1721x |
if (error_model_algorithm == "d_3") { |
801 | 471x |
d_3_messages = c( |
802 | 471x |
direct_failed = "Direct fitting failed, results of three-step fitting are returned", |
803 | 471x |
same = "Direct fitting and three-step fitting yield approximately the same likelihood", |
804 | 471x |
threestep = "Three-step fitting yielded a higher likelihood than direct fitting", |
805 | 471x |
direct = "Direct fitting yielded a higher likelihood than three-step fitting") |
806 | 471x |
if (direct_failed) { |
807 | ! |
if (!quiet) message(d_3_messages["direct_failed"]) |
808 | ! |
fit$d_3_message <- d_3_messages["direct_failed"] |
809 |
} else { |
|
810 | 471x |
rel_diff <- abs((fit_direct$logLik - fit$logLik))/-mean(c(fit_direct$logLik, fit$logLik)) |
811 | 471x |
if (rel_diff < 0.0001) { |
812 | ! |
if (!quiet) message(d_3_messages["same"]) |
813 | 240x |
fit$d_3_message <- d_3_messages["same"] |
814 |
} else { |
|
815 | 231x |
if (fit$logLik > fit_direct$logLik) { |
816 | ! |
if (!quiet) message(d_3_messages["threestep"]) |
817 | 15x |
fit$d_3_message <- d_3_messages["threestep"] |
818 |
} else { |
|
819 | ! |
if (!quiet) message(d_3_messages["direct"]) |
820 | 216x |
fit <- fit_direct |
821 | 216x |
fit$d_3_message <- d_3_messages["direct"] |
822 | 216x |
degparms <- fit$par[degparms_index] |
823 | 216x |
errparms <- fit$par[errparms_index] |
824 | 216x |
current_data <- data_direct |
825 |
} |
|
826 |
} |
|
827 |
} |
|
828 |
} |
|
829 |
} |
|
830 | 8167x |
if (err_mod != "const" & error_model_algorithm == "IRLS") { |
831 | 189x |
reweight.diff <- 1 |
832 | 189x |
n.iter <- 0 |
833 | 189x |
errparms_last <- errparms |
834 | ||
835 | 189x |
while (reweight.diff > reweight.tol & |
836 | 189x |
n.iter < reweight.max.iter) { |
837 | ||
838 | ! |
if (!quiet) message("Optimising the error model") |
839 | 756x |
fit <- nlminb(errparms, cost_function, control = control, |
840 | 756x |
lower = lower[names(errparms)], |
841 | 756x |
upper = upper[names(errparms)], |
842 | 756x |
fixed_degparms = degparms, ...) |
843 | 756x |
errparms <- fit$par |
844 | ||
845 | ! |
if (!quiet) message("Optimising the degradation model") |
846 | 756x |
fit <- nlminb(degparms, cost_function, control = control, |
847 | 756x |
lower = lower[names(degparms)], |
848 | 756x |
upper = upper[names(degparms)], |
849 | 756x |
fixed_errparms = errparms, ...) |
850 | 756x |
degparms <- fit$par |
851 | ||
852 | 756x |
reweight.diff <- dist(rbind(errparms, errparms_last)) |
853 | 756x |
errparms_last <- errparms |
854 | ||
855 | 756x |
fit$par <- c(fit$par, errparms) |
856 | 756x |
cost.current <- cost_function(c(degparms, errparms), OLS = FALSE) |
857 | 756x |
fit$logLik <- - cost.current |
858 |
} |
|
859 |
} |
|
860 | ||
861 | 8167x |
dim_hessian <- length(c(degparms, errparms)) |
862 | ||
863 | 8167x |
fit$hessian <- try(numDeriv::hessian(cost_function, c(degparms, errparms), OLS = FALSE, |
864 | 8167x |
update_data = FALSE), silent = TRUE) |
865 | 8167x |
if (inherits(fit$hessian, "try-error")) { |
866 | ! |
fit$hessian <- matrix(NA, nrow = dim_hessian, ncol = dim_hessian) |
867 |
} |
|
868 | 8167x |
dimnames(fit$hessian) <- list(names(c(degparms, errparms)), |
869 | 8167x |
names(c(degparms, errparms))) |
870 | ||
871 |
# Backtransform parameters |
|
872 | 8167x |
bparms.optim = backtransform_odeparms(degparms, mkinmod, |
873 | 8167x |
transform_rates = transform_rates, |
874 | 8167x |
transform_fractions = transform_fractions) |
875 | 8167x |
bparms.fixed = c(state.ini.fixed, parms.fixed) |
876 | 8167x |
bparms.all = c(bparms.optim, parms.fixed) |
877 | ||
878 | 8167x |
fit$hessian_notrans <- try(numDeriv::hessian(cost_function, c(bparms.optim, errparms), |
879 | 8167x |
OLS = FALSE, trans = FALSE, update_data = FALSE), silent = TRUE) |
880 | 8167x |
if (inherits(fit$hessian_notrans, "try-error")) { |
881 | ! |
fit$hessian_notrans <- matrix(NA, nrow = dim_hessian, ncol = dim_hessian) |
882 |
} |
|
883 | 8167x |
dimnames(fit$hessian_notrans) <- list(names(c(bparms.optim, errparms)), |
884 | 8167x |
names(c(bparms.optim, errparms))) |
885 |
}) |
|
886 | ||
887 | 8167x |
fit$call <- call |
888 | ||
889 | 8167x |
fit$error_model_algorithm <- error_model_algorithm |
890 | ||
891 | 8167x |
if (fit$convergence != 0) { |
892 | 108x |
convergence_warning = paste0("Optimisation did not converge:\n", fit$message) |
893 | 108x |
summary_warnings <- c(summary_warnings, C = convergence_warning) |
894 | 108x |
warning(convergence_warning) |
895 |
} else { |
|
896 | 104x |
if(!quiet) message("Optimisation successfully terminated.\n") |
897 |
} |
|
898 | ||
899 |
# We need to return some more data for summary and plotting |
|
900 | 8167x |
fit$solution_type <- solution_type |
901 | 8167x |
fit$transform_rates <- transform_rates |
902 | 8167x |
fit$transform_fractions <- transform_fractions |
903 | 8167x |
fit$reweight.tol <- reweight.tol |
904 | 8167x |
fit$reweight.max.iter <- reweight.max.iter |
905 | 8167x |
fit$control <- control |
906 | 8167x |
fit$calls <- calls |
907 | 8167x |
fit$time <- fit_time |
908 | ||
909 |
# We also need the model and a model name for summary and plotting, |
|
910 |
# but without symbols because they could become invalid |
|
911 | 8167x |
fit$symbols <- NULL |
912 | 8167x |
fit$mkinmod <- mkinmod |
913 | 8167x |
fit$mkinmod$name <- mkinmod_name |
914 | 8167x |
fit$obs_vars <- obs_vars |
915 | ||
916 |
# Residual sum of squares as a function of the fitted parameters |
|
917 | 8167x |
fit$rss <- function(P) cost_function(P, OLS = TRUE, update_data = FALSE) |
918 | ||
919 |
# Log-likelihood with possibility to fix degparms or errparms |
|
920 | 8167x |
fit$ll <- function(P, fixed_degparms = FALSE, fixed_errparms = FALSE, trans = FALSE) { |
921 | 547080x |
- cost_function(P, trans = trans, fixed_degparms = fixed_degparms, |
922 | 547080x |
fixed_errparms = fixed_errparms, OLS = FALSE, update_data = FALSE) |
923 |
} |
|
924 | ||
925 |
# Collect initial parameter values in three dataframes |
|
926 | 8167x |
fit$start <- data.frame(value = c(state.ini.optim, |
927 | 8167x |
parms.optim, errparms_optim)) |
928 | 8167x |
fit$start$type = c(rep("state", length(state.ini.optim)), |
929 | 8167x |
rep("deparm", length(parms.optim)), |
930 | 8167x |
rep("error", length(errparms_optim))) |
931 | ||
932 | 8167x |
fit$start_transformed = data.frame( |
933 | 8167x |
value = c(state.ini.optim, transparms.optim, errparms_optim), |
934 | 8167x |
lower = lower, |
935 | 8167x |
upper = upper) |
936 | ||
937 | 8167x |
fit$fixed <- data.frame(value = c(state.ini.fixed, parms.fixed)) |
938 | 8167x |
fit$fixed$type = c(rep("state", length(state.ini.fixed)), |
939 | 8167x |
rep("deparm", length(parms.fixed))) |
940 | ||
941 | 8167x |
fit$data <- data.frame(time = current_data$time, |
942 | 8167x |
variable = current_data$name, |
943 | 8167x |
observed = current_data$value, |
944 | 8167x |
predicted = current_data$predicted) |
945 | ||
946 | 8167x |
fit$data$residual <- fit$data$observed - fit$data$predicted |
947 | ||
948 | 8167x |
fit$atol <- atol |
949 | 8167x |
fit$rtol <- rtol |
950 | 8167x |
fit$err_mod <- err_mod |
951 | ||
952 |
# Return different sets of backtransformed parameters for summary and plotting |
|
953 | 8167x |
fit$bparms.optim <- bparms.optim |
954 | 8167x |
fit$bparms.fixed <- bparms.fixed |
955 | ||
956 |
# Return ode and state parameters for further fitting |
|
957 | 8167x |
fit$bparms.ode <- bparms.all[mkinmod$parms] |
958 | 8167x |
fit$bparms.state <- c(bparms.all[setdiff(names(bparms.all), names(fit$bparms.ode))], |
959 | 8167x |
state.ini.fixed) |
960 | 8167x |
names(fit$bparms.state) <- gsub("_0$", "", names(fit$bparms.state)) |
961 | ||
962 | 8167x |
fit$errparms <- errparms |
963 | 8167x |
fit$df.residual <- n_observed - length(c(degparms, errparms)) |
964 | ||
965 |
# Assign the class here so method dispatch works for residuals |
|
966 | 8167x |
class(fit) <- c("mkinfit") |
967 | ||
968 | 8167x |
if (test_residuals) { |
969 |
# Check for normal distribution of residuals |
|
970 | 153x |
fit$shapiro.p <- shapiro.test(residuals(fit, standardized = TRUE))$p.value |
971 | 153x |
if (fit$shapiro.p < 0.05) { |
972 | 153x |
shapiro_warning <- paste("Shapiro-Wilk test for standardized residuals: p = ", signif(fit$shapiro.p, 3)) |
973 | 153x |
warning(shapiro_warning) |
974 | 153x |
summary_warnings <- c(summary_warnings, S = shapiro_warning) |
975 |
} |
|
976 |
} |
|
977 | ||
978 | 8167x |
fit$summary_warnings <- summary_warnings |
979 | ||
980 | 8167x |
fit$date <- date() |
981 | 8167x |
fit$version <- as.character(utils::packageVersion("mkin")) |
982 | 8167x |
fit$Rversion <- paste(R.version$major, R.version$minor, sep=".") |
983 | ||
984 | 8167x |
return(fit) |
985 |
} |
1 |
#' Method to get the names of ill-defined parameters |
|
2 |
#' |
|
3 |
#' The method for generalised nonlinear regression fits as obtained |
|
4 |
#' with [mkinfit] and [mmkin] checks if the degradation parameters |
|
5 |
#' pass the Wald test (in degradation kinetics often simply called t-test) for |
|
6 |
#' significant difference from zero. For this test, the parameterisation |
|
7 |
#' without parameter transformations is used. |
|
8 |
#' |
|
9 |
#' The method for hierarchical model fits, also known as nonlinear |
|
10 |
#' mixed-effects model fits as obtained with [saem] and [mhmkin] |
|
11 |
#' checks if any of the confidence intervals for the random |
|
12 |
#' effects expressed as standard deviations include zero, and if |
|
13 |
#' the confidence intervals for the error model parameters include |
|
14 |
#' zero. |
|
15 |
#' |
|
16 |
#' @param object The object to investigate |
|
17 |
#' @param x The object to be printed |
|
18 |
#' @param conf.level The confidence level for checking p values |
|
19 |
#' @param \dots For potential future extensions |
|
20 |
#' @param random For hierarchical fits, should random effects be tested? |
|
21 |
#' @param errmod For hierarchical fits, should error model parameters be |
|
22 |
#' tested? |
|
23 |
#' @param slopes For hierarchical [saem] fits using saemix as backend, |
|
24 |
#' should slope parameters in the covariate model(starting with 'beta_') be |
|
25 |
#' tested? |
|
26 |
#' @return For [mkinfit] or [saem] objects, a character vector of parameter |
|
27 |
#' names. For [mmkin] or [mhmkin] objects, a matrix like object of class |
|
28 |
#' 'illparms.mmkin' or 'illparms.mhmkin'. |
|
29 |
#' @note All return objects have printing methods. For the single fits, printing |
|
30 |
#' does not output anything in the case no ill-defined parameters are found. |
|
31 |
#' @export |
|
32 |
illparms <- function(object, ...) |
|
33 |
{ |
|
34 | 2471x |
UseMethod("illparms", object) |
35 |
} |
|
36 | ||
37 |
#' @rdname illparms |
|
38 |
#' @export |
|
39 |
#' @examples |
|
40 |
#' fit <- mkinfit("FOMC", FOCUS_2006_A, quiet = TRUE) |
|
41 |
#' illparms(fit) |
|
42 |
illparms.mkinfit <- function(object, conf.level = 0.95, ...) { |
|
43 | 8x |
p_values <- suppressWarnings(summary(object)$bpar[, "Pr(>t)"]) |
44 | 8x |
na <- is.na(p_values) |
45 | 8x |
failed <- p_values > 1 - conf.level |
46 | 8x |
ret <- names(parms(object))[na | failed] |
47 | 8x |
class(ret) <- "illparms.mkinfit" |
48 | 8x |
return(ret) |
49 |
} |
|
50 | ||
51 |
#' @rdname illparms |
|
52 |
#' @export |
|
53 |
print.illparms.mkinfit <- function(x, ...) { |
|
54 | 190x |
class(x) <- NULL |
55 | 190x |
if (length(x) > 0) { |
56 | ! |
print(as.character(x)) |
57 |
} |
|
58 |
} |
|
59 | ||
60 |
#' @rdname illparms |
|
61 |
#' @export |
|
62 |
#' @examples |
|
63 |
#' \dontrun{ |
|
64 |
#' fits <- mmkin( |
|
65 |
#' c("SFO", "FOMC"), |
|
66 |
#' list("FOCUS A" = FOCUS_2006_A, |
|
67 |
#' "FOCUS C" = FOCUS_2006_C), |
|
68 |
#' quiet = TRUE) |
|
69 |
#' illparms(fits) |
|
70 |
#' } |
|
71 |
illparms.mmkin <- function(object, conf.level = 0.95, ...) { |
|
72 | 1x |
result <- lapply(object, |
73 | 1x |
function(fit) { |
74 | ! |
if (inherits(fit, "try-error")) return("E") |
75 | 8x |
ill <- illparms(fit, conf.level = conf.level) |
76 | 8x |
if (length(ill) > 0) { |
77 | 3x |
return(paste(ill, collapse = ", ")) |
78 |
} else { |
|
79 | 5x |
return("") |
80 |
} |
|
81 |
}) |
|
82 | 1x |
result <- unlist(result) |
83 | 1x |
dim(result) <- dim(object) |
84 | 1x |
dimnames(result) <- dimnames(object) |
85 | 1x |
class(result) <- "illparms.mmkin" |
86 | 1x |
return(result) |
87 |
} |
|
88 | ||
89 |
#' @rdname illparms |
|
90 |
#' @export |
|
91 |
print.illparms.mmkin <- function(x, ...) { |
|
92 | 1x |
class(x) <- NULL |
93 | 1x |
print(x, quote = FALSE) |
94 |
} |
|
95 | ||
96 |
#' @rdname illparms |
|
97 |
#' @export |
|
98 |
illparms.saem.mmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, slopes = TRUE, ...) { |
|
99 | 2091x |
if (inherits(object$so, "try-error")) { |
100 | ! |
ill_parms <- NA |
101 |
} else { |
|
102 | 2091x |
ints <- intervals(object, conf.level = conf.level) |
103 | 2091x |
ill_parms <- character(0) |
104 | 2091x |
if (random) { |
105 | 2091x |
ill_parms_random_i <- which(ints$random[, "lower"] < 0) |
106 | 2091x |
ill_parms_random <- rownames(ints$random)[ill_parms_random_i] |
107 | 2091x |
ill_parms <- c(ill_parms, ill_parms_random) |
108 |
} |
|
109 | 2091x |
if (errmod) { |
110 | 2091x |
ill_parms_errmod_i <- which(ints$errmod[, "lower"] < 0 & ints$errmod[, "upper"] > 0) |
111 | 2091x |
ill_parms_errmod <- rownames(ints$errmod)[ill_parms_errmod_i] |
112 | 2091x |
ill_parms <- c(ill_parms, ill_parms_errmod) |
113 |
} |
|
114 | 2091x |
if (slopes) { |
115 | ! |
if (is.null(object$so)) stop("Slope testing is only implemented for the saemix backend") |
116 | 2091x |
slope_names <- grep("^beta_", object$so@model@name.fixed, value = TRUE) |
117 | 2091x |
ci <- object$so@results@conf.int |
118 | 2091x |
rownames(ci) <- ci$name |
119 | 2091x |
slope_ci <- ci[slope_names, ] |
120 | 2091x |
ill_parms_slopes <- slope_ci[, "lower"] < 0 & slope_ci[, "upper"] > 0 |
121 | 2091x |
ill_parms <- c(ill_parms, slope_names[ill_parms_slopes]) |
122 |
} |
|
123 |
} |
|
124 | 2091x |
class(ill_parms) <- "illparms.saem.mmkin" |
125 | 2091x |
return(ill_parms) |
126 |
} |
|
127 | ||
128 |
#' @rdname illparms |
|
129 |
#' @export |
|
130 |
print.illparms.saem.mmkin <- print.illparms.mkinfit |
|
131 | ||
132 |
#' @rdname illparms |
|
133 |
#' @export |
|
134 |
illparms.mhmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, ...) { |
|
135 | 371x |
if (inherits(object[[1]], "saem.mmkin")) { |
136 | 371x |
check_failed <- function(x) if (inherits(x$so, "try-error")) TRUE else FALSE |
137 |
} |
|
138 | 371x |
result <- lapply(object, |
139 | 371x |
function(fit) { |
140 | 1484x |
if (check_failed(fit)) { |
141 | ! |
return("E") |
142 |
} else { |
|
143 | 1484x |
if (!is.null(fit$FIM_failed) && |
144 | 1484x |
"random effects and error model parameters" %in% fit$FIM_failed) { |
145 | ! |
return("NA") |
146 |
} else { |
|
147 | 1484x |
ill <- illparms(fit, conf.level = conf.level, random = random, errmod = errmod) |
148 | 1484x |
if (length(ill) > 0) { |
149 | 1000x |
return(paste(ill, collapse = ", ")) |
150 |
} else { |
|
151 | 484x |
return("") |
152 |
} |
|
153 |
} |
|
154 |
} |
|
155 |
}) |
|
156 | 371x |
result <- unlist(result) |
157 | 371x |
dim(result) <- dim(object) |
158 | 371x |
dimnames(result) <- dimnames(object) |
159 | 371x |
class(result) <- "illparms.mhmkin" |
160 | 371x |
return(result) |
161 |
} |
|
162 | ||
163 |
#' @rdname illparms |
|
164 |
#' @export |
|
165 |
print.illparms.mhmkin <- function(x, ...) { |
|
166 | 125x |
class(x) <- NULL |
167 | 125x |
print(x, quote = FALSE) |
168 |
} |
1 |
utils::globalVariables(c("type", "variable", "observed")) |
|
2 | ||
3 |
#' Plot the observed data and the fitted model of an mkinfit object |
|
4 |
#' |
|
5 |
#' Solves the differential equations with the optimised and fixed parameters |
|
6 |
#' from a previous successful call to \code{\link{mkinfit}} and plots the |
|
7 |
#' observed data together with the solution of the fitted model. |
|
8 |
#' |
|
9 |
#' If the current plot device is a \code{\link[tikzDevice]{tikz}} device, then |
|
10 |
#' latex is being used for the formatting of the chi2 error level, if |
|
11 |
#' \code{show_errmin = TRUE}. |
|
12 |
#' |
|
13 |
#' @aliases plot.mkinfit plot_sep plot_res plot_err |
|
14 |
#' @param x Alias for fit introduced for compatibility with the generic S3 |
|
15 |
#' method. |
|
16 |
#' @param fit An object of class \code{\link{mkinfit}}. |
|
17 |
#' @param obs_vars A character vector of names of the observed variables for |
|
18 |
#' which the data and the model should be plotted. Defauls to all observed |
|
19 |
#' variables in the model. |
|
20 |
#' @param xlab Label for the x axis. |
|
21 |
#' @param ylab Label for the y axis. |
|
22 |
#' @param xlim Plot range in x direction. |
|
23 |
#' @param ylim Plot range in y direction. If given as a list, plot ranges |
|
24 |
#' for the different plot rows can be given for row layout. |
|
25 |
#' @param col_obs Colors used for plotting the observed data and the |
|
26 |
#' corresponding model prediction lines. |
|
27 |
#' @param pch_obs Symbols to be used for plotting the data. |
|
28 |
#' @param lty_obs Line types to be used for the model predictions. |
|
29 |
#' @param add Should the plot be added to an existing plot? |
|
30 |
#' @param legend Should a legend be added to the plot? |
|
31 |
#' @param show_residuals Should residuals be shown? If only one plot of the |
|
32 |
#' fits is shown, the residual plot is in the lower third of the plot. |
|
33 |
#' Otherwise, i.e. if "sep_obs" is given, the residual plots will be located |
|
34 |
#' to the right of the plots of the fitted curves. If this is set to |
|
35 |
#' 'standardized', a plot of the residuals divided by the standard deviation |
|
36 |
#' given by the fitted error model will be shown. |
|
37 |
#' @param standardized When calling 'plot_res', should the residuals be |
|
38 |
#' standardized in the residual plot? |
|
39 |
#' @param show_errplot Should squared residuals and the error model be shown? |
|
40 |
#' If only one plot of the fits is shown, this plot is in the lower third of |
|
41 |
#' the plot. Otherwise, i.e. if "sep_obs" is given, the residual plots will |
|
42 |
#' be located to the right of the plots of the fitted curves. |
|
43 |
#' @param maxabs Maximum absolute value of the residuals. This is used for the |
|
44 |
#' scaling of the y axis and defaults to "auto". |
|
45 |
#' @param sep_obs Should the observed variables be shown in separate subplots? |
|
46 |
#' If yes, residual plots requested by "show_residuals" will be shown next |
|
47 |
#' to, not below the plot of the fits. |
|
48 |
#' @param rel.height.middle The relative height of the middle plot, if more |
|
49 |
#' than two rows of plots are shown. |
|
50 |
#' @param row_layout Should we use a row layout where the residual plot or the |
|
51 |
#' error model plot is shown to the right? |
|
52 |
#' @param lpos Position(s) of the legend(s). Passed to \code{\link{legend}} as |
|
53 |
#' the first argument. If not length one, this should be of the same length |
|
54 |
#' as the obs_var argument. |
|
55 |
#' @param inset Passed to \code{\link{legend}} if applicable. |
|
56 |
#' @param show_errmin Should the FOCUS chi2 error value be shown in the upper |
|
57 |
#' margin of the plot? |
|
58 |
#' @param errmin_digits The number of significant digits for rounding the FOCUS |
|
59 |
#' chi2 error percentage. |
|
60 |
#' @param frame Should a frame be drawn around the plots? |
|
61 |
#' @param \dots Further arguments passed to \code{\link{plot}}. |
|
62 |
#' @import graphics |
|
63 |
#' @importFrom grDevices dev.cur |
|
64 |
#' @return The function is called for its side effect. |
|
65 |
#' @author Johannes Ranke |
|
66 |
#' @examples |
|
67 |
#' |
|
68 |
#' # One parent compound, one metabolite, both single first order, path from |
|
69 |
#' # parent to sink included |
|
70 |
#' \dontrun{ |
|
71 |
#' SFO_SFO <- mkinmod(parent = mkinsub("SFO", "m1", full = "Parent"), |
|
72 |
#' m1 = mkinsub("SFO", full = "Metabolite M1" )) |
|
73 |
#' fit <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE) |
|
74 |
#' fit <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE, error_model = "tc") |
|
75 |
#' plot(fit) |
|
76 |
#' plot_res(fit) |
|
77 |
#' plot_res(fit, standardized = FALSE) |
|
78 |
#' plot_err(fit) |
|
79 |
#' |
|
80 |
#' # Show the observed variables separately, with residuals |
|
81 |
#' plot(fit, sep_obs = TRUE, show_residuals = TRUE, lpos = c("topright", "bottomright"), |
|
82 |
#' show_errmin = TRUE) |
|
83 |
#' |
|
84 |
#' # The same can be obtained with less typing, using the convenience function plot_sep |
|
85 |
#' plot_sep(fit, lpos = c("topright", "bottomright")) |
|
86 |
#' |
|
87 |
#' # Show the observed variables separately, with the error model |
|
88 |
#' plot(fit, sep_obs = TRUE, show_errplot = TRUE, lpos = c("topright", "bottomright"), |
|
89 |
#' show_errmin = TRUE) |
|
90 |
#' } |
|
91 |
#' |
|
92 |
#' @export |
|
93 |
plot.mkinfit <- function(x, fit = x, |
|
94 |
obs_vars = names(fit$mkinmod$map), |
|
95 |
xlab = "Time", ylab = "Residue", |
|
96 |
xlim = range(fit$data$time), |
|
97 |
ylim = "default", |
|
98 |
col_obs = 1:length(obs_vars), |
|
99 |
pch_obs = col_obs, |
|
100 |
lty_obs = rep(1, length(obs_vars)), |
|
101 |
add = FALSE, legend = !add, |
|
102 |
show_residuals = FALSE, |
|
103 |
show_errplot = FALSE, |
|
104 |
maxabs = "auto", |
|
105 |
sep_obs = FALSE, rel.height.middle = 0.9, |
|
106 |
row_layout = FALSE, |
|
107 |
lpos = "topright", inset = c(0.05, 0.05), |
|
108 |
show_errmin = FALSE, errmin_digits = 3, |
|
109 |
frame = TRUE, ...) |
|
110 |
{ |
|
111 | 1503x |
if (identical(show_residuals, "standardized")) { |
112 | ! |
show_residuals <- TRUE |
113 | ! |
standardized <- TRUE |
114 |
} else { |
|
115 | 1503x |
standardized <- FALSE |
116 |
} |
|
117 | ||
118 | ! |
if (add && show_residuals) stop("If adding to an existing plot we can not show residuals") |
119 | ! |
if (add && show_errplot) stop("If adding to an existing plot we can not show the error model plot") |
120 | ! |
if (show_residuals && show_errplot) stop("We can either show residuals over time or the error model plot, not both") |
121 | ! |
if (add && sep_obs) stop("If adding to an existing plot we can not show observed variables separately") |
122 | ||
123 | ||
124 | 1503x |
solution_type = fit$solution_type |
125 | 1503x |
parms.all <- c(fit$bparms.optim, fit$bparms.fixed) |
126 | ||
127 | 1503x |
ininames <- c( |
128 | 1503x |
rownames(subset(fit$start, type == "state")), |
129 | 1503x |
rownames(subset(fit$fixed, type == "state"))) |
130 | 1503x |
odeini <- parms.all[ininames] |
131 | ||
132 |
# Order initial state variables |
|
133 | 1503x |
names(odeini) <- sub("_0", "", names(odeini)) |
134 | 1503x |
odeini <- odeini[names(fit$mkinmod$diffs)] |
135 | ||
136 | 1503x |
outtimes <- seq(xlim[1], xlim[2], length.out=100) |
137 | ||
138 | 1503x |
odenames <- c( |
139 | 1503x |
rownames(subset(fit$start, type == "deparm")), |
140 | 1503x |
rownames(subset(fit$fixed, type == "deparm"))) |
141 | 1503x |
odeparms <- parms.all[odenames] |
142 | ||
143 | ||
144 | 1503x |
if (solution_type == "deSolve" & !is.null(fit$mkinmod$cf)) { |
145 | 140x |
fit$mkinmod[["symbols"]] <- deSolve::checkDLL(dllname = fit$mkinmod$dll_info[["name"]], |
146 | 140x |
func = "diffs", initfunc = "initpar", |
147 | 140x |
jacfunc = NULL, nout = 0, outnames = NULL) |
148 |
} |
|
149 | 1503x |
out <- mkinpredict(fit$mkinmod, odeparms, odeini, outtimes, |
150 | 1503x |
solution_type = solution_type, atol = fit$atol, rtol = fit$rtol) |
151 | ||
152 | 1503x |
out <- as.data.frame(out) |
153 | ||
154 | 1503x |
names(col_obs) <- names(pch_obs) <- names(lty_obs) <- obs_vars |
155 | ||
156 |
# Create a plot layout only if not to be added to an existing plot |
|
157 |
# or only a single plot is requested (e.g. by plot.mmkin) |
|
158 | 1503x |
do_layout = FALSE |
159 | 485x |
if (show_residuals | sep_obs | show_errplot) do_layout = TRUE |
160 | 1503x |
n_plot_rows = if (sep_obs) length(obs_vars) else 1 |
161 | ||
162 | 1503x |
if (do_layout) { |
163 |
# Layout should be restored afterwards |
|
164 | 485x |
oldpar <- par(no.readonly = TRUE) |
165 | 485x |
on.exit(par(oldpar, no.readonly = TRUE)) |
166 | ||
167 |
# If the observed variables are shown separately, or if requested, do row layout |
|
168 | 485x |
if (sep_obs | row_layout) { |
169 | 415x |
row_layout <- TRUE |
170 | 415x |
n_plot_cols = if (show_residuals | show_errplot) 2 else 1 |
171 | 415x |
n_plots = n_plot_rows * n_plot_cols |
172 | ||
173 |
# Set relative plot heights, so the first and the last plot are the norm |
|
174 |
# and the middle plots (if n_plot_rows >2) are smaller by rel.height.middle |
|
175 | 415x |
rel.heights <- if (n_plot_rows > 2) c(1, rep(rel.height.middle, n_plot_rows - 2), 1) |
176 | 415x |
else rep(1, n_plot_rows) |
177 | 415x |
layout_matrix = matrix(1:n_plots, |
178 | 415x |
n_plot_rows, n_plot_cols, byrow = TRUE) |
179 | 415x |
layout(layout_matrix, heights = rel.heights) |
180 |
} else { # else show residuals in the lower third to keep compatibility |
|
181 | 70x |
layout(matrix(c(1, 2), 2, 1), heights = c(2, 1.3)) |
182 | 70x |
par(mar = c(3, 4, 4, 2) + 0.1) |
183 |
} |
|
184 |
} |
|
185 | ||
186 |
# Replicate legend position argument if necessary |
|
187 | 1503x |
if (length(lpos) == 1) lpos = rep(lpos, n_plot_rows) |
188 | ||
189 |
# Loop over plot rows |
|
190 | 1503x |
for (plot_row in 1:n_plot_rows) { |
191 | ||
192 | 1503x |
row_obs_vars = if (sep_obs) obs_vars[plot_row] else obs_vars |
193 | ||
194 |
# Set ylim to sensible default, or to the specified value |
|
195 | 1503x |
if (is.list(ylim)) { |
196 | ! |
ylim_row <- ylim[[plot_row]] |
197 |
} else { |
|
198 | 1503x |
if (ylim[[1]] == "default") { |
199 | 1503x |
ylim_row = c(0, max(c(subset(fit$data, variable %in% row_obs_vars)$observed, |
200 | 1503x |
unlist(out[row_obs_vars])), na.rm = TRUE)) |
201 |
} else { |
|
202 | ! |
ylim_row = ylim |
203 |
} |
|
204 |
} |
|
205 | ||
206 | 1503x |
if (row_layout) { |
207 |
# Margins for top row of plots when we have more than one row |
|
208 |
# Reduce bottom margin by 2.1 - hides x axis legend |
|
209 | 415x |
if (plot_row == 1 & n_plot_rows > 1) { |
210 | ! |
par(mar = c(3.0, 4.1, 4.1, 2.1)) |
211 |
} |
|
212 | ||
213 |
# Margins for middle rows of plots, if any |
|
214 | 415x |
if (plot_row > 1 & plot_row < n_plot_rows) { |
215 |
# Reduce top margin by 2 after the first plot as we have no main title, |
|
216 |
# reduced plot height, therefore we need rel.height.middle in the layout |
|
217 | ! |
par(mar = c(3.0, 4.1, 2.1, 2.1)) |
218 |
} |
|
219 | ||
220 |
# Margins for bottom row of plots when we have more than one row |
|
221 | 415x |
if (plot_row == n_plot_rows & n_plot_rows > 1) { |
222 |
# Restore bottom margin for last plot to show x axis legend |
|
223 | ! |
par(mar = c(5.1, 4.1, 2.1, 2.1)) |
224 |
} |
|
225 |
} |
|
226 | ||
227 |
# Set up the main plot if not to be added to an existing plot |
|
228 | 1503x |
if (add == FALSE) { |
229 | 1503x |
plot(0, type="n", |
230 | 1503x |
xlim = xlim, ylim = ylim_row, |
231 | 1503x |
xlab = xlab, ylab = ylab, frame = frame, ...) |
232 |
} |
|
233 | ||
234 |
# Plot the data |
|
235 | 1503x |
for (obs_var in row_obs_vars) { |
236 | 1708x |
points(subset(fit$data, variable == obs_var, c(time, observed)), |
237 | 1708x |
pch = pch_obs[obs_var], col = col_obs[obs_var]) |
238 |
} |
|
239 | ||
240 |
# Plot the model output |
|
241 | 1503x |
matlines(out$time, out[row_obs_vars], col = col_obs[row_obs_vars], lty = lty_obs[row_obs_vars]) |
242 | ||
243 | 1503x |
if (legend == TRUE) { |
244 |
# Get full names from model definition if they are available |
|
245 | 695x |
legend_names = lapply(row_obs_vars, function(x) { |
246 | 900x |
if (!is.null(fit$mkinmod$spec[[x]]$full_name)) |
247 | 410x |
if (is.na(fit$mkinmod$spec[[x]]$full_name)) x |
248 | ! |
else fit$mkinmod$spec[[x]]$full_name |
249 | 490x |
else x |
250 |
}) |
|
251 | 695x |
legend(lpos[plot_row], inset= inset, legend = legend_names, |
252 | 695x |
col = col_obs[row_obs_vars], pch = pch_obs[row_obs_vars], lty = lty_obs[row_obs_vars]) |
253 |
} |
|
254 | ||
255 |
# Show chi2 error value if requested |
|
256 | 1503x |
if (show_errmin) { |
257 | 70x |
if (length(row_obs_vars) == 1) { |
258 | 70x |
errmin_var = row_obs_vars |
259 |
} else { |
|
260 | ! |
errmin_var = "All data" |
261 | ! |
if (length(row_obs_vars) != length(fit$mkinmod$map)) { |
262 | ! |
warning("Showing chi2 error level for all data, but only ", |
263 | ! |
row_obs_vars, " were selected for plotting") |
264 |
} |
|
265 |
} |
|
266 | ||
267 | 70x |
chi2 <- signif(100 * mkinerrmin(fit)[errmin_var, "err.min"], errmin_digits) |
268 |
# Use LateX if the current plotting device is tikz |
|
269 | 70x |
if (names(dev.cur()) == "tikz output") { |
270 | ! |
chi2_text <- paste0("$\\chi^2$ error level = ", chi2, "\\%") |
271 |
} else { |
|
272 | 70x |
chi2_perc <- paste0(chi2, "%") |
273 | 70x |
chi2_text <- bquote(chi^2 ~ "error level" == .(chi2_perc)) |
274 |
} |
|
275 | 70x |
mtext(chi2_text, cex = 0.7, line = 0.4) |
276 |
} |
|
277 | ||
278 | 1503x |
if (do_layout & !row_layout) { |
279 | 70x |
par(mar = c(5, 4, 0, 2) + 0.1) |
280 |
} |
|
281 | ||
282 |
# Show residuals if requested |
|
283 | 1503x |
if (show_residuals) { |
284 | 280x |
mkinresplot(fit, obs_vars = row_obs_vars, standardized = standardized, |
285 | 280x |
pch_obs = pch_obs[row_obs_vars], col_obs = col_obs[row_obs_vars], |
286 | 280x |
legend = FALSE, frame = frame, xlab = xlab, xlim = xlim, maxabs = maxabs) |
287 |
} |
|
288 | ||
289 |
# Show error model plot if requested |
|
290 | 1503x |
if (show_errplot) { |
291 | 205x |
mkinerrplot(fit, obs_vars = row_obs_vars, |
292 | 205x |
pch_obs = pch_obs[row_obs_vars], col_obs = col_obs[row_obs_vars], |
293 | 205x |
legend = FALSE, frame = frame) |
294 |
} |
|
295 |
} |
|
296 |
} |
|
297 | ||
298 |
#' @rdname plot.mkinfit |
|
299 |
#' @export |
|
300 |
plot_sep <- function(fit, show_errmin = TRUE, |
|
301 |
show_residuals = ifelse(identical(fit$err_mod, "const"), TRUE, "standardized"), ...) { |
|
302 | 70x |
plot.mkinfit(fit, sep_obs = TRUE, show_residuals = show_residuals, |
303 | 70x |
show_errmin = show_errmin, ...) |
304 |
} |
|
305 | ||
306 |
#' @rdname plot.mkinfit |
|
307 |
#' @export |
|
308 |
plot_res <- function(fit, sep_obs = FALSE, show_errmin = sep_obs, |
|
309 |
standardized = ifelse(identical(fit$err_mod, "const"), FALSE, TRUE), ...) |
|
310 |
{ |
|
311 | 140x |
plot.mkinfit(fit, sep_obs = sep_obs, show_errmin = show_errmin, |
312 | 140x |
show_residuals = ifelse(standardized, "standardized", TRUE), |
313 | 140x |
row_layout = TRUE, ...) |
314 |
} |
|
315 | ||
316 |
#' @rdname plot.mkinfit |
|
317 |
#' @export |
|
318 |
plot_err <- function(fit, sep_obs = FALSE, show_errmin = sep_obs, ...) { |
|
319 | 205x |
plot.mkinfit(fit, sep_obs = sep_obs, show_errmin = show_errmin, |
320 | 205x |
show_errplot = TRUE, row_layout = TRUE, ...) |
321 |
} |
|
322 | ||
323 |
#' Plot the observed data and the fitted model of an mkinfit object |
|
324 |
#' |
|
325 |
#' Deprecated function. It now only calls the plot method |
|
326 |
#' \code{\link{plot.mkinfit}}. |
|
327 |
#' |
|
328 |
#' @param fit an object of class \code{\link{mkinfit}}. |
|
329 |
#' @param \dots further arguments passed to \code{\link{plot.mkinfit}}. |
|
330 |
#' @return The function is called for its side effect. |
|
331 |
#' @author Johannes Ranke |
|
332 |
#' @export |
|
333 |
mkinplot <- function(fit, ...) |
|
334 |
{ |
|
335 | ! |
plot(fit, ...) |
336 |
} |
1 |
#' Create a mixed effects model from an mmkin row object |
|
2 |
#' |
|
3 |
#' @importFrom rlang !!! |
|
4 |
#' @param object An [mmkin] row object |
|
5 |
#' @param method The method to be used |
|
6 |
#' @param \dots Currently not used |
|
7 |
#' @return An object of class 'mixed.mmkin' which has the observed data in a |
|
8 |
#' single dataframe which is convenient for plotting |
|
9 |
#' @examples |
|
10 |
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
11 |
#' n_biphasic <- 8 |
|
12 |
#' err_1 = list(const = 1, prop = 0.07) |
|
13 |
#' |
|
14 |
#' DFOP_SFO <- mkinmod( |
|
15 |
#' parent = mkinsub("DFOP", "m1"), |
|
16 |
#' m1 = mkinsub("SFO"), |
|
17 |
#' quiet = TRUE) |
|
18 |
#' |
|
19 |
#' set.seed(123456) |
|
20 |
#' log_sd <- 0.3 |
|
21 |
#' syn_biphasic_parms <- as.matrix(data.frame( |
|
22 |
#' k1 = rlnorm(n_biphasic, log(0.05), log_sd), |
|
23 |
#' k2 = rlnorm(n_biphasic, log(0.01), log_sd), |
|
24 |
#' g = plogis(rnorm(n_biphasic, 0, log_sd)), |
|
25 |
#' f_parent_to_m1 = plogis(rnorm(n_biphasic, 0, log_sd)), |
|
26 |
#' k_m1 = rlnorm(n_biphasic, log(0.002), log_sd))) |
|
27 |
#' |
|
28 |
#' ds_biphasic_mean <- lapply(1:n_biphasic, |
|
29 |
#' function(i) { |
|
30 |
#' mkinpredict(DFOP_SFO, syn_biphasic_parms[i, ], |
|
31 |
#' c(parent = 100, m1 = 0), sampling_times) |
|
32 |
#' } |
|
33 |
#' ) |
|
34 |
#' |
|
35 |
#' set.seed(123456L) |
|
36 |
#' ds_biphasic <- lapply(ds_biphasic_mean, function(ds) { |
|
37 |
#' add_err(ds, |
|
38 |
#' sdfunc = function(value) sqrt(err_1$const^2 + value^2 * err_1$prop^2), |
|
39 |
#' n = 1, secondary = "m1")[[1]] |
|
40 |
#' }) |
|
41 |
#' |
|
42 |
#' \dontrun{ |
|
43 |
#' f_mmkin <- mmkin(list("DFOP-SFO" = DFOP_SFO), ds_biphasic, error_model = "tc", quiet = TRUE) |
|
44 |
#' |
|
45 |
#' f_mixed <- mixed(f_mmkin) |
|
46 |
#' print(f_mixed) |
|
47 |
#' plot(f_mixed) |
|
48 |
#' } |
|
49 |
#' @export |
|
50 |
mixed <- function(object, ...) { |
|
51 | 182x |
UseMethod("mixed") |
52 |
} |
|
53 | ||
54 |
#' @export |
|
55 |
#' @rdname mixed |
|
56 |
mixed.mmkin <- function(object, method = c("none"), ...) { |
|
57 | ! |
if (nrow(object) > 1) stop("Only row objects allowed") |
58 | ||
59 | 182x |
method <- match.arg(method) |
60 | ||
61 | 182x |
ds_names <- colnames(object) |
62 | 182x |
res <- list(mmkin = object, mkinmod = object[[1]]$mkinmod) |
63 | ||
64 | 182x |
if (method[1] == "none") { |
65 | 182x |
ds_list <- lapply(object, |
66 | 182x |
function(x) x$data[c("variable", "time", "observed", "predicted", "residual")]) |
67 | ||
68 | 182x |
names(ds_list) <- ds_names |
69 | 182x |
res$data <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds") |
70 | 182x |
names(res$data)[1:4] <- c("ds", "name", "time", "value") |
71 | 182x |
res$data$name <- as.character(res$data$name) |
72 | 182x |
res$data$ds <- ordered(res$data$ds, levels = unique(res$data$ds)) |
73 | 182x |
standardized <- unlist(lapply(object, residuals, standardized = TRUE)) |
74 | 182x |
res$data$std <- res$data$residual / standardized |
75 | 182x |
res$data$standardized <- standardized |
76 | ||
77 | 182x |
class(res) <- c("mixed.mmkin") |
78 | 182x |
return(res) |
79 |
} |
|
80 |
} |
|
81 | ||
82 |
#' @export |
|
83 |
#' @rdname mixed |
|
84 |
#' @param x A mixed.mmkin object to print |
|
85 |
#' @param digits Number of digits to use for printing. |
|
86 |
print.mixed.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { |
|
87 | 117x |
cat("Kinetic model fitted by nonlinear regression to each dataset" ) |
88 | 117x |
cat("\nStructural model:\n") |
89 | 117x |
diffs <- x$mmkin[[1]]$mkinmod$diffs |
90 | 117x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs) |
91 | 117x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
92 | 117x |
cat("\nData:\n") |
93 | 117x |
cat(nrow(x$data), "observations of", |
94 | 117x |
length(unique(x$data$name)), "variable(s) grouped in", |
95 | 117x |
length(unique(x$data$ds)), "datasets\n\n") |
96 | ||
97 | 117x |
print(x$mmkin, digits = digits) |
98 | ||
99 | 117x |
cat("\nMean fitted parameters:\n") |
100 | 117x |
print(mean_degparms(x$mmkin), digits = digits) |
101 | ||
102 | 117x |
invisible(x) |
103 |
} |
1 |
#' Extract model parameters |
|
2 |
#' |
|
3 |
#' This function returns degradation model parameters as well as error |
|
4 |
#' model parameters per default, in order to avoid working with a fitted model |
|
5 |
#' without considering the error structure that was assumed for the fit. |
|
6 |
#' |
|
7 |
#' @param object A fitted model object. |
|
8 |
#' @param \dots Not used |
|
9 |
#' @return Depending on the object, a numeric vector of fitted model parameters, |
|
10 |
#' a matrix (e.g. for mmkin row objects), or a list of matrices (e.g. for |
|
11 |
#' mmkin objects with more than one row). |
|
12 |
#' @seealso [saem], [multistart] |
|
13 |
#' @examples |
|
14 |
#' # mkinfit objects |
|
15 |
#' fit <- mkinfit("SFO", FOCUS_2006_C, quiet = TRUE) |
|
16 |
#' parms(fit) |
|
17 |
#' parms(fit, transformed = TRUE) |
|
18 |
#' |
|
19 |
#' # mmkin objects |
|
20 |
#' ds <- lapply(experimental_data_for_UBA_2019[6:10], |
|
21 |
#' function(x) subset(x$data[c("name", "time", "value")])) |
|
22 |
#' names(ds) <- paste("Dataset", 6:10) |
|
23 |
#' \dontrun{ |
|
24 |
#' fits <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE, cores = 1) |
|
25 |
#' parms(fits["SFO", ]) |
|
26 |
#' parms(fits[, 2]) |
|
27 |
#' parms(fits) |
|
28 |
#' parms(fits, transformed = TRUE) |
|
29 |
#' } |
|
30 |
#' @export |
|
31 |
parms <- function(object, ...) |
|
32 |
{ |
|
33 | 91384x |
UseMethod("parms", object) |
34 |
} |
|
35 | ||
36 |
#' @param transformed Should the parameters be returned as used internally |
|
37 |
#' during the optimisation? |
|
38 |
#' @param errparms Should the error model parameters be returned |
|
39 |
#' in addition to the degradation parameters? |
|
40 |
#' @rdname parms |
|
41 |
#' @export |
|
42 |
parms.mkinfit <- function(object, transformed = FALSE, errparms = TRUE, ...) |
|
43 |
{ |
|
44 | 88039x |
res <- if (transformed) object$par |
45 | 88039x |
else c(object$bparms.optim, object$errparms) |
46 | 88039x |
if (!errparms) { |
47 | 3000x |
res[setdiff(names(res), names(object$errparms))] |
48 |
} |
|
49 | 85039x |
else return(res) |
50 |
} |
|
51 | ||
52 |
#' @rdname parms |
|
53 |
#' @export |
|
54 |
parms.mmkin <- function(object, transformed = FALSE, errparms = TRUE, ...) |
|
55 |
{ |
|
56 | 265x |
if (nrow(object) == 1) { |
57 | 265x |
res <- sapply(object, parms, transformed = transformed, |
58 | 265x |
errparms = errparms, ...) |
59 | 265x |
colnames(res) <- colnames(object) |
60 |
} else { |
|
61 | ! |
res <- list() |
62 | ! |
for (i in 1:nrow(object)) { |
63 | ! |
res[[i]] <- parms(object[i, ], transformed = transformed, |
64 | ! |
errparms = errparms, ...) |
65 |
} |
|
66 | ! |
names(res) <- rownames(object) |
67 |
} |
|
68 | 265x |
return(res) |
69 |
} |
|
70 | ||
71 |
#' @param exclude_failed For [multistart] objects, should rows for failed fits |
|
72 |
#' be removed from the returned parameter matrix? |
|
73 |
#' @rdname parms |
|
74 |
#' @export |
|
75 |
parms.multistart <- function(object, exclude_failed = TRUE, ...) { |
|
76 | 176x |
res <- t(sapply(object, parms)) |
77 | 176x |
successful <- which(!is.na(res[, 1])) |
78 | 176x |
first_success <- successful[1] |
79 | 176x |
colnames(res) <- names(parms(object[[first_success]])) |
80 | ! |
if (exclude_failed[1]) res <- res[successful, ] |
81 | 176x |
return(res) |
82 |
} |
1 |
#' Fit one or more kinetic models with one or more state variables to one or |
|
2 |
#' more datasets |
|
3 |
#' |
|
4 |
#' This function calls \code{\link{mkinfit}} on all combinations of models and |
|
5 |
#' datasets specified in its first two arguments. |
|
6 |
#' |
|
7 |
#' @param models Either a character vector of shorthand names like |
|
8 |
#' \code{c("SFO", "FOMC", "DFOP", "HS", "SFORB")}, or an optionally named |
|
9 |
#' list of \code{\link{mkinmod}} objects. |
|
10 |
#' @param datasets An optionally named list of datasets suitable as observed |
|
11 |
#' data for \code{\link{mkinfit}}. |
|
12 |
#' @param cores The number of cores to be used for multicore processing. This |
|
13 |
#' is only used when the \code{cluster} argument is \code{NULL}. On Windows |
|
14 |
#' machines, cores > 1 is not supported, you need to use the \code{cluster} |
|
15 |
#' argument to use multiple logical processors. Per default, all cores |
|
16 |
#' detected by [parallel::detectCores()] are used, except on Windows where |
|
17 |
#' the default is 1. |
|
18 |
#' @param cluster A cluster as returned by \code{\link{makeCluster}} to be used |
|
19 |
#' for parallel execution. |
|
20 |
#' @param \dots Further arguments that will be passed to \code{\link{mkinfit}}. |
|
21 |
#' @importFrom parallel mclapply parLapply detectCores |
|
22 |
#' @return A two-dimensional \code{\link{array}} of \code{\link{mkinfit}} |
|
23 |
#' objects and/or try-errors that can be indexed using the model names for the |
|
24 |
#' first index (row index) and the dataset names for the second index (column |
|
25 |
#' index). |
|
26 |
#' @author Johannes Ranke |
|
27 |
#' @seealso \code{\link{[.mmkin}} for subsetting, \code{\link{plot.mmkin}} for |
|
28 |
#' plotting. |
|
29 |
#' @keywords optimize |
|
30 |
#' @examples |
|
31 |
#' |
|
32 |
#' \dontrun{ |
|
33 |
#' m_synth_SFO_lin <- mkinmod(parent = mkinsub("SFO", "M1"), |
|
34 |
#' M1 = mkinsub("SFO", "M2"), |
|
35 |
#' M2 = mkinsub("SFO"), use_of_ff = "max") |
|
36 |
#' |
|
37 |
#' m_synth_FOMC_lin <- mkinmod(parent = mkinsub("FOMC", "M1"), |
|
38 |
#' M1 = mkinsub("SFO", "M2"), |
|
39 |
#' M2 = mkinsub("SFO"), use_of_ff = "max") |
|
40 |
#' |
|
41 |
#' models <- list(SFO_lin = m_synth_SFO_lin, FOMC_lin = m_synth_FOMC_lin) |
|
42 |
#' datasets <- lapply(synthetic_data_for_UBA_2014[1:3], function(x) x$data) |
|
43 |
#' names(datasets) <- paste("Dataset", 1:3) |
|
44 |
#' |
|
45 |
#' time_default <- system.time(fits.0 <- mmkin(models, datasets, quiet = TRUE)) |
|
46 |
#' time_1 <- system.time(fits.4 <- mmkin(models, datasets, cores = 1, quiet = TRUE)) |
|
47 |
#' |
|
48 |
#' time_default |
|
49 |
#' time_1 |
|
50 |
#' |
|
51 |
#' endpoints(fits.0[["SFO_lin", 2]]) |
|
52 |
#' |
|
53 |
#' # plot.mkinfit handles rows or columns of mmkin result objects |
|
54 |
#' plot(fits.0[1, ]) |
|
55 |
#' plot(fits.0[1, ], obs_var = c("M1", "M2")) |
|
56 |
#' plot(fits.0[, 1]) |
|
57 |
#' # Use double brackets to extract a single mkinfit object, which will be plotted |
|
58 |
#' # by plot.mkinfit and can be plotted using plot_sep |
|
59 |
#' plot(fits.0[[1, 1]], sep_obs = TRUE, show_residuals = TRUE, show_errmin = TRUE) |
|
60 |
#' plot_sep(fits.0[[1, 1]]) |
|
61 |
#' # Plotting with mmkin (single brackets, extracting an mmkin object) does not |
|
62 |
#' # allow to plot the observed variables separately |
|
63 |
#' plot(fits.0[1, 1]) |
|
64 |
#' |
|
65 |
#' # On Windows, we can use multiple cores by making a cluster first |
|
66 |
#' cl <- parallel::makePSOCKcluster(12) |
|
67 |
#' f <- mmkin(c("SFO", "FOMC", "DFOP"), |
|
68 |
#' list(A = FOCUS_2006_A, B = FOCUS_2006_B, C = FOCUS_2006_C, D = FOCUS_2006_D), |
|
69 |
#' cluster = cl, quiet = TRUE) |
|
70 |
#' print(f) |
|
71 |
#' # We get false convergence for the FOMC fit to FOCUS_2006_A because this |
|
72 |
#' # dataset is really SFO, and the FOMC fit is overparameterised |
|
73 |
#' parallel::stopCluster(cl) |
|
74 |
#' } |
|
75 |
#' |
|
76 |
#' @export mmkin |
|
77 |
mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets, |
|
78 |
cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), cluster = NULL, ...) |
|
79 |
{ |
|
80 | 4032x |
call <- match.call() |
81 | 4032x |
parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE", "logistic") |
82 | 4032x |
n.m <- length(models) |
83 | 4032x |
n.d <- length(datasets) |
84 | 4032x |
n.fits <- n.m * n.d |
85 | 4032x |
fit_indices <- matrix(1:n.fits, ncol = n.d) |
86 | ||
87 |
# Check models and define their names |
|
88 | 4032x |
if (!all(sapply(models, function(x) inherits(x, "mkinmod")))) { |
89 | 2323x |
if (!all(models %in% parent_models_available)) { |
90 | 50x |
stop("Please supply models as a list of mkinmod objects or a vector combined of\n ", |
91 | 50x |
paste(parent_models_available, collapse = ", ")) |
92 |
} else { |
|
93 | 2273x |
names(models) <- models |
94 |
} |
|
95 |
} else { |
|
96 | 1087x |
if (is.null(names(models))) names(models) <- as.character(1:n.m) |
97 |
} |
|
98 | ||
99 |
# Check datasets and define their names |
|
100 | 1575x |
if (is.null(names(datasets))) names(datasets) <- as.character(1:n.d) |
101 | ||
102 |
# Define names for fit index |
|
103 | 3982x |
dimnames(fit_indices) <- list(model = names(models), |
104 | 3982x |
dataset = names(datasets)) |
105 | ||
106 | ||
107 | 3982x |
fit_function <- function(fit_index) { |
108 | 793x |
w <- which(fit_indices == fit_index, arr.ind = TRUE) |
109 | 793x |
model_index <- w[1] |
110 | 793x |
dataset_index <- w[2] |
111 | 793x |
res <- try(mkinfit(models[[model_index]], datasets[[dataset_index]], ...)) |
112 | 793x |
if (!inherits(res, "try-error")) res$mkinmod$name <- names(models)[model_index] |
113 | 793x |
return(res) |
114 |
} |
|
115 | ||
116 | 3982x |
fit_time <- system.time({ |
117 | 3982x |
if (is.null(cluster)) { |
118 | 2154x |
results <- parallel::mclapply(as.list(1:n.fits), fit_function, |
119 | 2154x |
mc.cores = cores, mc.preschedule = FALSE) |
120 |
} else { |
|
121 | 1828x |
results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function) |
122 |
} |
|
123 |
}) |
|
124 | ||
125 | 3798x |
attributes(results) <- attributes(fit_indices) |
126 | 3798x |
attr(results, "call") <- call |
127 | 3798x |
attr(results, "time") <- fit_time |
128 | 3798x |
class(results) <- "mmkin" |
129 | 3798x |
return(results) |
130 |
} |
|
131 | ||
132 |
#' Subsetting method for mmkin objects |
|
133 |
#' |
|
134 |
#' @param x An \code{\link{mmkin} object} |
|
135 |
#' @param i Row index selecting the fits for specific models |
|
136 |
#' @param j Column index selecting the fits to specific datasets |
|
137 |
#' @param ... Not used, only there to satisfy the generic method definition |
|
138 |
#' @param drop If FALSE, the method always returns an mmkin object, otherwise |
|
139 |
#' either a list of mkinfit objects or a single mkinfit object. |
|
140 |
#' @return An object of class \code{\link{mmkin}}. |
|
141 |
#' @author Johannes Ranke |
|
142 |
#' @rdname Extract.mmkin |
|
143 |
#' @examples |
|
144 |
#' |
|
145 |
#' # Only use one core, to pass R CMD check --as-cran |
|
146 |
#' fits <- mmkin(c("SFO", "FOMC"), list(B = FOCUS_2006_B, C = FOCUS_2006_C), |
|
147 |
#' cores = 1, quiet = TRUE) |
|
148 |
#' fits["FOMC", ] |
|
149 |
#' fits[, "B"] |
|
150 |
#' fits["SFO", "B"] |
|
151 |
#' |
|
152 |
#' head( |
|
153 |
#' # This extracts an mkinfit object with lots of components |
|
154 |
#' fits[["FOMC", "B"]] |
|
155 |
#' ) |
|
156 |
#' @export |
|
157 |
`[.mmkin` <- function(x, i, j, ..., drop = FALSE) { |
|
158 | 2760x |
class(x) <- NULL |
159 | 2760x |
x_sub <- x[i, j, drop = drop] |
160 | 2760x |
if (!drop) class(x_sub) <- "mmkin" |
161 | 2760x |
return(x_sub) |
162 |
} |
|
163 | ||
164 |
#' Print method for mmkin objects |
|
165 |
#' |
|
166 |
#' @param x An [mmkin] object. |
|
167 |
#' @param \dots Not used. |
|
168 |
#' @rdname mmkin |
|
169 |
#' @export |
|
170 |
print.mmkin <- function(x, ...) { |
|
171 | 375x |
cat("<mmkin> object\n") |
172 | 375x |
cat("Status of individual fits:\n\n") |
173 | 375x |
print(status(x)) |
174 |
} |
|
175 | ||
176 |
#' @export |
|
177 |
update.mmkin <- function(object, ..., evaluate = TRUE) |
|
178 |
{ |
|
179 | 256x |
call <- attr(object, "call") |
180 | ||
181 | 256x |
update_arguments <- match.call(expand.dots = FALSE)$... |
182 | ||
183 | 256x |
if (length(update_arguments) > 0) { |
184 | 256x |
update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) |
185 |
} |
|
186 | ||
187 | 256x |
for (a in names(update_arguments)[update_arguments_in_call]) { |
188 | 115x |
call[[a]] <- update_arguments[[a]] |
189 |
} |
|
190 | ||
191 | 256x |
update_arguments_not_in_call <- !update_arguments_in_call |
192 | 256x |
if(any(update_arguments_not_in_call)) { |
193 | 206x |
call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) |
194 | 206x |
call <- as.call(call) |
195 |
} |
|
196 | ||
197 | 256x |
if(evaluate) eval(call, parent.frame()) |
198 | ! |
else call |
199 |
} |
1 |
#' Produce predictions from a kinetic model using specific parameters |
|
2 |
#' |
|
3 |
#' This function produces a time series for all the observed variables in a |
|
4 |
#' kinetic model as specified by [mkinmod], using a specific set of |
|
5 |
#' kinetic parameters and initial values for the state variables. |
|
6 |
#' |
|
7 |
#' @aliases mkinpredict mkinpredict.mkinmod mkinpredict.mkinfit |
|
8 |
#' @param x A kinetic model as produced by [mkinmod], or a kinetic fit as |
|
9 |
#' fitted by [mkinfit]. In the latter case, the fitted parameters are used for |
|
10 |
#' the prediction. |
|
11 |
#' @param odeparms A numeric vector specifying the parameters used in the |
|
12 |
#' kinetic model, which is generally defined as a set of ordinary differential |
|
13 |
#' equations. |
|
14 |
#' @param odeini A numeric vector containing the initial values of the state |
|
15 |
#' variables of the model. Note that the state variables can differ from the |
|
16 |
#' observed variables, for example in the case of the SFORB model. |
|
17 |
#' @param outtimes A numeric vector specifying the time points for which model |
|
18 |
#' predictions should be generated. |
|
19 |
#' @param solution_type The method that should be used for producing the |
|
20 |
#' predictions. This should generally be "analytical" if there is only one |
|
21 |
#' observed variable, and usually "deSolve" in the case of several observed |
|
22 |
#' variables. The third possibility "eigen" is fast in comparison to uncompiled |
|
23 |
#' ODE models, but not applicable to some models, e.g. using FOMC for the |
|
24 |
#' parent compound. |
|
25 |
#' @param method.ode The solution method passed via [mkinpredict] to [ode]] in |
|
26 |
#' case the solution type is "deSolve" and we are not using compiled code. |
|
27 |
#' When using compiled code, only lsoda is supported. |
|
28 |
#' @param use_compiled If set to \code{FALSE}, no compiled version of the |
|
29 |
#' [mkinmod] model is used, even if is present. |
|
30 |
#' @param use_symbols If set to \code{TRUE} (default), symbol info present in |
|
31 |
#' the [mkinmod] object is used if available for accessing compiled code |
|
32 |
#' @param atol Absolute error tolerance, passed to the ode solver. |
|
33 |
#' @param rtol Absolute error tolerance, passed to the ode solver. |
|
34 |
#' @param maxsteps Maximum number of steps, passed to the ode solver. |
|
35 |
#' @param map_output Boolean to specify if the output should list values for |
|
36 |
#' the observed variables (default) or for all state variables (if set to |
|
37 |
#' FALSE). Setting this to FALSE has no effect for analytical solutions, |
|
38 |
#' as these always return mapped output. |
|
39 |
#' @param na_stop Should it be an error if [ode] returns NaN values |
|
40 |
#' @param \dots Further arguments passed to the ode solver in case such a |
|
41 |
#' solver is used. |
|
42 |
#' @return A matrix with the numeric solution in wide format |
|
43 |
#' @author Johannes Ranke |
|
44 |
#' @examples |
|
45 |
#' |
|
46 |
#' SFO <- mkinmod(degradinol = mkinsub("SFO")) |
|
47 |
#' # Compare solution types |
|
48 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
49 |
#' solution_type = "analytical") |
|
50 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
51 |
#' solution_type = "deSolve") |
|
52 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
53 |
#' solution_type = "deSolve", use_compiled = FALSE) |
|
54 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
55 |
#' solution_type = "eigen") |
|
56 |
#' |
|
57 |
#' # Compare integration methods to analytical solution |
|
58 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
59 |
#' solution_type = "analytical")[21,] |
|
60 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
61 |
#' method = "lsoda", use_compiled = FALSE)[21,] |
|
62 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
63 |
#' method = "ode45", use_compiled = FALSE)[21,] |
|
64 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, |
|
65 |
#' method = "rk4", use_compiled = FALSE)[21,] |
|
66 |
#' # rk4 is not as precise here |
|
67 |
#' |
|
68 |
#' # The number of output times used to make a lot of difference until the |
|
69 |
#' # default for atol was adjusted |
|
70 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), |
|
71 |
#' seq(0, 20, by = 0.1))[201,] |
|
72 |
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), |
|
73 |
#' seq(0, 20, by = 0.01))[2001,] |
|
74 |
#' |
|
75 |
#' # Comparison of the performance of solution types |
|
76 |
#' SFO_SFO = mkinmod(parent = list(type = "SFO", to = "m1"), |
|
77 |
#' m1 = list(type = "SFO"), use_of_ff = "max") |
|
78 |
#' if(require(rbenchmark)) { |
|
79 |
#' benchmark(replications = 10, order = "relative", columns = c("test", "relative", "elapsed"), |
|
80 |
#' eigen = mkinpredict(SFO_SFO, |
|
81 |
#' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), |
|
82 |
#' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), |
|
83 |
#' solution_type = "eigen")[201,], |
|
84 |
#' deSolve_compiled = mkinpredict(SFO_SFO, |
|
85 |
#' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), |
|
86 |
#' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), |
|
87 |
#' solution_type = "deSolve")[201,], |
|
88 |
#' deSolve = mkinpredict(SFO_SFO, |
|
89 |
#' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), |
|
90 |
#' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), |
|
91 |
#' solution_type = "deSolve", use_compiled = FALSE)[201,], |
|
92 |
#' analytical = mkinpredict(SFO_SFO, |
|
93 |
#' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), |
|
94 |
#' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), |
|
95 |
#' solution_type = "analytical", use_compiled = FALSE)[201,]) |
|
96 |
#' } |
|
97 |
#' |
|
98 |
#' \dontrun{ |
|
99 |
#' # Predict from a fitted model |
|
100 |
#' f <- mkinfit(SFO_SFO, FOCUS_2006_C, quiet = TRUE) |
|
101 |
#' f <- mkinfit(SFO_SFO, FOCUS_2006_C, quiet = TRUE, solution_type = "deSolve") |
|
102 |
#' head(mkinpredict(f)) |
|
103 |
#' } |
|
104 |
#' |
|
105 |
#' @export |
|
106 |
mkinpredict <- function(x, odeparms, odeini, outtimes, ...) |
|
107 |
{ |
|
108 | 47544878x |
UseMethod("mkinpredict", x) |
109 |
} |
|
110 | ||
111 |
#' @rdname mkinpredict |
|
112 |
#' @export |
|
113 |
mkinpredict.mkinmod <- function(x, |
|
114 |
odeparms = c(k_parent_sink = 0.1), |
|
115 |
odeini = c(parent = 100), |
|
116 |
outtimes = seq(0, 120, by = 0.1), |
|
117 |
solution_type = "deSolve", |
|
118 |
use_compiled = "auto", |
|
119 |
use_symbols = FALSE, |
|
120 |
method.ode = "lsoda", atol = 1e-8, rtol = 1e-10, maxsteps = 20000L, |
|
121 |
map_output = TRUE, |
|
122 |
na_stop = TRUE, |
|
123 |
...) |
|
124 |
{ |
|
125 | ||
126 |
# Names of state variables and observed variables |
|
127 | 47544878x |
mod_vars <- names(x$diffs) |
128 | 47544878x |
obs_vars <- names(x$spec) |
129 | ||
130 |
# Order the inital values for state variables if they are named |
|
131 | 47544878x |
if (!is.null(names(odeini))) { |
132 | 47544878x |
odeini <- odeini[mod_vars] |
133 |
} |
|
134 | ||
135 | 47544878x |
out_obs <- matrix(NA, nrow = length(outtimes), ncol = 1 + length(obs_vars), |
136 | 47544878x |
dimnames = list(as.character(outtimes), c("time", obs_vars))) |
137 | 47544878x |
out_obs[, "time"] <- outtimes |
138 | ||
139 | 47544878x |
n_out_na <- 0 # to check if we get NA values with deSolve |
140 | ||
141 | 47544878x |
if (solution_type == "analytical") { |
142 |
# This is clumsy, as we wanted fast analytical predictions for mkinfit, |
|
143 |
# which bypasses mkinpredict in the case of analytical solutions |
|
144 | 1843695x |
pseudo_observed <- |
145 | 1843695x |
data.frame(name = rep(obs_vars, each = length(outtimes)), |
146 | 1843695x |
time = rep(outtimes, length(obs_vars))) |
147 | 1843695x |
pseudo_observed$predicted <- x$deg_func(pseudo_observed, odeini, odeparms) |
148 | 1843695x |
for (obs_var in obs_vars) { |
149 | 2431585x |
out_obs[, obs_var] <- pseudo_observed[pseudo_observed$name == obs_var, "predicted"] |
150 |
} |
|
151 |
# We don't have solutions for unobserved state variables, the output of |
|
152 |
# analytical solutions is always mapped to observed variables |
|
153 | 1843695x |
return(out_obs) |
154 |
} |
|
155 | ||
156 | 45701183x |
if (solution_type == "eigen") { |
157 | 97082x |
evalparse <- function(string) { |
158 | 392283x |
eval(parse(text=string), as.list(c(odeparms, odeini))) |
159 |
} |
|
160 | ||
161 | 97082x |
coefmat.num <- matrix(sapply(as.vector(x$coefmat), evalparse), |
162 | 97082x |
nrow = length(mod_vars)) |
163 | 97082x |
e <- eigen(coefmat.num) |
164 | 97082x |
c <- solve(e$vectors, odeini) |
165 | 97082x |
f.out <- function(t) { |
166 | 1085040x |
e$vectors %*% diag(exp(e$values * t), nrow=length(mod_vars)) %*% c |
167 |
} |
|
168 | 97082x |
o <- matrix(mapply(f.out, outtimes), |
169 | 97082x |
nrow = length(mod_vars), ncol = length(outtimes)) |
170 | 97082x |
out <- cbind(outtimes, t(o)) |
171 | 97082x |
colnames(out) <- c("time", mod_vars) |
172 |
} |
|
173 | ||
174 | 45701183x |
if (solution_type == "deSolve") { |
175 | 45604101x |
if (!is.null(x$cf) & use_compiled[1] != FALSE) { |
176 | ||
177 | 45603235x |
if (!is.null(x$symbols) & use_symbols) { |
178 | 1427314x |
lsoda_func <- x$symbols |
179 |
} else { |
|
180 | 44175921x |
lsoda_func <- "diffs" |
181 |
} |
|
182 | ||
183 | 45603235x |
out <- deSolve::lsoda( |
184 | 45603235x |
y = odeini, |
185 | 45603235x |
times = outtimes, |
186 | 45603235x |
func = lsoda_func, |
187 | 45603235x |
initfunc = "initpar", |
188 | 45603235x |
dllname = x$dll_info[["name"]], |
189 | 45603235x |
parms = odeparms[x$parms], # Order matters when using compiled models |
190 | 45603235x |
atol = atol, |
191 | 45603235x |
rtol = rtol, |
192 | 45603235x |
maxsteps = maxsteps, |
193 |
... |
|
194 |
) |
|
195 | ||
196 | 45603235x |
colnames(out) <- c("time", mod_vars) |
197 |
} else { |
|
198 | 866x |
mkindiff <- function(t, state, parms) { |
199 | ||
200 | 145229x |
time <- t |
201 | 145229x |
diffs <- vector() |
202 | 145229x |
for (box in names(x$diffs)) |
203 |
{ |
|
204 | 145229x |
diffname <- paste("d", box, sep="_") |
205 | 145229x |
diffs[diffname] <- with(as.list(c(time, state, parms)), |
206 | 145229x |
eval(parse(text=x$diffs[[box]]))) |
207 |
} |
|
208 | 145229x |
return(list(c(diffs))) |
209 |
} |
|
210 | 866x |
out <- deSolve::ode( |
211 | 866x |
y = odeini, |
212 | 866x |
times = outtimes, |
213 | 866x |
func = mkindiff, |
214 | 866x |
parms = odeparms, |
215 | 866x |
method = method.ode, |
216 | 866x |
atol = atol, |
217 | 866x |
rtol = rtol, |
218 | 866x |
maxsteps = maxsteps, |
219 |
... |
|
220 |
) |
|
221 |
} |
|
222 | 45604101x |
n_out_na <- sum(is.na(out)) |
223 | 45604101x |
if (n_out_na > 0 & na_stop) { |
224 | ! |
cat("odeini:\n") |
225 | ! |
print(odeini) |
226 | ! |
cat("odeparms:\n") |
227 | ! |
print(odeparms) |
228 | ! |
cat("out:\n") |
229 | ! |
print(out) |
230 | ! |
stop("Differential equations were not integrated for all output times because\n", |
231 | ! |
n_out_na, " NaN values occurred in output from ode()") |
232 |
} |
|
233 |
} |
|
234 | ||
235 | 45701183x |
if (map_output) { |
236 |
# Output transformation for models with unobserved compartments like SFORB |
|
237 |
# if not already mapped in analytical solution |
|
238 | 45701183x |
if (n_out_na > 0 & !na_stop) { |
239 | ! |
available <- c(TRUE, rep(FALSE, length(outtimes) - 1)) |
240 |
} else { |
|
241 | 45701183x |
available <- rep(TRUE, length(outtimes)) |
242 |
} |
|
243 | 45701183x |
for (var in names(x$map)) { |
244 | 93237433x |
if((length(x$map[[var]]) == 1)) { |
245 | 93235081x |
out_obs[available, var] <- out[available, var] |
246 |
} else { |
|
247 | 2352x |
out_obs[available, var] <- out[available, x$map[[var]][1]] + |
248 | 2352x |
out[available, x$map[[var]][2]] |
249 |
} |
|
250 |
} |
|
251 | 45701183x |
return(out_obs) |
252 |
} else { |
|
253 | ! |
dimnames(out) <- list(time = as.character(outtimes), c("time", mod_vars)) |
254 | ! |
return(out) |
255 |
} |
|
256 |
} |
|
257 | ||
258 |
#' @rdname mkinpredict |
|
259 |
#' @export |
|
260 |
mkinpredict.mkinfit <- function(x, |
|
261 |
odeparms = x$bparms.ode, |
|
262 |
odeini = x$bparms.state, |
|
263 |
outtimes = seq(0, 120, by = 0.1), |
|
264 |
solution_type = "deSolve", |
|
265 |
use_compiled = "auto", |
|
266 |
method.ode = "lsoda", atol = 1e-8, rtol = 1e-10, |
|
267 |
map_output = TRUE, ...) |
|
268 |
{ |
|
269 | ! |
mkinpredict(x$mkinmod, odeparms, odeini, outtimes, solution_type, use_compiled, |
270 | ! |
method.ode, atol, rtol, map_output, ...) |
271 |
} |
1 |
#' Anova method for saem.mmkin objects |
|
2 |
#' |
|
3 |
#' Generate an anova object. The method to calculate the BIC is that from the |
|
4 |
#' saemix package. As in other prominent anova methods, models are sorted by |
|
5 |
#' number of parameters, and the tests (if requested) are always relative to |
|
6 |
#' the model on the previous line. |
|
7 |
#' |
|
8 |
#' @param object An [saem.mmkin] object |
|
9 |
#' @param ... further such objects |
|
10 |
#' @param method Method for likelihood calculation: "is" (importance sampling), |
|
11 |
#' "lin" (linear approximation), or "gq" (Gaussian quadrature). Passed |
|
12 |
#' to [saemix::logLik.SaemixObject] |
|
13 |
#' @param test Should a likelihood ratio test be performed? If TRUE, |
|
14 |
#' the alternative models are tested against the first model. Should |
|
15 |
#' only be done for nested models. |
|
16 |
#' @param model.names Optional character vector of model names |
|
17 |
#' @importFrom stats anova logLik update pchisq terms |
|
18 |
#' @importFrom methods is |
|
19 |
#' @importFrom utils capture.output |
|
20 |
#' @export |
|
21 |
#' @return an "anova" data frame; the traditional (S3) result of anova() |
|
22 |
anova.saem.mmkin <- function(object, ..., |
|
23 |
method = c("is", "lin", "gq"), test = FALSE, model.names = NULL) |
|
24 |
{ |
|
25 |
# The following code is heavily inspired by anova.lmer in the lme4 package |
|
26 | 518x |
mCall <- match.call(expand.dots = TRUE) |
27 | 518x |
dots <- list(...) |
28 | 518x |
method <- match.arg(method) |
29 | ||
30 | 518x |
is_model <- sapply(dots, is, "saem.mmkin") |
31 | 518x |
if (any(is_model)) { |
32 | 518x |
mods <- c(list(object), dots[is_model]) |
33 | 518x |
successful <- sapply(mods, function(x) !inherits(x$so, "try-error")) |
34 | ||
35 | 518x |
if (is.null(model.names)) |
36 | 284x |
model.names <- vapply(as.list(mCall)[c(FALSE, TRUE, is_model)], deparse1, "") |
37 | ||
38 |
# Sanitize model names |
|
39 | 518x |
if (length(model.names) != length(mods)) |
40 | ! |
stop("Model names vector and model list have different lengths") |
41 | ||
42 | 518x |
if (any(duplicated(model.names))) |
43 | ! |
stop("Duplicate model names are not allowed") |
44 | ||
45 | 518x |
if (max(nchar(model.names)) > 200) { |
46 | ! |
warning("Model names longer than 200 characters, assigning generic names") |
47 | ! |
model.names <- paste0("MODEL",seq_along(model.names)) |
48 |
} |
|
49 | 518x |
names(mods) <- model.names |
50 | 518x |
mods <- mods[successful] |
51 | ||
52 |
# Ensure same data, ignoring covariates |
|
53 | 518x |
same_data <- sapply(mods[-1], function(x) { |
54 | 1182x |
identical(mods[[1]]$data[c("ds", "name", "time", "value")], |
55 | 1182x |
x$data[c("ds", "name", "time", "value")]) |
56 |
}) |
|
57 | 518x |
if (!all(same_data)) { |
58 | ! |
stop(sum(!same_data), " objects have not been fitted to the same data") |
59 |
} |
|
60 | ||
61 | 518x |
llks <- lapply(names(mods), function(x) { |
62 | 1700x |
llk <- try(logLik(mods[[x]], method = method), silent = TRUE) |
63 | 1700x |
if (inherits(llk, "try-error")) { |
64 | ! |
warning("Could not obtain log likelihood with '", method, "' method for ", x) |
65 | ! |
llk <- NA |
66 |
} |
|
67 | 1700x |
return(llk) |
68 |
}) |
|
69 | 518x |
available <- !sapply(llks, is.na) |
70 | 518x |
llks <- llks[available] |
71 | 518x |
mods <- mods[available] |
72 | ||
73 |
# Order models by increasing degrees of freedom: |
|
74 | 518x |
npar <- vapply(llks, attr, FUN.VALUE=numeric(1), "df") |
75 | 518x |
ii <- order(npar) |
76 | 518x |
mods <- mods[ii] |
77 | 518x |
llks <- llks[ii] |
78 | 518x |
npar <- npar[ii] |
79 | ||
80 |
# Describe data for the header, as in summary.saem.mmkin |
|
81 | 518x |
header <- paste("Data:", nrow(object$data), "observations of", |
82 | 518x |
length(unique(object$data$name)), "variable(s) grouped in", |
83 | 518x |
length(unique(object$data$ds)), "datasets\n") |
84 | ||
85 |
# Calculate statistics |
|
86 | 518x |
llk <- unlist(llks) |
87 | 518x |
chisq <- 2 * pmax(0, c(NA, diff(llk))) |
88 | 518x |
dfChisq <- c(NA, diff(npar)) |
89 | ||
90 | 518x |
bic <- function(x, method) { |
91 | 1700x |
BIC(x$so, method = method) |
92 |
} |
|
93 | 518x |
val <- data.frame( |
94 | 518x |
npar = npar, |
95 | 518x |
AIC = sapply(llks, AIC), |
96 | 518x |
BIC = sapply(mods, bic, method = method), # We use the saemix method here |
97 | 518x |
Lik = llk, |
98 | 518x |
row.names = names(mods), check.names = FALSE) |
99 | ||
100 | 518x |
if (test) { |
101 | 196x |
testval <- data.frame( |
102 | 196x |
Chisq = chisq, |
103 | 196x |
Df = dfChisq, |
104 | 196x |
"Pr(>Chisq)" = ifelse(dfChisq == 0, NA, |
105 | 196x |
pchisq(chisq, dfChisq, lower.tail = FALSE)), |
106 | 196x |
row.names = names(mods), check.names = FALSE) |
107 | 196x |
val <- cbind(val, testval) |
108 |
} |
|
109 | 518x |
class(val) <- c("anova", class(val)) |
110 | 518x |
structure(val, heading = c(header)) |
111 |
} else { |
|
112 | ! |
stop("Currently, no anova method is implemented for the case of a single saem.mmkin object") |
113 |
} |
|
114 |
} |
1 |
#' Create degradation functions for known analytical solutions |
|
2 |
#' |
|
3 |
#' @param spec List of model specifications as contained in mkinmod objects |
|
4 |
#' @param use_of_ff Minimum or maximum use of formation fractions |
|
5 |
#' @return Degradation function to be attached to mkinmod objects |
|
6 |
#' @examples |
|
7 |
#' |
|
8 |
#' SFO_SFO <- mkinmod( |
|
9 |
#' parent = mkinsub("SFO", "m1"), |
|
10 |
#' m1 = mkinsub("SFO")) |
|
11 |
#' FOCUS_D <- subset(FOCUS_2006_D, value != 0) # to avoid warnings |
|
12 |
#' fit_1 <- mkinfit(SFO_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE) |
|
13 |
#' \dontrun{ |
|
14 |
#' fit_2 <- mkinfit(SFO_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE) |
|
15 |
#' if (require(rbenchmark)) |
|
16 |
#' benchmark( |
|
17 |
#' analytical = mkinfit(SFO_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE), |
|
18 |
#' deSolve = mkinfit(SFO_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE), |
|
19 |
#' replications = 2) |
|
20 |
#' DFOP_SFO <- mkinmod( |
|
21 |
#' parent = mkinsub("DFOP", "m1"), |
|
22 |
#' m1 = mkinsub("SFO")) |
|
23 |
#' benchmark( |
|
24 |
#' analytical = mkinfit(DFOP_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE), |
|
25 |
#' deSolve = mkinfit(DFOP_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE), |
|
26 |
#' replications = 2) |
|
27 |
#' } |
|
28 |
#' @export |
|
29 |
create_deg_func <- function(spec, use_of_ff = c("min", "max")) { |
|
30 | ||
31 | 8117x |
use_of_ff <- match.arg(use_of_ff) |
32 | 8117x |
min_ff <- use_of_ff == "min" |
33 | 8117x |
obs_vars <- names(spec) |
34 | ||
35 | 8117x |
parent <- obs_vars[1] |
36 | 8117x |
parent_type <- spec[[1]]$type |
37 | ||
38 | 8117x |
supported <- TRUE # This may be modified below |
39 | ||
40 | 8117x |
predicted_text <- character(0) |
41 | ||
42 | 8117x |
if (parent_type == "SFO") { |
43 | 5916x |
if (min_ff) { |
44 | 599x |
targets <- c(spec[[1]]$to, if (spec[[1]]$sink) "sink" else NULL) |
45 | 599x |
k_parent <- paste(paste0("k_", parent, "_", targets), collapse = " + ") |
46 |
} else { |
|
47 | 5317x |
k_parent <- paste0("k_", parent) |
48 |
} |
|
49 |
} |
|
50 | ||
51 | 8117x |
predicted_text[parent] <- paste0(parent_type, ".solution(t, odeini['", parent, |
52 | 8117x |
if (parent_type == "SFORB") "_free", "'], ", |
53 | 8117x |
switch(parent_type, |
54 | 8117x |
SFO = k_parent, |
55 | 8117x |
FOMC = "alpha, beta", |
56 | 8117x |
IORE = paste0("k__iore_", parent, if (min_ff) "_sink" else "", ", N_", parent), |
57 | 8117x |
DFOP = "k1, k2, g", |
58 | 8117x |
SFORB = paste0("k_", parent, "_free_bound, k_", parent, "_bound_free, k_", parent, "_free", if (min_ff) "_sink" else ""), |
59 | 8117x |
HS = "k1, k2, tb", |
60 | 8117x |
logistic = "kmax, k0, r" |
61 |
), |
|
62 |
")") |
|
63 | ||
64 | 3728x |
if (length(obs_vars) >= 2) supported <- FALSE |
65 |
# Except for the following cases: |
|
66 | ||
67 | 8117x |
if (length(obs_vars) == 2) { |
68 | 3036x |
n1 <- obs_vars[1] |
69 | 3036x |
n2 <- obs_vars[2] |
70 | 3036x |
n10 <- paste0("odeini['", parent, "']") |
71 | 3036x |
n20 <- paste0("odeini['", n2, "']") |
72 | ||
73 |
# sfo_sfo |
|
74 | 3036x |
if (all( |
75 | 3036x |
spec[[1]]$sink == FALSE, |
76 | 3036x |
spec[[1]]$type == "SFO", |
77 | 3036x |
spec[[2]]$type == "SFO", |
78 | 3036x |
is.null(spec[[2]]$to))) { |
79 | 741x |
supported <- TRUE |
80 | 741x |
k1 <- k_parent |
81 | 741x |
k2 <- paste0("k_", n2, if(min_ff) "_sink" else "") |
82 | 741x |
predicted_text[n2] <- paste0( |
83 | 741x |
"(((", k2, "-", k1, ")*", n20, "-", k1, "*", n10, ")*exp(-", k2, "*t)+", |
84 | 741x |
k1, "*", n10, "*exp(-", k1, "*t))/(", k2, "-", k1, ")") |
85 |
} |
|
86 | ||
87 |
# sfo_f12_sfo |
|
88 | 3036x |
if (all( |
89 | 3036x |
use_of_ff == "max", |
90 | 3036x |
spec[[1]]$sink == TRUE, |
91 | 3036x |
spec[[1]]$type == "SFO", |
92 | 3036x |
spec[[2]]$type == "SFO", |
93 | 3036x |
is.null(spec[[2]]$to))) { |
94 | 1129x |
supported <- TRUE |
95 | 1129x |
k1 <- k_parent |
96 | 1129x |
k2 <- paste0("k_", n2) |
97 | 1129x |
f12 <- paste0("f_", n1, "_to_", n2) |
98 | 1129x |
predicted_text[n2] <- paste0( |
99 | 1129x |
"(((", k2, "-", k1, ")*", n20, "-", f12, "*", k1, "*", n10, ")*exp(-", k2, "*t)+", |
100 | 1129x |
f12, "*", k1, "*", n10, "*exp(-", k1, "*t))/(", k2, "-", k1, ")") |
101 |
} |
|
102 | ||
103 |
# sfo_k120_sfo |
|
104 | 3036x |
if (all( |
105 | 3036x |
use_of_ff == "min", |
106 | 3036x |
spec[[1]]$sink == TRUE, |
107 | 3036x |
spec[[1]]$type == "SFO", |
108 | 3036x |
spec[[2]]$type == "SFO", |
109 | 3036x |
is.null(spec[[2]]$to))) { |
110 | 351x |
supported <- TRUE |
111 | 351x |
k12 <- paste0("k_", n1, "_", n2) |
112 | 351x |
k10 <- paste0("k_", n1, "_sink") |
113 | 351x |
k2 <- paste0("k_", n2, "_sink") |
114 | 351x |
predicted_text[n2] <- paste0( |
115 | 351x |
"(((", k2, "-", k12, "-", k10, ")*", n20, "-", k12, "*", n10, ")*exp(-", k2, "*t)+", |
116 | 351x |
k12, "*", n10, "*exp(-(", k_parent, ")*t))/(", k2, "-(", k_parent, "))") |
117 |
} |
|
118 | ||
119 |
# dfop_f12_sfo |
|
120 | 3036x |
if (all( |
121 | 3036x |
use_of_ff == "max", |
122 | 3036x |
spec[[1]]$sink == TRUE, |
123 | 3036x |
spec[[1]]$type == "DFOP", |
124 | 3036x |
spec[[2]]$type == "SFO", |
125 | 3036x |
is.null(spec[[2]]$to))) { |
126 | 565x |
supported <- TRUE |
127 | 565x |
f12 <- paste0("f_", n1, "_to_", n2) |
128 | 565x |
k2 <- paste0("k_", n2) |
129 | 565x |
predicted_text[n2] <- paste0( |
130 | 565x |
"((", f12, "* g - ", f12, ") * k2 * ", n10, " * exp(- k2 * t))/(k2 - ", k2, ") - ", |
131 | 565x |
"((", f12, "* g) * k1 * ", n10, " * exp(- k1 * t))/(k1 - ", k2, ") + ", |
132 | 565x |
"(((k1 - ", k2, ") * k2 - ", k2, "* k1 + ", k2, "^2) * ", n20, "+", |
133 | 565x |
"((", f12, "* k1 + (", f12, "*g - ", f12, ") * ", k2, ") * k2 - ", f12, " * g * ", k2, " * k1) * ", n10, ") * ", |
134 | 565x |
"exp( - ", k2, " * t)/((k1 - ", k2, ") * k2 - ", k2, " * k1 + ", k2, "^2)") |
135 |
} |
|
136 | ||
137 |
} |
|
138 | ||
139 | 8117x |
if (supported) { |
140 | 7175x |
deg_func <- function(observed, odeini, odeparms) {} |
141 | ||
142 | 7175x |
f_body <- paste0("{\n", |
143 | 7175x |
"predicted <- numeric(0)\n", |
144 | 7175x |
"with(as.list(odeparms), {\n") |
145 | 7175x |
for (obs_var in obs_vars) { |
146 | 9961x |
f_body <- paste0(f_body, |
147 | 9961x |
"t <- observed[observed$name == '", obs_var, "', 'time']\n", |
148 | 9961x |
"predicted <<- c(predicted, ", predicted_text[obs_var], ")\n") |
149 |
} |
|
150 | 7175x |
f_body <- paste0(f_body, |
151 | 7175x |
"})\n", |
152 | 7175x |
"return(predicted)\n}\n") |
153 | ||
154 | 7175x |
body(deg_func) <- parse(text = f_body) |
155 | 7175x |
return(deg_func) |
156 |
} else { |
|
157 | 942x |
return(NULL) |
158 |
} |
|
159 |
} |
1 |
#' Helper functions to create nlme models from mmkin row objects |
|
2 |
#' |
|
3 |
#' These functions facilitate setting up a nonlinear mixed effects model for |
|
4 |
#' an mmkin row object. An mmkin row object is essentially a list of mkinfit |
|
5 |
#' objects that have been obtained by fitting the same model to a list of |
|
6 |
#' datasets. They are used internally by the [nlme.mmkin()] method. |
|
7 |
#' |
|
8 |
#' @param object An mmkin row object containing several fits of the same model to different datasets |
|
9 |
#' @import nlme |
|
10 |
#' @rdname nlme |
|
11 |
#' @seealso \code{\link{nlme.mmkin}} |
|
12 |
#' @examples |
|
13 |
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
14 |
#' m_SFO <- mkinmod(parent = mkinsub("SFO")) |
|
15 |
#' d_SFO_1 <- mkinpredict(m_SFO, |
|
16 |
#' c(k_parent = 0.1), |
|
17 |
#' c(parent = 98), sampling_times) |
|
18 |
#' d_SFO_1_long <- mkin_wide_to_long(d_SFO_1, time = "time") |
|
19 |
#' d_SFO_2 <- mkinpredict(m_SFO, |
|
20 |
#' c(k_parent = 0.05), |
|
21 |
#' c(parent = 102), sampling_times) |
|
22 |
#' d_SFO_2_long <- mkin_wide_to_long(d_SFO_2, time = "time") |
|
23 |
#' d_SFO_3 <- mkinpredict(m_SFO, |
|
24 |
#' c(k_parent = 0.02), |
|
25 |
#' c(parent = 103), sampling_times) |
|
26 |
#' d_SFO_3_long <- mkin_wide_to_long(d_SFO_3, time = "time") |
|
27 |
#' |
|
28 |
#' d1 <- add_err(d_SFO_1, function(value) 3, n = 1) |
|
29 |
#' d2 <- add_err(d_SFO_2, function(value) 2, n = 1) |
|
30 |
#' d3 <- add_err(d_SFO_3, function(value) 4, n = 1) |
|
31 |
#' ds <- c(d1 = d1, d2 = d2, d3 = d3) |
|
32 |
#' |
|
33 |
#' f <- mmkin("SFO", ds, cores = 1, quiet = TRUE) |
|
34 |
#' mean_dp <- mean_degparms(f) |
|
35 |
#' grouped_data <- nlme_data(f) |
|
36 |
#' nlme_f <- nlme_function(f) |
|
37 |
#' # These assignments are necessary for these objects to be |
|
38 |
#' # visible to nlme and augPred when evaluation is done by |
|
39 |
#' # pkgdown to generate the html docs. |
|
40 |
#' assign("nlme_f", nlme_f, globalenv()) |
|
41 |
#' assign("grouped_data", grouped_data, globalenv()) |
|
42 |
#' |
|
43 |
#' library(nlme) |
|
44 |
#' m_nlme <- nlme(value ~ nlme_f(name, time, parent_0, log_k_parent_sink), |
|
45 |
#' data = grouped_data, |
|
46 |
#' fixed = parent_0 + log_k_parent_sink ~ 1, |
|
47 |
#' random = pdDiag(parent_0 + log_k_parent_sink ~ 1), |
|
48 |
#' start = mean_dp) |
|
49 |
#' summary(m_nlme) |
|
50 |
#' plot(augPred(m_nlme, level = 0:1), layout = c(3, 1)) |
|
51 |
#' # augPred does not work on fits with more than one state |
|
52 |
#' # variable |
|
53 |
#' # |
|
54 |
#' # The procedure is greatly simplified by the nlme.mmkin function |
|
55 |
#' f_nlme <- nlme(f) |
|
56 |
#' plot(f_nlme) |
|
57 |
#' @return A function that can be used with nlme |
|
58 |
#' @export |
|
59 |
nlme_function <- function(object) { |
|
60 | ! |
if (nrow(object) > 1) stop("Only row objects allowed") |
61 | ||
62 | 1168x |
mkin_model <- object[[1]]$mkinmod |
63 | ||
64 | 1168x |
degparm_names <- names(mean_degparms(object)) |
65 | ||
66 |
# Inspired by https://stackoverflow.com/a/12983961/3805440 |
|
67 |
# and https://stackoverflow.com/a/26280789/3805440 |
|
68 | 1168x |
model_function_alist <- replicate(length(degparm_names) + 2, substitute()) |
69 | 1168x |
names(model_function_alist) <- c("name", "time", degparm_names) |
70 | ||
71 | 1168x |
model_function_body <- quote({ |
72 | 252739x |
arg_frame <- as.data.frame(as.list((environment())), stringsAsFactors = FALSE) |
73 | 252739x |
res_frame <- arg_frame[1:2] |
74 | 252739x |
parm_frame <- arg_frame[-(1:2)] |
75 | 252739x |
parms_unique <- unique(parm_frame) |
76 | ||
77 | 252739x |
n_unique <- nrow(parms_unique) |
78 | ||
79 | 252739x |
times_ds <- list() |
80 | 252739x |
names_ds <- list() |
81 | 252739x |
for (i in 1:n_unique) { |
82 | 2342789x |
times_ds[[i]] <- |
83 | 2342789x |
arg_frame[which(arg_frame[[3]] == parms_unique[i, 1]), "time"] |
84 | 2342789x |
names_ds[[i]] <- |
85 | 2342789x |
arg_frame[which(arg_frame[[3]] == parms_unique[i, 1]), "name"] |
86 |
} |
|
87 | ||
88 | 252739x |
res_list <- lapply(1:n_unique, function(x) { |
89 | 2342789x |
transparms_optim <- unlist(parms_unique[x, , drop = TRUE]) |
90 | 2342789x |
parms_fixed <- object[[1]]$bparms.fixed |
91 | ||
92 | 2342789x |
odeini_optim_parm_names <- grep('_0$', names(transparms_optim), value = TRUE) |
93 | 2342789x |
odeini_optim <- transparms_optim[odeini_optim_parm_names] |
94 | 2342789x |
names(odeini_optim) <- gsub('_0$', '', odeini_optim_parm_names) |
95 | 2342789x |
odeini_fixed_parm_names <- grep('_0$', names(parms_fixed), value = TRUE) |
96 | 2342789x |
odeini_fixed <- parms_fixed[odeini_fixed_parm_names] |
97 | 2342789x |
names(odeini_fixed) <- gsub('_0$', '', odeini_fixed_parm_names) |
98 | 2342789x |
odeini <- c(odeini_optim, odeini_fixed)[names(mkin_model$diffs)] |
99 | ||
100 | 2342789x |
ode_transparms_optim_names <- setdiff(names(transparms_optim), odeini_optim_parm_names) |
101 | 2342789x |
odeparms_optim <- backtransform_odeparms(transparms_optim[ode_transparms_optim_names], mkin_model, |
102 | 2342789x |
transform_rates = object[[1]]$transform_rates, |
103 | 2342789x |
transform_fractions = object[[1]]$transform_fractions) |
104 | 2342789x |
odeparms_fixed_names <- setdiff(names(parms_fixed), odeini_fixed_parm_names) |
105 | 2342789x |
odeparms_fixed <- parms_fixed[odeparms_fixed_names] |
106 | 2342789x |
odeparms <- c(odeparms_optim, odeparms_fixed) |
107 | ||
108 | 2342789x |
out_wide <- mkinpredict(mkin_model, |
109 | 2342789x |
odeparms = odeparms, odeini = odeini, |
110 | 2342789x |
solution_type = object[[1]]$solution_type, |
111 | 2342789x |
outtimes = sort(unique(times_ds[[x]]))) |
112 | 2342789x |
out_array <- out_wide[, -1, drop = FALSE] |
113 | 2342789x |
rownames(out_array) <- as.character(unique(times_ds[[x]])) |
114 | 2342789x |
out_times <- as.character(times_ds[[x]]) |
115 | 2342789x |
out_names <- as.character(names_ds[[x]]) |
116 | 2342789x |
out_values <- mapply(function(times, names) out_array[times, names], |
117 | 2342789x |
out_times, out_names) |
118 | 2342789x |
return(as.numeric(out_values)) |
119 |
}) |
|
120 | 252739x |
res <- unlist(res_list) |
121 | 252739x |
return(res) |
122 |
}) |
|
123 | 1168x |
model_function <- as.function(c(model_function_alist, model_function_body)) |
124 | 1168x |
return(model_function) |
125 |
} |
|
126 | ||
127 |
#' @rdname nlme |
|
128 |
#' @importFrom rlang !!! |
|
129 |
#' @return A \code{\link{groupedData}} object |
|
130 |
#' @export |
|
131 |
nlme_data <- function(object) { |
|
132 | ! |
if (nrow(object) > 1) stop("Only row objects allowed") |
133 | 5677x |
ds_names <- colnames(object) |
134 | ||
135 | 5677x |
ds_list <- lapply(object, function(x) x$data[c("time", "variable", "observed")]) |
136 | 5677x |
names(ds_list) <- ds_names |
137 | 5677x |
ds_nlme <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds") |
138 | 5677x |
ds_nlme$variable <- as.character(ds_nlme$variable) |
139 | 5677x |
ds_nlme$ds <- ordered(ds_nlme$ds, levels = unique(ds_nlme$ds)) |
140 | 5677x |
ds_nlme_renamed <- data.frame(ds = ds_nlme$ds, name = ds_nlme$variable, |
141 | 5677x |
time = ds_nlme$time, value = ds_nlme$observed, |
142 | 5677x |
stringsAsFactors = FALSE) |
143 | 5677x |
ds_nlme_grouped <- groupedData(value ~ time | ds, ds_nlme_renamed, order.groups = FALSE) |
144 | 5677x |
return(ds_nlme_grouped) |
145 |
} |
1 |
#' Functions to transform and backtransform kinetic parameters for fitting |
|
2 |
#' |
|
3 |
#' The transformations are intended to map parameters that should only take on |
|
4 |
#' restricted values to the full scale of real numbers. For kinetic rate |
|
5 |
#' constants and other parameters that can only take on positive values, a |
|
6 |
#' simple log transformation is used. For compositional parameters, such as the |
|
7 |
#' formations fractions that should always sum up to 1 and can not be negative, |
|
8 |
#' the [ilr] transformation is used. |
|
9 |
#' |
|
10 |
#' The transformation of sets of formation fractions is fragile, as it supposes |
|
11 |
#' the same ordering of the components in forward and backward transformation. |
|
12 |
#' This is no problem for the internal use in [mkinfit]. |
|
13 |
#' |
|
14 |
#' @param parms Parameters of kinetic models as used in the differential |
|
15 |
#' equations. |
|
16 |
#' @param transparms Transformed parameters of kinetic models as used in the |
|
17 |
#' fitting procedure. |
|
18 |
#' @param mkinmod The kinetic model of class [mkinmod], containing |
|
19 |
#' the names of the model variables that are needed for grouping the |
|
20 |
#' formation fractions before [ilr] transformation, the parameter |
|
21 |
#' names and the information if the pathway to sink is included in the model. |
|
22 |
#' @param transform_rates Boolean specifying if kinetic rate constants should |
|
23 |
#' be transformed in the model specification used in the fitting for better |
|
24 |
#' compliance with the assumption of normal distribution of the estimator. If |
|
25 |
#' TRUE, also alpha and beta parameters of the FOMC model are |
|
26 |
#' log-transformed, as well as k1 and k2 rate constants for the DFOP and HS |
|
27 |
#' models and the break point tb of the HS model. |
|
28 |
#' @param transform_fractions Boolean specifying if formation fractions |
|
29 |
#' constants should be transformed in the model specification used in the |
|
30 |
#' fitting for better compliance with the assumption of normal distribution |
|
31 |
#' of the estimator. The default (TRUE) is to do transformations. |
|
32 |
#' The g parameter of the DFOP model is also seen as a fraction. |
|
33 |
#' If a single fraction is transformed (g parameter of DFOP or only a single |
|
34 |
#' target variable e.g. a single metabolite plus a pathway to sink), a |
|
35 |
#' logistic transformation is used [stats::qlogis()]. In other cases, i.e. if |
|
36 |
#' two or more formation fractions need to be transformed whose sum cannot |
|
37 |
#' exceed one, the [ilr] transformation is used. |
|
38 |
#' @return A vector of transformed or backtransformed parameters |
|
39 |
#' @importFrom stats plogis qlogis |
|
40 |
#' @author Johannes Ranke |
|
41 |
#' @examples |
|
42 |
#' |
|
43 |
#' SFO_SFO <- mkinmod( |
|
44 |
#' parent = list(type = "SFO", to = "m1", sink = TRUE), |
|
45 |
#' m1 = list(type = "SFO"), use_of_ff = "min") |
|
46 |
#' |
|
47 |
#' # Fit the model to the FOCUS example dataset D using defaults |
|
48 |
#' FOCUS_D <- subset(FOCUS_2006_D, value != 0) # remove zero values to avoid warning |
|
49 |
#' fit <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE) |
|
50 |
#' fit.s <- summary(fit) |
|
51 |
#' # Transformed and backtransformed parameters |
|
52 |
#' print(fit.s$par, 3) |
|
53 |
#' print(fit.s$bpar, 3) |
|
54 |
#' |
|
55 |
#' \dontrun{ |
|
56 |
#' # Compare to the version without transforming rate parameters (does not work |
|
57 |
#' # with analytical solution, we get NA values for m1 in predictions) |
|
58 |
#' fit.2 <- mkinfit(SFO_SFO, FOCUS_D, transform_rates = FALSE, |
|
59 |
#' solution_type = "deSolve", quiet = TRUE) |
|
60 |
#' fit.2.s <- summary(fit.2) |
|
61 |
#' print(fit.2.s$par, 3) |
|
62 |
#' print(fit.2.s$bpar, 3) |
|
63 |
#' } |
|
64 |
#' |
|
65 |
#' initials <- fit$start$value |
|
66 |
#' names(initials) <- rownames(fit$start) |
|
67 |
#' transformed <- fit$start_transformed$value |
|
68 |
#' names(transformed) <- rownames(fit$start_transformed) |
|
69 |
#' transform_odeparms(initials, SFO_SFO) |
|
70 |
#' backtransform_odeparms(transformed, SFO_SFO) |
|
71 |
#' |
|
72 |
#' \dontrun{ |
|
73 |
#' # The case of formation fractions (this is now the default) |
|
74 |
#' SFO_SFO.ff <- mkinmod( |
|
75 |
#' parent = list(type = "SFO", to = "m1", sink = TRUE), |
|
76 |
#' m1 = list(type = "SFO"), |
|
77 |
#' use_of_ff = "max") |
|
78 |
#' |
|
79 |
#' fit.ff <- mkinfit(SFO_SFO.ff, FOCUS_D, quiet = TRUE) |
|
80 |
#' fit.ff.s <- summary(fit.ff) |
|
81 |
#' print(fit.ff.s$par, 3) |
|
82 |
#' print(fit.ff.s$bpar, 3) |
|
83 |
#' initials <- c("f_parent_to_m1" = 0.5) |
|
84 |
#' transformed <- transform_odeparms(initials, SFO_SFO.ff) |
|
85 |
#' backtransform_odeparms(transformed, SFO_SFO.ff) |
|
86 |
#' |
|
87 |
#' # And without sink |
|
88 |
#' SFO_SFO.ff.2 <- mkinmod( |
|
89 |
#' parent = list(type = "SFO", to = "m1", sink = FALSE), |
|
90 |
#' m1 = list(type = "SFO"), |
|
91 |
#' use_of_ff = "max") |
|
92 |
#' |
|
93 |
#' |
|
94 |
#' fit.ff.2 <- mkinfit(SFO_SFO.ff.2, FOCUS_D, quiet = TRUE) |
|
95 |
#' fit.ff.2.s <- summary(fit.ff.2) |
|
96 |
#' print(fit.ff.2.s$par, 3) |
|
97 |
#' print(fit.ff.2.s$bpar, 3) |
|
98 |
#' } |
|
99 |
#' |
|
100 |
#' @export transform_odeparms |
|
101 |
transform_odeparms <- function(parms, mkinmod, |
|
102 |
transform_rates = TRUE, transform_fractions = TRUE) |
|
103 |
{ |
|
104 |
# We need the model specification for the names of the model |
|
105 |
# variables and the information on the sink |
|
106 | 25587x |
spec = mkinmod$spec |
107 | ||
108 |
# Set up container for transformed parameters |
|
109 | 25587x |
transparms <- numeric(0) |
110 | ||
111 |
# Do not transform initial values for state variables |
|
112 | 25587x |
state.ini.optim <- parms[grep("_0$", names(parms))] |
113 | 25587x |
transparms[names(state.ini.optim)] <- state.ini.optim |
114 | ||
115 |
# Log transformation for rate constants if requested |
|
116 | 25587x |
k <- parms[grep("^k_", names(parms))] |
117 | 25587x |
k__iore <- parms[grep("^k__iore_", names(parms))] |
118 | 25587x |
k <- c(k, k__iore) |
119 | 25587x |
if (length(k) > 0) { |
120 | 15485x |
if(transform_rates) { |
121 | 14379x |
transparms[paste0("log_", names(k))] <- log(k) |
122 | 1106x |
} else transparms[names(k)] <- k |
123 |
} |
|
124 | ||
125 |
# Do not transform exponents in IORE models |
|
126 | 25587x |
N <- parms[grep("^N", names(parms))] |
127 | 25587x |
transparms[names(N)] <- N |
128 | ||
129 |
# Go through state variables and transform formation fractions if requested |
|
130 | 25587x |
mod_vars = names(spec) |
131 | 25587x |
for (box in mod_vars) { |
132 | 41283x |
f <- parms[grep(paste("^f", box, sep = "_"), names(parms))] |
133 | ||
134 | 41283x |
if (length(f) > 0) { |
135 | 6522x |
if(transform_fractions) { |
136 | 5910x |
if (spec[[box]]$sink) { |
137 | 5908x |
if (length(f) == 1) { |
138 | 5894x |
trans_f_name <- paste("f", box, "qlogis", sep = "_") |
139 | 5894x |
transparms[trans_f_name] <- qlogis(f) |
140 |
} else { |
|
141 | 14x |
trans_f <- ilr(c(f, 1 - sum(f))) |
142 | 14x |
trans_f_names <- paste("f", box, "ilr", 1:length(trans_f), sep = "_") |
143 | 14x |
transparms[trans_f_names] <- trans_f |
144 |
} |
|
145 |
} else { |
|
146 | 2x |
if (length(f) > 1) { |
147 | 2x |
trans_f <- ilr(f) |
148 | 2x |
trans_f_names <- paste("f", box, "ilr", 1:length(trans_f), sep = "_") |
149 | 2x |
transparms[trans_f_names] <- trans_f |
150 |
} |
|
151 |
} |
|
152 |
} else { |
|
153 | 612x |
transparms[names(f)] <- f |
154 |
} |
|
155 |
} |
|
156 |
} |
|
157 | ||
158 |
# Transform also FOMC parameters alpha and beta, DFOP and HS rates k1 and k2 |
|
159 |
# and HS parameter tb as well as logistic model parameters kmax, k0 and r if |
|
160 |
# transformation of rates is requested |
|
161 | 25587x |
for (pname in c("alpha", "beta", "k1", "k2", "tb", "kmax", "k0", "r")) { |
162 | 204696x |
if (!is.na(parms[pname])) { |
163 | 6006x |
if (transform_rates) { |
164 | 6006x |
transparms[paste0("log_", pname)] <- log(parms[pname]) |
165 |
} else { |
|
166 | ! |
transparms[pname] <- parms[pname] |
167 |
} |
|
168 |
} |
|
169 |
} |
|
170 | ||
171 |
# DFOP parameter g is treated as a fraction |
|
172 | 25587x |
if (!is.na(parms["g"])) { |
173 | 1978x |
g <- parms["g"] |
174 | 1978x |
if (transform_fractions) { |
175 | 1978x |
transparms["g_qlogis"] <- qlogis(g) |
176 |
} else { |
|
177 | ! |
transparms["g"] <- g |
178 |
} |
|
179 |
} |
|
180 | ||
181 | 25587x |
return(transparms) |
182 |
} |
|
183 | ||
184 |
#' @rdname transform_odeparms |
|
185 |
#' @export backtransform_odeparms |
|
186 |
backtransform_odeparms <- function(transparms, mkinmod, |
|
187 |
transform_rates = TRUE, |
|
188 |
transform_fractions = TRUE) |
|
189 |
{ |
|
190 |
# We need the model specification for the names of the model |
|
191 |
# variables and the information on the sink |
|
192 | 49214214x |
spec = mkinmod$spec |
193 | ||
194 |
# Set up container for backtransformed parameters |
|
195 | 49214214x |
parms <- numeric(0) |
196 | ||
197 |
# Do not transform initial values for state variables |
|
198 | 49214214x |
state.ini.optim <- transparms[grep("_0$", names(transparms))] |
199 | 49214214x |
parms[names(state.ini.optim)] <- state.ini.optim |
200 | ||
201 |
# Exponential transformation for rate constants |
|
202 | 49214214x |
if(transform_rates) { |
203 | 49140623x |
trans_k <- transparms[grep("^log_k_", names(transparms))] |
204 | 49140623x |
trans_k__iore <- transparms[grep("^log_k__iore_", names(transparms))] |
205 | 49140623x |
trans_k = c(trans_k, trans_k__iore) |
206 | 49140623x |
if (length(trans_k) > 0) { |
207 | 47598103x |
k_names <- gsub("^log_k", "k", names(trans_k)) |
208 | 47598103x |
parms[k_names] <- exp(trans_k) |
209 |
} |
|
210 |
} else { |
|
211 | 73591x |
trans_k <- transparms[grep("^k_", names(transparms))] |
212 | 73591x |
parms[names(trans_k)] <- trans_k |
213 | 73591x |
trans_k__iore <- transparms[grep("^k__iore_", names(transparms))] |
214 | 73591x |
parms[names(trans_k__iore)] <- trans_k__iore |
215 |
} |
|
216 | ||
217 |
# Do not transform exponents in IORE models |
|
218 | 49214214x |
N <- transparms[grep("^N", names(transparms))] |
219 | 49214214x |
parms[names(N)] <- N |
220 | ||
221 |
# Go through state variables and apply inverse transformations to formation fractions |
|
222 | 49214214x |
mod_vars = names(spec) |
223 | 49214214x |
for (box in mod_vars) { |
224 |
# Get the names as used in the model |
|
225 | 97593385x |
f_names = grep(paste("^f", box, sep = "_"), mkinmod$parms, value = TRUE) |
226 | ||
227 |
# Get the formation fraction parameters |
|
228 | 97593385x |
trans_f = transparms[grep(paste("^f", box, sep = "_"), names(transparms))] |
229 | 97593385x |
if (length(trans_f) > 0) { |
230 | 46632823x |
if(transform_fractions) { |
231 | 46588453x |
if (any(grepl("qlogis", names(trans_f)))) { |
232 | 46059152x |
f_tmp <- plogis(trans_f) |
233 | 46059152x |
parms[f_names] <- f_tmp |
234 |
} else { |
|
235 | 529301x |
f_tmp <- invilr(trans_f) |
236 | 529301x |
if (spec[[box]]$sink) { |
237 | 528393x |
parms[f_names] <- f_tmp[1:length(f_tmp)-1] |
238 |
} else { |
|
239 | 908x |
parms[f_names] <- f_tmp |
240 |
} |
|
241 |
} |
|
242 |
} else { |
|
243 | 44370x |
parms[names(trans_f)] <- trans_f |
244 |
} |
|
245 |
} |
|
246 |
} |
|
247 | ||
248 |
# Transform parameters also for FOMC, DFOP, HS and logistic models |
|
249 | 49214214x |
for (pname in c("alpha", "beta", "k1", "k2", "tb", "kmax", "k0", "r")) { |
250 | 393713712x |
if (transform_rates) { |
251 | 393124984x |
pname_trans = paste0("log_", pname) |
252 | 393124984x |
if (!is.na(transparms[pname_trans])) { |
253 | 4306142x |
parms[pname] <- exp(transparms[pname_trans]) |
254 |
} |
|
255 |
} else { |
|
256 | 588728x |
if (!is.na(transparms[pname])) { |
257 | ! |
parms[pname] <- transparms[pname] |
258 |
} |
|
259 |
} |
|
260 |
} |
|
261 | ||
262 |
# DFOP parameter g is now transformed using qlogis |
|
263 | 49214214x |
if (!is.na(transparms["g_qlogis"])) { |
264 | 2034008x |
g_qlogis <- transparms["g_qlogis"] |
265 | 2034008x |
parms["g"] <- plogis(g_qlogis) |
266 |
} |
|
267 |
# In earlier times we used ilr for g, so we keep this around |
|
268 | 49214214x |
if (!is.na(transparms["g_ilr"])) { |
269 | ! |
g_ilr <- transparms["g_ilr"] |
270 | ! |
parms["g"] <- invilr(g_ilr)[1] |
271 |
} |
|
272 | 49214214x |
if (!is.na(transparms["g"])) { |
273 | ! |
parms["g"] <- transparms["g"] |
274 |
} |
|
275 | ||
276 | 49214214x |
return(parms) |
277 |
} |
|
278 |
# vim: set ts=2 sw=2 expandtab: |
1 |
#' Hierarchical kinetics template |
|
2 |
#' |
|
3 |
#' R markdown format for setting up hierarchical kinetics based on a template |
|
4 |
#' provided with the mkin package. This format is based on [rmarkdown::pdf_document]. |
|
5 |
#' Chunk options are adapted. Echoing R code from code chunks and caching are |
|
6 |
#' turned on per default. character for prepending output from code chunks is |
|
7 |
#' set to the empty string, code tidying is off, figure alignment defaults to |
|
8 |
#' centering, and positioning of figures is set to "H", which means that |
|
9 |
#' figures will not move around in the document, but stay where the user |
|
10 |
#' includes them. |
|
11 |
#' |
|
12 |
#' The latter feature (positioning the figures with "H") depends on the LaTeX |
|
13 |
#' package 'float'. In addition, the LaTeX package 'listing' is used in the |
|
14 |
#' template for showing model fit summaries in the Appendix. This means that |
|
15 |
#' the LaTeX packages 'float' and 'listing' need to be installed in the TeX |
|
16 |
#' distribution used. |
|
17 |
#' |
|
18 |
#' On Windows, the easiest way to achieve this (if no TeX distribution |
|
19 |
#' is present before) is to install the 'tinytex' R package, to run |
|
20 |
#' 'tinytex::install_tinytex()' to get the basic tiny Tex distribution, |
|
21 |
#' and then to run 'tinytex::tlmgr_install(c("float", "listing"))'. |
|
22 |
#' |
|
23 |
#' @inheritParams rmarkdown::pdf_document |
|
24 |
#' @param ... Arguments to \code{rmarkdown::pdf_document} |
|
25 |
#' |
|
26 |
#' @return R Markdown output format to pass to |
|
27 |
#' \code{\link[rmarkdown:render]{render}} |
|
28 |
#' |
|
29 |
#' @examples |
|
30 |
#' |
|
31 |
#' \dontrun{ |
|
32 |
#' library(rmarkdown) |
|
33 |
#' # The following is now commented out after the relase of v1.2.3 for the generation |
|
34 |
#' # of online docs, as the command creates a directory and opens an editor |
|
35 |
#' #draft("example_analysis.rmd", template = "hierarchical_kinetics", package = "mkin") |
|
36 |
#' } |
|
37 |
#' |
|
38 |
#' @export |
|
39 |
hierarchical_kinetics <- function(..., keep_tex = FALSE) { |
|
40 | ||
41 | ! |
if (getRversion() < "4.1.0") |
42 | ! |
stop("You need R with version > 4.1.0 to compile this document") |
43 | ||
44 | ! |
if (!requireNamespace("knitr")) stop("Please install the knitr package to use this template") |
45 | ! |
if (!requireNamespace("rmarkdown")) stop("Please install the rmarkdown package to use this template") |
46 | ! |
knitr::opts_chunk$set(cache = TRUE, comment = "", tidy = FALSE, echo = TRUE) |
47 | ! |
knitr::opts_chunk$set(fig.align = "center", fig.pos = "H") |
48 | ! |
options(knitr.kable.NA = "") |
49 | ||
50 | ! |
fmt <- rmarkdown::pdf_document(..., |
51 | ! |
keep_tex = keep_tex, |
52 | ! |
toc = TRUE, |
53 | ! |
toc_depth = 3, |
54 | ! |
includes = rmarkdown::includes(in_header = "header.tex"), |
55 | ! |
extra_dependencies = c("float", "listing", "framed") |
56 |
) |
|
57 | ||
58 | ! |
return(fmt) |
59 |
} |
1 |
# Code inspired by nlme::nlme.nlsList and R/nlme_fit.R from nlmixr |
|
2 | ||
3 |
# We need to assign the degradation function created in nlme.mmkin to an |
|
4 |
# environment that is always accessible, also e.g. when evaluation is done by |
|
5 |
# testthat or pkgdown. Therefore parent.frame() is not good enough. The |
|
6 |
# following environment will be in the mkin namespace. |
|
7 |
.nlme_env <- new.env(parent = emptyenv()) |
|
8 | ||
9 |
#' @export |
|
10 |
nlme::nlme |
|
11 | ||
12 |
#' Retrieve a degradation function from the mmkin namespace |
|
13 |
#' |
|
14 |
#' @importFrom utils getFromNamespace |
|
15 |
#' @return A function that was likely previously assigned from within |
|
16 |
#' nlme.mmkin |
|
17 |
#' @export |
|
18 |
get_deg_func <- function() { |
|
19 | 217279x |
return(get("deg_func", getFromNamespace(".nlme_env", "mkin"))) |
20 |
} |
|
21 | ||
22 |
#' Create an nlme model for an mmkin row object |
|
23 |
#' |
|
24 |
#' This functions sets up a nonlinear mixed effects model for an mmkin row |
|
25 |
#' object. An mmkin row object is essentially a list of mkinfit objects that |
|
26 |
#' have been obtained by fitting the same model to a list of datasets. |
|
27 |
#' |
|
28 |
#' Note that the convergence of the nlme algorithms depends on the quality |
|
29 |
#' of the data. In degradation kinetics, we often only have few datasets |
|
30 |
#' (e.g. data for few soils) and complicated degradation models, which may |
|
31 |
#' make it impossible to obtain convergence with nlme. |
|
32 |
#' |
|
33 |
#' @param model An [mmkin] row object. |
|
34 |
#' @param data Ignored, data are taken from the mmkin model |
|
35 |
#' @param fixed Ignored, all degradation parameters fitted in the |
|
36 |
#' mmkin model are used as fixed parameters |
|
37 |
#' @param random If not specified, no correlations between random effects are |
|
38 |
#' set up for the optimised degradation model parameters. This is |
|
39 |
#' achieved by using the [nlme::pdDiag] method. |
|
40 |
#' @param groups See the documentation of nlme |
|
41 |
#' @param start If not specified, mean values of the fitted degradation |
|
42 |
#' parameters taken from the mmkin object are used |
|
43 |
#' @param correlation See the documentation of nlme |
|
44 |
#' @param weights passed to nlme |
|
45 |
#' @param subset passed to nlme |
|
46 |
#' @param method passed to nlme |
|
47 |
#' @param na.action passed to nlme |
|
48 |
#' @param naPattern passed to nlme |
|
49 |
#' @param control passed to nlme |
|
50 |
#' @param verbose passed to nlme |
|
51 |
#' @importFrom stats na.fail as.formula |
|
52 |
#' @return Upon success, a fitted 'nlme.mmkin' object, which is an nlme object |
|
53 |
#' with additional elements. It also inherits from 'mixed.mmkin'. |
|
54 |
#' @note As the object inherits from [nlme::nlme], there is a wealth of |
|
55 |
#' methods that will automatically work on 'nlme.mmkin' objects, such as |
|
56 |
#' [nlme::intervals()], [nlme::anova.lme()] and [nlme::coef.lme()]. |
|
57 |
#' @export |
|
58 |
#' @seealso [nlme_function()], [plot.mixed.mmkin], [summary.nlme.mmkin] |
|
59 |
#' @examples |
|
60 |
#' ds <- lapply(experimental_data_for_UBA_2019[6:10], |
|
61 |
#' function(x) subset(x$data[c("name", "time", "value")], name == "parent")) |
|
62 |
#' |
|
63 |
#' \dontrun{ |
|
64 |
#' f <- mmkin(c("SFO", "DFOP"), ds, quiet = TRUE, cores = 1) |
|
65 |
#' library(nlme) |
|
66 |
#' f_nlme_sfo <- nlme(f["SFO", ]) |
|
67 |
#' f_nlme_dfop <- nlme(f["DFOP", ]) |
|
68 |
#' anova(f_nlme_sfo, f_nlme_dfop) |
|
69 |
#' print(f_nlme_dfop) |
|
70 |
#' plot(f_nlme_dfop) |
|
71 |
#' endpoints(f_nlme_dfop) |
|
72 |
#' |
|
73 |
#' ds_2 <- lapply(experimental_data_for_UBA_2019[6:10], |
|
74 |
#' function(x) x$data[c("name", "time", "value")]) |
|
75 |
#' m_sfo_sfo <- mkinmod(parent = mkinsub("SFO", "A1"), |
|
76 |
#' A1 = mkinsub("SFO"), use_of_ff = "min", quiet = TRUE) |
|
77 |
#' m_sfo_sfo_ff <- mkinmod(parent = mkinsub("SFO", "A1"), |
|
78 |
#' A1 = mkinsub("SFO"), use_of_ff = "max", quiet = TRUE) |
|
79 |
#' m_dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"), |
|
80 |
#' A1 = mkinsub("SFO"), quiet = TRUE) |
|
81 |
#' |
|
82 |
#' f_2 <- mmkin(list("SFO-SFO" = m_sfo_sfo, |
|
83 |
#' "SFO-SFO-ff" = m_sfo_sfo_ff, |
|
84 |
#' "DFOP-SFO" = m_dfop_sfo), |
|
85 |
#' ds_2, quiet = TRUE) |
|
86 |
#' |
|
87 |
#' f_nlme_sfo_sfo <- nlme(f_2["SFO-SFO", ]) |
|
88 |
#' plot(f_nlme_sfo_sfo) |
|
89 |
#' |
|
90 |
#' # With formation fractions this does not coverge with defaults |
|
91 |
#' # f_nlme_sfo_sfo_ff <- nlme(f_2["SFO-SFO-ff", ]) |
|
92 |
#' #plot(f_nlme_sfo_sfo_ff) |
|
93 |
#' |
|
94 |
#' # For the following, we need to increase pnlsMaxIter and the tolerance |
|
95 |
#' # to get convergence |
|
96 |
#' f_nlme_dfop_sfo <- nlme(f_2["DFOP-SFO", ], |
|
97 |
#' control = list(pnlsMaxIter = 120, tolerance = 5e-4)) |
|
98 |
#' |
|
99 |
#' plot(f_nlme_dfop_sfo) |
|
100 |
#' |
|
101 |
#' anova(f_nlme_dfop_sfo, f_nlme_sfo_sfo) |
|
102 |
#' |
|
103 |
#' endpoints(f_nlme_sfo_sfo) |
|
104 |
#' endpoints(f_nlme_dfop_sfo) |
|
105 |
#' |
|
106 |
#' if (length(findFunction("varConstProp")) > 0) { # tc error model for nlme available |
|
107 |
#' # Attempts to fit metabolite kinetics with the tc error model are possible, |
|
108 |
#' # but need tweeking of control values and sometimes do not converge |
|
109 |
#' |
|
110 |
#' f_tc <- mmkin(c("SFO", "DFOP"), ds, quiet = TRUE, error_model = "tc") |
|
111 |
#' f_nlme_sfo_tc <- nlme(f_tc["SFO", ]) |
|
112 |
#' f_nlme_dfop_tc <- nlme(f_tc["DFOP", ]) |
|
113 |
#' AIC(f_nlme_sfo, f_nlme_sfo_tc, f_nlme_dfop, f_nlme_dfop_tc) |
|
114 |
#' print(f_nlme_dfop_tc) |
|
115 |
#' } |
|
116 |
#' |
|
117 |
#' f_2_obs <- update(f_2, error_model = "obs") |
|
118 |
#' f_nlme_sfo_sfo_obs <- nlme(f_2_obs["SFO-SFO", ]) |
|
119 |
#' print(f_nlme_sfo_sfo_obs) |
|
120 |
#' f_nlme_dfop_sfo_obs <- nlme(f_2_obs["DFOP-SFO", ], |
|
121 |
#' control = list(pnlsMaxIter = 120, tolerance = 5e-4)) |
|
122 |
#' |
|
123 |
#' f_2_tc <- update(f_2, error_model = "tc") |
|
124 |
#' # f_nlme_sfo_sfo_tc <- nlme(f_2_tc["SFO-SFO", ]) # No convergence with 50 iterations |
|
125 |
#' # f_nlme_dfop_sfo_tc <- nlme(f_2_tc["DFOP-SFO", ], |
|
126 |
#' # control = list(pnlsMaxIter = 120, tolerance = 5e-4)) # Error in X[, fmap[[nm]]] <- gradnm |
|
127 |
#' |
|
128 |
#' anova(f_nlme_dfop_sfo, f_nlme_dfop_sfo_obs) |
|
129 |
#' |
|
130 |
#' } |
|
131 |
nlme.mmkin <- function(model, data = "auto", |
|
132 |
fixed = lapply(as.list(names(mean_degparms(model))), |
|
133 |
function(el) eval(parse(text = paste(el, 1, sep = "~")))), |
|
134 |
random = pdDiag(fixed), |
|
135 |
groups, |
|
136 |
start = mean_degparms(model, random = TRUE, test_log_parms = TRUE), |
|
137 |
correlation = NULL, weights = NULL, |
|
138 |
subset, method = c("ML", "REML"), |
|
139 |
na.action = na.fail, naPattern, |
|
140 |
control = list(), verbose= FALSE) |
|
141 |
{ |
|
142 | ! |
if (nrow(model) > 1) stop("Only row objects allowed") |
143 | ||
144 | 1013x |
thisCall <- as.list(match.call())[-1] |
145 | ||
146 |
# Warn in case arguments were used that are overriden |
|
147 | 1013x |
if (any(!is.na(match(names(thisCall), |
148 | 1013x |
c("data"))))) { |
149 | ! |
warning("'nlme.mmkin' will redefine 'data'") |
150 |
} |
|
151 | ||
152 |
# Get native symbol info for speed |
|
153 | 1013x |
if (model[[1]]$solution_type == "deSolve" & !is.null(model[[1]]$mkinmod$cf)) { |
154 |
# The mkinmod stored in the first fit will be used by nlme |
|
155 | 189x |
model[[1]]$mkinmod$symbols <- deSolve::checkDLL( |
156 | 189x |
dllname = model[[1]]$mkinmod$dll_info[["name"]], |
157 | 189x |
func = "diffs", initfunc = "initpar", |
158 | 189x |
jacfunc = NULL, nout = 0, outnames = NULL) |
159 |
} |
|
160 | ||
161 | 1013x |
deg_func <- nlme_function(model) |
162 | ||
163 | 1013x |
assign("deg_func", deg_func, getFromNamespace(".nlme_env", "mkin")) |
164 | ||
165 |
# For the formula, get the degradation function from the mkin namespace |
|
166 | 1013x |
this_model_text <- paste0("value ~ mkin::get_deg_func()(", |
167 | 1013x |
paste(names(formals(deg_func)), collapse = ", "), ")") |
168 | 1013x |
this_model <- as.formula(this_model_text) |
169 | ||
170 | 1013x |
thisCall[["model"]] <- this_model |
171 | ||
172 | 1013x |
thisCall[["data"]] <- nlme_data(model) |
173 | ||
174 | 1013x |
thisCall[["start"]] <- start |
175 | ||
176 | 1013x |
thisCall[["fixed"]] <- fixed |
177 | ||
178 | 1013x |
thisCall[["random"]] <- random |
179 | ||
180 | 1013x |
error_model <- model[[1]]$err_mod |
181 | ||
182 | 1013x |
if (missing(weights)) { |
183 | 1013x |
thisCall[["weights"]] <- switch(error_model, |
184 | 1013x |
const = NULL, |
185 | 1013x |
obs = varIdent(form = ~ 1 | name), |
186 | 1013x |
tc = varConstProp()) |
187 | 1013x |
sigma <- switch(error_model, |
188 | 1013x |
tc = 1, |
189 | 1013x |
NULL) |
190 |
} |
|
191 | ||
192 | 1013x |
control <- thisCall[["control"]] |
193 | 1013x |
if (error_model == "tc") { |
194 | 928x |
control$sigma = 1 |
195 | 928x |
thisCall[["control"]] <- control |
196 |
} |
|
197 | ||
198 | 1013x |
fit_time <- system.time(val <- do.call("nlme.formula", thisCall)) |
199 | 1013x |
val$time <- fit_time |
200 | ||
201 | 1013x |
val$mkinmod <- model[[1]]$mkinmod |
202 |
# Don't return addresses that will become invalid |
|
203 | 1013x |
val$mkinmod$symbols <- NULL |
204 | ||
205 | 1013x |
val$data <- thisCall[["data"]] |
206 | 1013x |
val$mmkin <- model |
207 | 824x |
if (is.list(start)) val$mean_dp_start <- start$fixed |
208 | 189x |
else val$mean_dp_start <- start |
209 | 1013x |
val$transform_rates <- model[[1]]$transform_rates |
210 | 1013x |
val$transform_fractions <- model[[1]]$transform_fractions |
211 | 1013x |
val$solution_type <- model[[1]]$solution_type |
212 | 1013x |
val$err_mode <- error_model |
213 | ||
214 | 1013x |
val$bparms.optim <- backtransform_odeparms(val$coefficients$fixed, |
215 | 1013x |
val$mkinmod, |
216 | 1013x |
transform_rates = val$transform_rates, |
217 | 1013x |
transform_fractions = val$transform_fractions) |
218 | ||
219 | 1013x |
val$bparms.fixed <- model[[1]]$bparms.fixed |
220 | 1013x |
val$date.fit <- date() |
221 | 1013x |
val$nlmeversion <- as.character(utils::packageVersion("nlme")) |
222 | 1013x |
val$mkinversion <- as.character(utils::packageVersion("mkin")) |
223 | 1013x |
val$Rversion <- paste(R.version$major, R.version$minor, sep=".") |
224 | 1013x |
class(val) <- c("nlme.mmkin", "mixed.mmkin", "nlme", "lme") |
225 | 1013x |
return(val) |
226 |
} |
|
227 | ||
228 |
#' @export |
|
229 |
#' @rdname nlme.mmkin |
|
230 |
#' @param x An nlme.mmkin object to print |
|
231 |
#' @param digits Number of digits to use for printing |
|
232 |
print.nlme.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { |
|
233 | 117x |
cat( "Kinetic nonlinear mixed-effects model fit by " ) |
234 | 117x |
cat( if(x$method == "REML") "REML\n" else "maximum likelihood\n") |
235 | 117x |
cat("\nStructural model:\n") |
236 | 117x |
diffs <- x$mmkin[[1]]$mkinmod$diffs |
237 | 117x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs) |
238 | 117x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
239 | 117x |
cat("\nData:\n") |
240 | 117x |
cat(nrow(x$data), "observations of", |
241 | 117x |
length(unique(x$data$name)), "variable(s) grouped in", |
242 | 117x |
length(unique(x$data$ds)), "datasets\n") |
243 | 117x |
cat("\nLog-", if(x$method == "REML") "restricted-" else "", |
244 | 117x |
"likelihood: ", format(x$logLik, digits = digits), "\n", sep = "") |
245 | 117x |
fixF <- x$call$fixed |
246 | 117x |
cat("\nFixed effects:\n", |
247 | 117x |
deparse( |
248 | 117x |
if(inherits(fixF, "formula") || is.call(fixF) || is.name(fixF)) |
249 | 117x |
x$call$fixed |
250 |
else |
|
251 | 117x |
lapply(fixF, function(el) as.name(deparse(el)))), "\n") |
252 | 117x |
print(fixef(x), digits = digits, ...) |
253 | 117x |
cat("\n") |
254 | 117x |
print(summary(x$modelStruct), sigma = x$sigma, digits = digits, ...) |
255 | 117x |
invisible(x) |
256 |
} |
|
257 | ||
258 |
#' @export |
|
259 |
#' @rdname nlme.mmkin |
|
260 |
#' @param object An nlme.mmkin object to update |
|
261 |
#' @param ... Update specifications passed to update.nlme |
|
262 |
update.nlme.mmkin <- function(object, ...) { |
|
263 | 85x |
res <- NextMethod() |
264 | 85x |
res$mmkin <- object$mmkin |
265 | 85x |
class(res) <- c("nlme.mmkin", "nlme", "lme") |
266 | 85x |
return(res) |
267 |
} |
1 |
utils::globalVariables(c("variable", "residual")) |
|
2 | ||
3 |
#' Function to plot residuals stored in an mkin object |
|
4 |
#' |
|
5 |
#' This function plots the residuals for the specified subset of the observed |
|
6 |
#' variables from an mkinfit object. A combined plot of the fitted model and |
|
7 |
#' the residuals can be obtained using \code{\link{plot.mkinfit}} using the |
|
8 |
#' argument \code{show_residuals = TRUE}. |
|
9 |
#' |
|
10 |
#' @importFrom stats residuals |
|
11 |
#' @param object A fit represented in an \code{\link{mkinfit}} object. |
|
12 |
#' @param obs_vars A character vector of names of the observed variables for |
|
13 |
#' which residuals should be plotted. Defaults to all observed variables in |
|
14 |
#' the model |
|
15 |
#' @param xlim plot range in x direction. |
|
16 |
#' @param xlab Label for the x axis. |
|
17 |
#' @param standardized Should the residuals be standardized by dividing by the |
|
18 |
#' standard deviation given by the error model of the fit? |
|
19 |
#' @param ylab Label for the y axis. |
|
20 |
#' @param maxabs Maximum absolute value of the residuals. This is used for the |
|
21 |
#' scaling of the y axis and defaults to "auto". |
|
22 |
#' @param legend Should a legend be plotted? |
|
23 |
#' @param lpos Where should the legend be placed? Default is "topright". Will |
|
24 |
#' be passed on to \code{\link{legend}}. |
|
25 |
#' @param col_obs Colors for the observed variables. |
|
26 |
#' @param pch_obs Symbols to be used for the observed variables. |
|
27 |
#' @param frame Should a frame be drawn around the plots? |
|
28 |
#' @param \dots further arguments passed to \code{\link{plot}}. |
|
29 |
#' @return Nothing is returned by this function, as it is called for its side |
|
30 |
#' effect, namely to produce a plot. |
|
31 |
#' @author Johannes Ranke and Katrin Lindenberger |
|
32 |
#' @seealso \code{\link{mkinplot}}, for a way to plot the data and the fitted |
|
33 |
#' lines of the mkinfit object, and \code{\link{plot_res}} for a function |
|
34 |
#' combining the plot of the fit and the residual plot. |
|
35 |
#' @examples |
|
36 |
#' |
|
37 |
#' model <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO")) |
|
38 |
#' fit <- mkinfit(model, FOCUS_2006_D, quiet = TRUE) |
|
39 |
#' mkinresplot(fit, "m1") |
|
40 |
#' |
|
41 |
#' @export |
|
42 |
mkinresplot <- function (object, |
|
43 |
obs_vars = names(object$mkinmod$map), |
|
44 |
xlim = c(0, 1.1 * max(object$data$time)), |
|
45 |
standardized = FALSE, |
|
46 |
xlab = "Time", ylab = ifelse(standardized, "Standardized residual", "Residual"), |
|
47 |
maxabs = "auto", legend = TRUE, lpos = "topright", |
|
48 |
col_obs = "auto", pch_obs = "auto", |
|
49 |
frame = TRUE, |
|
50 |
...) |
|
51 |
{ |
|
52 | 1228x |
obs_vars_all <- as.character(unique(object$data$variable)) |
53 | ||
54 | 1228x |
if (length(obs_vars) > 0){ |
55 | 1228x |
obs_vars <- intersect(obs_vars_all, obs_vars) |
56 | ! |
} else obs_vars <- obs_vars_all |
57 | ||
58 | 1228x |
if (standardized) { |
59 | ! |
res_col <- "standardized" |
60 | ! |
object$data[[res_col]] <- residuals(object, standardized = TRUE) |
61 |
} else { |
|
62 | 1228x |
res_col <- "residual" |
63 |
} |
|
64 | 1228x |
res <- subset(object$data, variable %in% obs_vars)[res_col] |
65 | ||
66 | 1228x |
if (maxabs == "auto") maxabs = max(abs(res), na.rm = TRUE) |
67 | ||
68 |
# Set colors and symbols |
|
69 | 1228x |
if (col_obs[1] == "auto") { |
70 | 948x |
col_obs <- 1:length(obs_vars) |
71 |
} |
|
72 | ||
73 | 1228x |
if (pch_obs[1] == "auto") { |
74 | 948x |
pch_obs <- 1:length(obs_vars) |
75 |
} |
|
76 | 1228x |
names(col_obs) <- names(pch_obs) <- obs_vars |
77 | ||
78 | 1228x |
plot(0, type = "n", frame = frame, |
79 | 1228x |
xlab = xlab, ylab = ylab, |
80 | 1228x |
xlim = xlim, |
81 | 1228x |
ylim = c(-1.2 * maxabs, 1.2 * maxabs), ...) |
82 | ||
83 | 1228x |
for(obs_var in obs_vars){ |
84 | 1298x |
residuals_plot <- subset(object$data, variable == obs_var, c("time", res_col)) |
85 | 1298x |
points(residuals_plot, pch = pch_obs[obs_var], col = col_obs[obs_var]) |
86 |
} |
|
87 | ||
88 | 1228x |
abline(h = 0, lty = 2) |
89 | ||
90 | 1228x |
if (legend == TRUE) { |
91 | ! |
legend(lpos, inset = c(0.05, 0.05), legend = obs_vars, |
92 | ! |
col = col_obs[obs_vars], pch = pch_obs[obs_vars]) |
93 |
} |
|
94 |
} |
1 |
#' Plot model fits (observed and fitted) and the residuals for a row or column |
|
2 |
#' of an mmkin object |
|
3 |
#' |
|
4 |
#' When x is a row selected from an mmkin object (\code{\link{[.mmkin}}), the |
|
5 |
#' same model fitted for at least one dataset is shown. When it is a column, |
|
6 |
#' the fit of at least one model to the same dataset is shown. |
|
7 |
#' |
|
8 |
#' If the current plot device is a \code{\link[tikzDevice]{tikz}} device, then |
|
9 |
#' latex is being used for the formatting of the chi2 error level. |
|
10 |
#' |
|
11 |
#' @param x An object of class \code{\link{mmkin}}, with either one row or one |
|
12 |
#' column. |
|
13 |
#' @param main The main title placed on the outer margin of the plot. |
|
14 |
#' @param legends An index for the fits for which legends should be shown. |
|
15 |
#' @param resplot Should the residuals plotted against time, using |
|
16 |
#' \code{\link{mkinresplot}}, or as squared residuals against predicted |
|
17 |
#' values, with the error model, using \code{\link{mkinerrplot}}. |
|
18 |
#' @param ylab Label for the y axis. |
|
19 |
#' @param standardized Should the residuals be standardized? This option |
|
20 |
#' is passed to \code{\link{mkinresplot}}, it only takes effect if |
|
21 |
#' `resplot = "time"`. |
|
22 |
#' @param show_errmin Should the chi2 error level be shown on top of the plots |
|
23 |
#' to the left? |
|
24 |
#' @param errmin_var The variable for which the FOCUS chi2 error value should |
|
25 |
#' be shown. |
|
26 |
#' @param errmin_digits The number of significant digits for rounding the FOCUS |
|
27 |
#' chi2 error percentage. |
|
28 |
#' @param cex Passed to the plot functions and \code{\link{mtext}}. |
|
29 |
#' @param rel.height.middle The relative height of the middle plot, if more |
|
30 |
#' than two rows of plots are shown. |
|
31 |
#' @param ymax Maximum y axis value for \code{\link{plot.mkinfit}}. |
|
32 |
#' @param \dots Further arguments passed to \code{\link{plot.mkinfit}} and |
|
33 |
#' \code{\link{mkinresplot}}. |
|
34 |
#' @return The function is called for its side effect. |
|
35 |
#' @author Johannes Ranke |
|
36 |
#' @examples |
|
37 |
#' |
|
38 |
#' \dontrun{ |
|
39 |
#' # Only use one core not to offend CRAN checks |
|
40 |
#' fits <- mmkin(c("FOMC", "HS"), |
|
41 |
#' list("FOCUS B" = FOCUS_2006_B, "FOCUS C" = FOCUS_2006_C), # named list for titles |
|
42 |
#' cores = 1, quiet = TRUE, error_model = "tc") |
|
43 |
#' plot(fits[, "FOCUS C"]) |
|
44 |
#' plot(fits["FOMC", ]) |
|
45 |
#' plot(fits["FOMC", ], show_errmin = FALSE) |
|
46 |
#' |
|
47 |
#' # We can also plot a single fit, if we like the way plot.mmkin works, but then the plot |
|
48 |
#' # height should be smaller than the plot width (this is not possible for the html pages |
|
49 |
#' # generated by pkgdown, as far as I know). |
|
50 |
#' plot(fits["FOMC", "FOCUS C"]) # same as plot(fits[1, 2]) |
|
51 |
#' |
|
52 |
#' # Show the error models |
|
53 |
#' plot(fits["FOMC", ], resplot = "errmod") |
|
54 |
#' } |
|
55 |
#' |
|
56 |
#' @export |
|
57 |
plot.mmkin <- function(x, main = "auto", legends = 1, |
|
58 |
resplot = c("time", "errmod"), |
|
59 |
ylab = "Residue", |
|
60 |
standardized = FALSE, |
|
61 |
show_errmin = TRUE, |
|
62 |
errmin_var = "All data", errmin_digits = 3, |
|
63 |
cex = 0.7, rel.height.middle = 0.9, |
|
64 |
ymax = "auto", ...) |
|
65 |
{ |
|
66 | ||
67 | 316x |
oldpar <- par(no.readonly = TRUE) |
68 | 316x |
on.exit(par(oldpar, no.readonly = TRUE)) |
69 | ||
70 | 316x |
n.m <- nrow(x) |
71 | 316x |
n.d <- ncol(x) |
72 | ||
73 | 316x |
resplot <- match.arg(resplot) |
74 | ||
75 |
# We can handle either a row (different models, same dataset) |
|
76 |
# or a column (same model, different datasets) |
|
77 | ! |
if (n.m > 1 & n.d > 1) stop("Please select fits either for one model or for one dataset") |
78 | ! |
if (n.m == 1 & n.d == 1) loop_over = "none" |
79 | 246x |
if (n.m > 1) loop_over <- "models" |
80 | 70x |
if (n.d > 1) loop_over <- "datasets" |
81 | 316x |
n.fits <- length(x) |
82 | ||
83 |
# Set the main plot titles from the names of the models or the datasets |
|
84 |
# Will be integer indexes if no other names are present in the mmkin object |
|
85 | 316x |
if (main == "auto") { |
86 | 140x |
main = switch(loop_over, |
87 | 140x |
none = paste(rownames(x), colnames(x)), |
88 | 140x |
models = colnames(x), |
89 | 140x |
datasets = rownames(x)) |
90 |
} |
|
91 | ||
92 |
# Set relative plot heights, so the first and the last plot are the norm |
|
93 |
# and the middle plots (if n.fits >2) are smaller by rel.height.middle |
|
94 | 316x |
rel.heights <- if (n.fits > 2) c(1, rep(rel.height.middle, n.fits - 2), 1) |
95 | 316x |
else rep(1, n.fits) |
96 | 316x |
layout(matrix(1:(2 * n.fits), n.fits, 2, byrow = TRUE), heights = rel.heights) |
97 | ||
98 | 316x |
par(cex = cex) |
99 | ||
100 | 316x |
for (i.fit in 1:n.fits) { |
101 | ||
102 |
# Margins for top row of plots when we have more than one row |
|
103 |
# Reduce bottom margin by 2.1 - hides x axis legend |
|
104 | 948x |
if (i.fit == 1 & n.fits > 1) { |
105 | 316x |
par(mar = c(3.0, 4.1, 4.1, 2.1)) |
106 |
} |
|
107 | ||
108 |
# Margins for middle rows of plots, if any |
|
109 | 948x |
if (i.fit > 1 & i.fit < n.fits) { |
110 |
# Reduce top margin by 2 after the first plot as we have no main title, |
|
111 |
# reduced plot height, therefore we need rel.height.middle in the layout |
|
112 | 316x |
par(mar = c(3.0, 4.1, 2.1, 2.1)) |
113 |
} |
|
114 | ||
115 |
# Margins for bottom row of plots when we have more than one row |
|
116 | 948x |
if (i.fit == n.fits & n.fits > 1) { |
117 |
# Restore bottom margin for last plot to show x axis legend |
|
118 | 316x |
par(mar = c(5.1, 4.1, 2.1, 2.1)) |
119 |
} |
|
120 | ||
121 | 948x |
fit <- x[[i.fit]] |
122 | 948x |
if (ymax == "auto") { |
123 | 948x |
plot(fit, legend = legends == i.fit, ylab = ylab, ...) |
124 |
} else { |
|
125 | ! |
plot(fit, legend = legends == i.fit, ylim = c(0, ymax), ylab = ylab, ...) |
126 |
} |
|
127 | ||
128 | 948x |
title(main, outer = TRUE, line = -2) |
129 | ||
130 | 948x |
fit_name <- switch(loop_over, |
131 | 948x |
models = rownames(x)[i.fit], |
132 | 948x |
datasets = colnames(x)[i.fit], |
133 | 948x |
none = "") |
134 | ||
135 | 948x |
if (show_errmin) { |
136 | 948x |
chi2 <- signif(100 * mkinerrmin(fit)[errmin_var, "err.min"], errmin_digits) |
137 | ||
138 |
# Use LateX if the current plotting device is tikz |
|
139 | 948x |
if (names(dev.cur()) == "tikz output") { |
140 | ! |
chi2_text <- paste0(fit_name, " $\\chi^2$ error level = ", chi2, "\\%") |
141 |
} else { |
|
142 | 948x |
chi2_perc <- paste0(chi2, "%") |
143 | 948x |
chi2_text <- bquote(.(fit_name) ~ chi^2 ~ "error level" == .(chi2_perc)) |
144 |
} |
|
145 | 948x |
mtext(chi2_text, cex = cex, line = 0.4) |
146 |
} else { |
|
147 | ! |
mtext(fit_name, cex = cex, line = 0.4) |
148 |
} |
|
149 | ||
150 | 948x |
if (resplot == "time") { |
151 | 948x |
mkinresplot(fit, legend = FALSE, standardized = standardized, ...) |
152 |
} else { |
|
153 | ! |
mkinerrplot(fit, legend = FALSE, ...) |
154 |
} |
|
155 | 948x |
mtext(paste(fit_name, "residuals"), cex = cex, line = 0.4) |
156 |
} |
|
157 |
} |
1 |
#' Summary method for class "mmkin" |
|
2 |
#' |
|
3 |
#' Shows status information on the [mkinfit] objects contained in the object |
|
4 |
#' and gives an overview of ill-defined parameters calculated by [illparms]. |
|
5 |
#' |
|
6 |
#' @param object an object of class [mmkin] |
|
7 |
#' @param x an object of class \code{summary.mmkin}. |
|
8 |
#' @param conf.level confidence level for testing parameters |
|
9 |
#' @param digits number of digits to use for printing |
|
10 |
#' @param \dots optional arguments passed to methods like \code{print}. |
|
11 |
#' @examples |
|
12 |
#' |
|
13 |
#' fits <- mmkin( |
|
14 |
#' c("SFO", "FOMC"), |
|
15 |
#' list("FOCUS A" = FOCUS_2006_A, |
|
16 |
#' "FOCUS C" = FOCUS_2006_C), |
|
17 |
#' quiet = TRUE, cores = 1) |
|
18 |
#' summary(fits) |
|
19 |
#' |
|
20 |
#' @export |
|
21 |
summary.mmkin <- function(object, conf.level = 0.95, ...) { |
|
22 | ||
23 | 1x |
ans <- list( |
24 | 1x |
err_mod = object[[1, 1]]$err_mod, |
25 | 1x |
time = attr(object, "time"), |
26 | 1x |
illparms = illparms(object), |
27 | 1x |
status = status(object) |
28 |
) |
|
29 | ||
30 | 1x |
class(ans) <- c("summary.mmkin") |
31 | 1x |
return(ans) |
32 |
} |
|
33 | ||
34 |
#' @rdname summary.mmkin |
|
35 |
#' @export |
|
36 |
print.summary.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { |
|
37 | 1x |
if (!is.null(x$err_mod)) { |
38 | 1x |
cat("Error model: ") |
39 | 1x |
cat(switch(x$err_mod, |
40 | 1x |
const = "Constant variance", |
41 | 1x |
obs = "Variance unique to each observed variable", |
42 | 1x |
tc = "Two-component variance function"), "\n") |
43 |
} |
|
44 | 1x |
cat("Fitted in", x$time[["elapsed"]], "s\n") |
45 | ||
46 | 1x |
cat("\nStatus:\n") |
47 | 1x |
print(x$status) |
48 | ||
49 | 1x |
if (any(x$illparms != "")) { |
50 | 1x |
cat("\nIll-defined parameters:\n") |
51 | 1x |
print(x$illparms) |
52 |
} |
|
53 | ||
54 | 1x |
invisible(x) |
55 |
} |
|
56 |
1 |
#' Read datasets and relevant meta information from a spreadsheet file |
|
2 |
#' |
|
3 |
#' This function imports one dataset from each sheet of a spreadsheet file. |
|
4 |
#' These sheets are selected based on the contents of a sheet 'Datasets', with |
|
5 |
#' a column called 'Dataset Number', containing numbers identifying the dataset |
|
6 |
#' sheets to be read in. In the second column there must be a grouping |
|
7 |
#' variable, which will often be named 'Soil'. Optionally, time normalization |
|
8 |
#' factors can be given in columns named 'Temperature' and 'Moisture'. |
|
9 |
#' |
|
10 |
#' There must be a sheet 'Compounds', with columns 'Name' and 'Acronym'. |
|
11 |
#' The first row read after the header read in from this sheet is assumed |
|
12 |
#' to contain name and acronym of the parent compound. |
|
13 |
#' |
|
14 |
#' The dataset sheets should be named using the dataset numbers read in from |
|
15 |
#' the 'Datasets' sheet, i.e. '1', '2', ... . In each dataset sheet, the name |
|
16 |
#' of the observed variable (e.g. the acronym of the parent compound or |
|
17 |
#' one of its transformation products) should be in the first column, |
|
18 |
#' the time values should be in the second colum, and the observed value |
|
19 |
#' in the third column. |
|
20 |
#' |
|
21 |
#' In case relevant covariate data are available, they should be given |
|
22 |
#' in a sheet 'Covariates', containing one line for each value of the grouping |
|
23 |
#' variable specified in 'Datasets'. These values should be in the first |
|
24 |
#' column and the column must have the same name as the second column in |
|
25 |
#' 'Datasets'. Covariates will be read in from columns four and higher. |
|
26 |
#' Their names should preferably not contain special characters like spaces, |
|
27 |
#' so they can be easily used for specifying covariate models. |
|
28 |
#' |
|
29 |
#' A similar data structure is defined as the R6 class [mkindsg], but |
|
30 |
#' is probably more complicated to use. |
|
31 |
#' |
|
32 |
#' @param path Absolute or relative path to the spreadsheet file |
|
33 |
#' @param valid_datasets Optional numeric index of the valid datasets, default is |
|
34 |
#' to use all datasets |
|
35 |
#' @param parent_only Should only the parent data be used? |
|
36 |
#' @param normalize Should the time scale be normalized using temperature |
|
37 |
#' and moisture normalisation factors in the sheet 'Datasets'? |
|
38 |
#' @export |
|
39 |
read_spreadsheet <- function(path, valid_datasets = "all", |
|
40 |
parent_only = FALSE, normalize = TRUE) |
|
41 |
{ |
|
42 | 117x |
if (!requireNamespace("readxl", quietly = TRUE)) |
43 | ! |
stop("Please install the readxl package to use this function") |
44 | ||
45 |
# Read the compound table |
|
46 | 117x |
compounds <- readxl::read_excel(path, sheet = "Compounds") |
47 | 117x |
parent <- compounds[1, ]$Acronym |
48 | ||
49 |
# Read in meta information |
|
50 | 117x |
ds_meta <- readxl::read_excel(path, sheet = "Datasets") |
51 | 117x |
ds_meta["Dataset Number"] <- as.character(ds_meta[["Dataset Number"]]) |
52 | ||
53 |
# Select valid datasets |
|
54 | ! |
if (valid_datasets[1] == "all") valid_datasets <- 1:nrow(ds_meta) |
55 | 117x |
ds_numbers_valid <- ds_meta[valid_datasets, ]$`Dataset Number` |
56 | 117x |
grouping_factor <- names(ds_meta[2]) # Often "Soil" |
57 | ||
58 |
# Read in valid datasets |
|
59 | 117x |
ds_raw <- lapply(ds_numbers_valid, |
60 | 117x |
function(dsn) readxl::read_excel(path, sheet = as.character(dsn))) |
61 | ||
62 |
# Make data frames compatible with mmkin |
|
63 | 117x |
ds_tmp <- lapply(ds_raw, function(x) { |
64 | 1287x |
ds_ret <- x[1:3] |> |
65 | 1287x |
rlang::set_names(c("name", "time", "value")) |> |
66 | 1287x |
transform(value = as.numeric(value)) |
67 |
}) |
|
68 | 117x |
names(ds_tmp) <- ds_numbers_valid |
69 | ||
70 |
# Normalize with temperature and moisture correction factors |
|
71 | 117x |
if (normalize) { |
72 | 117x |
ds_norm <- lapply(ds_numbers_valid, function(ds_number) { |
73 | 1287x |
f_corr <- as.numeric(ds_meta[ds_number, c("Temperature", "Moisture")]) |
74 | 1287x |
ds_corr <- ds_tmp[[ds_number]] |> |
75 | 1287x |
transform(time = time * f_corr[1] * f_corr[2]) |
76 | 1287x |
return(ds_corr) |
77 |
}) |
|
78 |
} else { |
|
79 | ! |
ds_norm <- ds_tmp |
80 |
} |
|
81 | 117x |
names(ds_norm) <- ds_numbers_valid |
82 | ||
83 |
# Select parent data only if requested |
|
84 | 117x |
if (parent_only) { |
85 | ! |
ds_norm <- lapply(ds_norm, function(x) subset(x, name == parent)) |
86 | ! |
compounds <- compounds[1, ] |
87 |
} |
|
88 | ||
89 |
# Create a single long table to combine datasets with the same group name |
|
90 | 117x |
ds_all <- vctrs::vec_rbind(!!!ds_norm, .names_to = "Dataset Number") |
91 | 117x |
ds_all_group <- merge(ds_all, ds_meta[c("Dataset Number", grouping_factor)]) |
92 | 117x |
groups <- unique(ds_meta[valid_datasets, ][[grouping_factor]]) |
93 | ||
94 | 117x |
ds <- lapply(groups, function(x) { |
95 | 819x |
ret <- ds_all_group[ds_all_group[[grouping_factor]] == x, ] |
96 | 819x |
ret[c("name", "time", "value")] |
97 |
} |
|
98 |
) |
|
99 | 117x |
names(ds) <- groups |
100 | ||
101 |
# Get covariates |
|
102 | 117x |
covariates_raw <- readxl::read_excel(path, sheet = "Covariates") |
103 | 117x |
covariates <- as.data.frame(covariates_raw[4:ncol(covariates_raw)]) |
104 | 117x |
nocov <- setdiff(groups, covariates_raw[[1]]) |
105 | 117x |
if (length(nocov) > 0) { |
106 | ! |
message("Did not find covariate data for ", paste(nocov, collapse = ", ")) |
107 | ! |
message("Not returning covariate data") |
108 | ! |
attr(ds, "covariates") <- NULL |
109 |
} else { |
|
110 | 117x |
rownames(covariates) <- covariates_raw[[1]] |
111 | 117x |
covariates <- covariates[which(colnames(covariates) != "Remarks")] |
112 |
# Attach covariate data if available |
|
113 | 117x |
attr(ds, "covariates") <- covariates[groups, , drop = FALSE] |
114 |
} |
|
115 | ||
116 |
# Attach the compound list to support automatic model building |
|
117 | 117x |
attr(ds, "compounds") <- as.data.frame(compounds) |
118 | ||
119 | 117x |
return(ds) |
120 |
} |
1 |
#' Export a list of datasets format to a CAKE study file |
|
2 |
#' |
|
3 |
#' In addition to the datasets, the pathways in the degradation model can be |
|
4 |
#' specified as well. |
|
5 |
#' |
|
6 |
#' @param ds A named list of datasets in long format as compatible with |
|
7 |
#' \code{\link{mkinfit}}. |
|
8 |
#' @param map A character vector with CAKE compartment names (Parent, A1, ...), |
|
9 |
#' named with the names used in the list of datasets. |
|
10 |
#' @param links An optional character vector of target compartments, named with |
|
11 |
#' the names of the source compartments. In order to make this easier, the |
|
12 |
#' names are used as in the datasets supplied. |
|
13 |
#' @param filename Where to write the result. Should end in .csf in order to be |
|
14 |
#' compatible with CAKE. |
|
15 |
#' @param path An optional path to the output file. |
|
16 |
#' @param overwrite If TRUE, existing files are overwritten. |
|
17 |
#' @param study The name of the study. |
|
18 |
#' @param description An optional description. |
|
19 |
#' @param time_unit The time unit for the residue data. |
|
20 |
#' @param res_unit The unit used for the residues. |
|
21 |
#' @param comment An optional comment. |
|
22 |
#' @param date The date of file creation. |
|
23 |
#' @param optimiser Can be OLS or IRLS. |
|
24 |
#' @importFrom utils write.table |
|
25 |
#' @return The function is called for its side effect. |
|
26 |
#' @author Johannes Ranke |
|
27 |
#' @export |
|
28 |
CAKE_export <- function(ds, map = c(parent = "Parent"), |
|
29 |
links = NA, |
|
30 |
filename = "CAKE_export.csf", path = ".", overwrite = FALSE, |
|
31 |
study = "Degradinol aerobic soil degradation", |
|
32 |
description = "", |
|
33 |
time_unit = "days", |
|
34 |
res_unit = "% AR", |
|
35 |
comment = "", |
|
36 |
date = Sys.Date(), |
|
37 |
optimiser = "IRLS") |
|
38 |
{ |
|
39 | 741x |
file <- file.path(path, filename) |
40 | 247x |
if (file.exists(file) & !overwrite) stop(file, " already exists, stopping") |
41 | 494x |
csf <- file(file, encoding = "latin1", open = "w+") |
42 | 494x |
on.exit(close(csf)) |
43 | ||
44 | 494x |
CAKE_compartments = c("Parent", "A1", "A2", "A3", "B1", "B2", "C1") |
45 | 494x |
if (!all(map %in% CAKE_compartments)) { |
46 | 247x |
stop("The elements of map have to be CAKE compartment names") |
47 |
} |
|
48 | ||
49 | 247x |
add <- function(x) cat(paste0(x, "\r\n"), file = csf, append = TRUE) |
50 | 247x |
add0 <- function(x) cat(x, file = csf, append = TRUE) |
51 | ||
52 | 247x |
add("[FileInfo]") |
53 | 247x |
add("CAKE-Version: 3.4 (Release)") |
54 | 247x |
add(paste("Name:", study)) |
55 | 247x |
add(paste("Description:", description)) |
56 | 247x |
add(paste("MeasurementUnits:", res_unit)) |
57 | 247x |
add(paste("TimeUnits:", time_unit)) |
58 | 247x |
add(paste("Comments:", comment)) |
59 | 247x |
add(paste("Date:", date)) |
60 | 247x |
add(paste("Optimiser:", optimiser)) |
61 | 247x |
add("") |
62 | ||
63 | 247x |
add("[Data]") |
64 | ||
65 | 247x |
for (i in seq_along(ds)) { |
66 | 494x |
add(paste("NewDataSet:", names(ds)[i])) |
67 | 494x |
d <- mkin_long_to_wide(ds[[i]]) |
68 | 494x |
names(d) <- c("Time", map[names(d)[-1]]) |
69 | 494x |
write.table(d, csf, |
70 | 494x |
sep = "\t", col.names = TRUE, |
71 | 494x |
row.names = FALSE, |
72 | 494x |
quote = FALSE, eol = "\r\n", na = "") |
73 | 494x |
add("") |
74 |
} |
|
75 | ||
76 | 247x |
if (!is.na(links)) { |
77 | 247x |
add("") |
78 | 247x |
add("[Model]") |
79 | 247x |
add(paste0("ParentCompartment: Parent\t", names(map)[1], "\t", names(map)[1])) |
80 | 247x |
for (name in names(map)[-1]) { |
81 | 247x |
add(paste0("Compartment: ", map[name], "\t", name, "\t", name)) |
82 |
} |
|
83 | 247x |
for (li in names(links)) { |
84 | 247x |
add(paste0("Link: ", map[li], "\t", map[links[li]], "\t0.5\t0\t1\tFree\tExplicit")) |
85 |
} |
|
86 | ||
87 |
} |
|
88 | ||
89 | 247x |
add("") |
90 | 247x |
add("[ComponentNames]") |
91 | 247x |
for (name in names(map)) { |
92 | 494x |
add(paste0(map[name], ":", name)) |
93 |
} |
|
94 | ||
95 |
} |
1 |
#' Display the output of a summary function according to the output format |
|
2 |
#' |
|
3 |
#' This function is intended for use in a R markdown code chunk with the chunk |
|
4 |
#' option `results = "asis"`. |
|
5 |
#' |
|
6 |
#' @param object The object for which the summary is to be listed |
|
7 |
#' @param caption An optional caption |
|
8 |
#' @param label An optional label, ignored in html output |
|
9 |
#' @param clearpage Should a new page be started after the listing? Ignored in html output |
|
10 |
#' @export |
|
11 |
summary_listing <- function(object, caption = NULL, label = NULL, |
|
12 |
clearpage = TRUE) { |
|
13 | ! |
if (knitr::is_latex_output()) { |
14 | ! |
tex_listing(object = object, caption = caption, label = label, |
15 | ! |
clearpage = clearpage) |
16 |
} |
|
17 | ! |
if (knitr::is_html_output()) { |
18 | ! |
html_listing(object = object, caption = caption) |
19 |
} |
|
20 |
} |
|
21 | ||
22 |
#' @rdname summary_listing |
|
23 |
#' @export |
|
24 |
tex_listing <- function(object, caption = NULL, label = NULL, |
|
25 |
clearpage = TRUE) { |
|
26 | ! |
cat("\n") |
27 | ! |
cat("\\begin{listing}", "\n") |
28 | ! |
if (!is.null(caption)) { |
29 | ! |
cat("\\caption{", caption, "}", "\n", sep = "") |
30 |
} |
|
31 | ! |
if (!is.null(label)) { |
32 | ! |
cat("\\caption{", label, "}", "\n", sep = "") |
33 |
} |
|
34 | ! |
cat("\\begin{snugshade}", "\n") |
35 | ! |
cat("\\scriptsize", "\n") |
36 | ! |
cat("\\begin{verbatim}", "\n") |
37 | ! |
cat(capture.output(suppressWarnings(summary(object))), sep = "\n") |
38 | ! |
cat("\n") |
39 | ! |
cat("\\end{verbatim}", "\n") |
40 | ! |
cat("\\end{snugshade}", "\n") |
41 | ! |
cat("\\end{listing}", "\n") |
42 | ! |
if (clearpage) { |
43 | ! |
cat("\\clearpage", "\n") |
44 |
} |
|
45 |
} |
|
46 | ||
47 |
#' @rdname summary_listing |
|
48 |
#' @export |
|
49 |
html_listing <- function(object, caption = NULL) { |
|
50 | ! |
cat("\n") |
51 | ! |
if (!is.null(caption)) { |
52 | ! |
cat("<caption>", caption, "</caption>", "\n", sep = "") |
53 |
} |
|
54 | ! |
cat("<pre><code>\n") |
55 | ! |
cat(capture.output(suppressWarnings(summary(object))), sep = "\n") |
56 | ! |
cat("\n") |
57 | ! |
cat("</pre></code>\n") |
58 |
} |
|
59 |
1 |
#' Perform a hierarchical model fit with multiple starting values |
|
2 |
#' |
|
3 |
#' The purpose of this method is to check if a certain algorithm for fitting |
|
4 |
#' nonlinear hierarchical models (also known as nonlinear mixed-effects models) |
|
5 |
#' will reliably yield results that are sufficiently similar to each other, if |
|
6 |
#' started with a certain range of reasonable starting parameters. It is |
|
7 |
#' inspired by the article on practical identifiabiliy in the frame of nonlinear |
|
8 |
#' mixed-effects models by Duchesne et al (2021). |
|
9 |
#' |
|
10 |
#' @param object The fit object to work with |
|
11 |
#' @param n How many different combinations of starting parameters should be |
|
12 |
#' used? |
|
13 |
#' @param cores How many fits should be run in parallel (only on posix platforms)? |
|
14 |
#' @param cluster A cluster as returned by [parallel::makeCluster] to be used |
|
15 |
#' for parallel execution. |
|
16 |
#' @param \dots Passed to the update function. |
|
17 |
#' @param x The multistart object to print |
|
18 |
#' @return A list of [saem.mmkin] objects, with class attributes |
|
19 |
#' 'multistart.saem.mmkin' and 'multistart'. |
|
20 |
#' @seealso [parplot], [llhist] |
|
21 |
#' |
|
22 |
#' @references Duchesne R, Guillemin A, Gandrillon O, Crauste F. Practical |
|
23 |
#' identifiability in the frame of nonlinear mixed effects models: the example |
|
24 |
#' of the in vitro erythropoiesis. BMC Bioinformatics. 2021 Oct 4;22(1):478. |
|
25 |
#' doi: 10.1186/s12859-021-04373-4. |
|
26 |
#' @export |
|
27 |
#' @examples |
|
28 |
#' \dontrun{ |
|
29 |
#' library(mkin) |
|
30 |
#' dmta_ds <- lapply(1:7, function(i) { |
|
31 |
#' ds_i <- dimethenamid_2018$ds[[i]]$data |
|
32 |
#' ds_i[ds_i$name == "DMTAP", "name"] <- "DMTA" |
|
33 |
#' ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i] |
|
34 |
#' ds_i |
|
35 |
#' }) |
|
36 |
#' names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title) |
|
37 |
#' dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]]) |
|
38 |
#' dmta_ds[["Elliot 1"]] <- dmta_ds[["Elliot 2"]] <- NULL |
|
39 |
#' |
|
40 |
#' f_mmkin <- mmkin("DFOP", dmta_ds, error_model = "tc", cores = 7, quiet = TRUE) |
|
41 |
#' f_saem_full <- saem(f_mmkin) |
|
42 |
#' f_saem_full_multi <- multistart(f_saem_full, n = 16, cores = 16) |
|
43 |
#' parplot(f_saem_full_multi, lpos = "topleft") |
|
44 |
#' illparms(f_saem_full) |
|
45 |
#' |
|
46 |
#' f_saem_reduced <- update(f_saem_full, no_random_effect = "log_k2") |
|
47 |
#' illparms(f_saem_reduced) |
|
48 |
#' # On Windows, we need to create a PSOCK cluster first and refer to it |
|
49 |
#' # in the call to multistart() |
|
50 |
#' library(parallel) |
|
51 |
#' cl <- makePSOCKcluster(12) |
|
52 |
#' f_saem_reduced_multi <- multistart(f_saem_reduced, n = 16, cluster = cl) |
|
53 |
#' parplot(f_saem_reduced_multi, lpos = "topright", ylim = c(0.5, 2)) |
|
54 |
#' stopCluster(cl) |
|
55 |
#' } |
|
56 |
multistart <- function(object, n = 50, |
|
57 |
cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), |
|
58 |
cluster = NULL, ...) |
|
59 |
{ |
|
60 | 200x |
UseMethod("multistart", object) |
61 |
} |
|
62 | ||
63 |
#' @rdname multistart |
|
64 |
#' @export |
|
65 |
multistart.saem.mmkin <- function(object, n = 50, cores = 1, |
|
66 |
cluster = NULL, ...) { |
|
67 | 200x |
call <- match.call() |
68 | ! |
if (n <= 1) stop("Please specify an n of at least 2") |
69 | ||
70 | 200x |
mmkin_object <- object$mmkin |
71 | ||
72 | 200x |
mmkin_parms <- parms(mmkin_object, errparms = FALSE, |
73 | 200x |
transformed = object$transformations == "mkin") |
74 | 200x |
start_parms <- apply( |
75 | 200x |
mmkin_parms, 1, |
76 | 200x |
function(x) stats::runif(n, min(x), max(x))) |
77 | ||
78 | 200x |
saem_call <- object$call |
79 | 200x |
saem_call[[1]] <- saem |
80 | 200x |
saem_call[[2]] <- mmkin_object |
81 | 200x |
i_startparms <- which(names(saem_call) == "degparms_start") |
82 | ||
83 | 200x |
fit_function <- function(x) { |
84 | ||
85 | 16x |
new_startparms <- str2lang( |
86 | 16x |
paste0(capture.output(dput(start_parms[x, ])), |
87 | 16x |
collapse = "")) |
88 | ||
89 | 16x |
if (length(i_startparms) == 0) { |
90 | 16x |
saem_call <- c(as.list(saem_call), degparms_start = new_startparms) |
91 | 16x |
saem_call <- as.call(saem_call) |
92 |
} else { |
|
93 | ! |
saem_call[i_startparms] <- new_startparms |
94 |
} |
|
95 | ||
96 | 16x |
ret <- eval(saem_call) |
97 | ||
98 | 16x |
return(ret) |
99 |
} |
|
100 | ||
101 | 200x |
if (is.null(cluster)) { |
102 | 200x |
res <- parallel::mclapply(1:n, fit_function, |
103 | 200x |
mc.cores = cores, mc.preschedule = FALSE) |
104 |
} else { |
|
105 | ! |
res <- parallel::parLapplyLB(cluster, 1:n, fit_function) |
106 |
} |
|
107 | 184x |
attr(res, "orig") <- object |
108 | 184x |
attr(res, "start_parms") <- start_parms |
109 | 184x |
attr(res, "call") <- call |
110 | 184x |
class(res) <- c("multistart.saem.mmkin", "multistart") |
111 | 184x |
return(res) |
112 |
} |
|
113 | ||
114 |
#' @export |
|
115 |
status.multistart <- function(object, ...) { |
|
116 | ! |
all_summary_warnings <- character() |
117 | ||
118 | ! |
result <- lapply(object, |
119 | ! |
function(fit) { |
120 | ! |
if (inherits(fit, "try-error")) return("E") |
121 |
else { |
|
122 | ! |
return("OK") |
123 |
} |
|
124 |
}) |
|
125 | ! |
result <- unlist(result) |
126 | ||
127 | ! |
class(result) <- "status.multistart" |
128 | ! |
return(result) |
129 |
} |
|
130 | ||
131 |
#' @export |
|
132 |
status.multistart.saem.mmkin <- function(object, ...) { |
|
133 | 88x |
all_summary_warnings <- character() |
134 | ||
135 | 88x |
result <- lapply(object, |
136 | 88x |
function(fit) { |
137 | ! |
if (inherits(fit$so, "try-error")) return("E") |
138 |
else { |
|
139 | 704x |
return("OK") |
140 |
} |
|
141 |
}) |
|
142 | 88x |
result <- unlist(result) |
143 | ||
144 | 88x |
class(result) <- "status.multistart" |
145 | 88x |
return(result) |
146 |
} |
|
147 | ||
148 |
#' @export |
|
149 |
print.status.multistart <- function(x, ...) { |
|
150 | 88x |
class(x) <- NULL |
151 | 88x |
print(table(x, dnn = NULL)) |
152 | 88x |
if (any(x == "OK")) cat("OK: Fit terminated successfully\n") |
153 | ! |
if (any(x == "E")) cat("E: Error\n") |
154 |
} |
|
155 | ||
156 |
#' @rdname multistart |
|
157 |
#' @export |
|
158 |
print.multistart <- function(x, ...) { |
|
159 | 88x |
cat("<multistart> object with", length(x), "fits:\n") |
160 | 88x |
print(status(x)) |
161 |
} |
|
162 | ||
163 |
#' @rdname multistart |
|
164 |
#' @export |
|
165 |
best <- function(object, ...) |
|
166 |
{ |
|
167 | 184x |
UseMethod("best", object) |
168 |
} |
|
169 | ||
170 |
#' @export |
|
171 |
#' @return The object with the highest likelihood |
|
172 |
#' @rdname multistart |
|
173 |
best.default <- function(object, ...) |
|
174 |
{ |
|
175 | 184x |
return(object[[which.best(object)]]) |
176 |
} |
|
177 | ||
178 |
#' @return The index of the object with the highest likelihood |
|
179 |
#' @rdname multistart |
|
180 |
#' @export |
|
181 |
which.best <- function(object, ...) |
|
182 |
{ |
|
183 | 360x |
UseMethod("which.best", object) |
184 |
} |
|
185 | ||
186 |
#' @rdname multistart |
|
187 |
#' @export |
|
188 |
which.best.default <- function(object, ...) |
|
189 |
{ |
|
190 | 360x |
llfunc <- function(object) { |
191 | 2528x |
ret <- try(logLik(object)) |
192 | ! |
if (inherits(ret, "try-error")) return(NA) |
193 | 2528x |
else return(ret) |
194 |
} |
|
195 | 360x |
ll <- sapply(object, llfunc) |
196 | 360x |
return(which.max(ll)) |
197 |
} |
|
198 | ||
199 |
#' @export |
|
200 |
update.multistart <- function(object, ..., evaluate = TRUE) { |
|
201 | ! |
call <- attr(object, "call") |
202 |
# For some reason we get multistart.saem.mmkin in call[[1]] when using multistart |
|
203 |
# from the loaded package so we need to fix this so we do not have to export |
|
204 |
# multistart.saem.mmkin |
|
205 | ! |
call[[1]] <- multistart |
206 | ||
207 | ! |
update_arguments <- match.call(expand.dots = FALSE)$... |
208 | ||
209 | ! |
if (length(update_arguments) > 0) { |
210 | ! |
update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) |
211 |
} |
|
212 | ||
213 | ! |
for (a in names(update_arguments)[update_arguments_in_call]) { |
214 | ! |
call[[a]] <- update_arguments[[a]] |
215 |
} |
|
216 | ||
217 | ! |
update_arguments_not_in_call <- !update_arguments_in_call |
218 | ! |
if(any(update_arguments_not_in_call)) { |
219 | ! |
call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) |
220 | ! |
call <- as.call(call) |
221 |
} |
|
222 | ! |
if(evaluate) eval(call, parent.frame()) |
223 | ! |
else call |
224 |
} |
1 |
#' @importFrom lmtest lrtest |
|
2 |
#' @export |
|
3 |
lmtest::lrtest |
|
4 | ||
5 |
#' Likelihood ratio test for mkinfit models |
|
6 |
#' |
|
7 |
#' Compare two mkinfit models based on their likelihood. If two fitted |
|
8 |
#' mkinfit objects are given as arguments, it is checked if they have been |
|
9 |
#' fitted to the same data. It is the responsibility of the user to make sure |
|
10 |
#' that the models are nested, i.e. one of them has less degrees of freedom |
|
11 |
#' and can be expressed by fixing the parameters of the other. |
|
12 |
#' |
|
13 |
#' Alternatively, an argument to mkinfit can be given which is then passed |
|
14 |
#' to \code{\link{update.mkinfit}} to obtain the alternative model. |
|
15 |
#' |
|
16 |
#' The comparison is then made by the \code{\link[lmtest]{lrtest.default}} |
|
17 |
#' method from the lmtest package. The model with the higher number of fitted |
|
18 |
#' parameters (alternative hypothesis) is listed first, then the model with the |
|
19 |
#' lower number of fitted parameters (null hypothesis). |
|
20 |
#' |
|
21 |
#' @importFrom stats logLik update |
|
22 |
#' @param object An \code{\link{mkinfit}} object, or an \code{\link{mmkin}} column |
|
23 |
#' object containing two fits to the same data. |
|
24 |
#' @param object_2 Optionally, another mkinfit object fitted to the same data. |
|
25 |
#' @param \dots Argument to \code{\link{mkinfit}}, passed to |
|
26 |
#' \code{\link{update.mkinfit}} for creating the alternative fitted object. |
|
27 |
#' @examples |
|
28 |
#' \dontrun{ |
|
29 |
#' test_data <- subset(synthetic_data_for_UBA_2014[[12]]$data, name == "parent") |
|
30 |
#' sfo_fit <- mkinfit("SFO", test_data, quiet = TRUE) |
|
31 |
#' dfop_fit <- mkinfit("DFOP", test_data, quiet = TRUE) |
|
32 |
#' lrtest(dfop_fit, sfo_fit) |
|
33 |
#' lrtest(sfo_fit, dfop_fit) |
|
34 |
#' |
|
35 |
#' # The following two examples are commented out as they fail during |
|
36 |
#' # generation of the static help pages by pkgdown |
|
37 |
#' #lrtest(dfop_fit, error_model = "tc") |
|
38 |
#' #lrtest(dfop_fit, fixed_parms = c(k2 = 0)) |
|
39 |
#' |
|
40 |
#' # However, this equivalent syntax also works for static help pages |
|
41 |
#' lrtest(dfop_fit, update(dfop_fit, error_model = "tc")) |
|
42 |
#' lrtest(dfop_fit, update(dfop_fit, fixed_parms = c(k2 = 0))) |
|
43 |
#' } |
|
44 |
#' @export |
|
45 |
lrtest.mkinfit <- function(object, object_2 = NULL, ...) { |
|
46 | ||
47 | 6x |
name_function <- function(x) { |
48 | 10x |
object_name <- paste(x$mkinmod$name, "with error model", x$err_mod) |
49 | 10x |
if (length(x$bparms.fixed) > 0) { |
50 | 7x |
object_name <- paste(object_name, |
51 | 7x |
"and fixed parameter(s)", |
52 | 7x |
paste(names(x$bparms.fixed), collapse = ", ")) |
53 |
} |
|
54 | 10x |
return(object_name) |
55 |
} |
|
56 | ||
57 | 6x |
if (is.null(object_2)) { |
58 | ! |
object_2 <- update(object, ...) |
59 |
} else { |
|
60 | 6x |
data_object <- object$data[c("time", "variable", "observed")] |
61 | 6x |
data_object_2 <- object_2$data[c("time", "variable", "observed")] |
62 | 6x |
if (!identical(data_object, data_object_2)) { |
63 | 1x |
stop("It seems that the mkinfit objects have not been fitted to the same data") |
64 |
} |
|
65 |
} |
|
66 | 5x |
if (attr(logLik(object), "df") > attr(logLik(object_2), "df")) { |
67 | 2x |
lmtest::lrtest.default(object, object_2, name = name_function) |
68 |
} else { |
|
69 | 3x |
lmtest::lrtest.default(object_2, object, name = name_function) |
70 |
} |
|
71 |
} |
|
72 | ||
73 |
#' @rdname lrtest.mkinfit |
|
74 |
#' @export |
|
75 |
lrtest.mmkin <- function(object, ...) { |
|
76 | ! |
if (nrow(object) != 2 | ncol(object) > 1) stop("Only works for a column containing two mkinfit objects") |
77 | ! |
object[[1, 1]]$mkinmod$name <- rownames(object)[1] |
78 | ! |
object[[2, 1]]$mkinmod$name <- rownames(object)[2] |
79 | ! |
lrtest(object[[1, 1]], object[[2, 1]]) |
80 |
} |
1 |
#' Calculate Akaike weights for model averaging |
|
2 |
#' |
|
3 |
#' Akaike weights are calculated based on the relative |
|
4 |
#' expected Kullback-Leibler information as specified |
|
5 |
#' by Burnham and Anderson (2004). |
|
6 |
#' |
|
7 |
#' @param object An [mmkin] column object, containing two or more |
|
8 |
#' [mkinfit] models that have been fitted to the same data, |
|
9 |
#' or an mkinfit object. In the latter case, further mkinfit |
|
10 |
#' objects fitted to the same data should be specified |
|
11 |
#' as dots arguments. |
|
12 |
#' @param \dots Not used in the method for [mmkin] column objects, |
|
13 |
#' further [mkinfit] objects in the method for mkinfit objects. |
|
14 |
#' @references Burnham KP and Anderson DR (2004) Multimodel |
|
15 |
#' Inference: Understanding AIC and BIC in Model Selection. |
|
16 |
#' *Sociological Methods & Research* **33**(2) 261-304 |
|
17 |
#' @md |
|
18 |
#' @examples |
|
19 |
#' \dontrun{ |
|
20 |
#' f_sfo <- mkinfit("SFO", FOCUS_2006_D, quiet = TRUE) |
|
21 |
#' f_dfop <- mkinfit("DFOP", FOCUS_2006_D, quiet = TRUE) |
|
22 |
#' aw_sfo_dfop <- aw(f_sfo, f_dfop) |
|
23 |
#' sum(aw_sfo_dfop) |
|
24 |
#' aw_sfo_dfop # SFO gets more weight as it has less parameters and a similar fit |
|
25 |
#' f <- mmkin(c("SFO", "FOMC", "DFOP"), list("FOCUS D" = FOCUS_2006_D), cores = 1, quiet = TRUE) |
|
26 |
#' aw(f) |
|
27 |
#' sum(aw(f)) |
|
28 |
#' aw(f[c("SFO", "DFOP")]) |
|
29 |
#' } |
|
30 |
#' @export |
|
31 | 1482x |
aw <- function(object, ...) UseMethod("aw") |
32 | ||
33 |
.aw <- function(all_objects) { |
|
34 | 494x |
AIC_all <- sapply(all_objects, AIC) |
35 | 494x |
delta_i <- AIC_all - min(AIC_all) |
36 | 494x |
denom <- sum(exp(-delta_i/2)) |
37 | 494x |
w_i <- exp(-delta_i/2) / denom |
38 | 494x |
return(w_i) |
39 |
} |
|
40 | ||
41 |
#' @export |
|
42 |
#' @rdname aw |
|
43 |
aw.mkinfit <- function(object, ...) { |
|
44 | 988x |
oo <- list(...) |
45 | 988x |
data_object <- object$data[c("time", "variable", "observed")] |
46 | 988x |
for (i in seq_along(oo)) { |
47 | 247x |
if (!inherits(oo[[i]], "mkinfit")) stop("Please supply only mkinfit objects") |
48 | 988x |
data_other_object <- oo[[i]]$data[c("time", "variable", "observed")] |
49 | 988x |
if (!identical(data_object, data_other_object)) { |
50 | 247x |
stop("It seems that the mkinfit objects have not all been fitted to the same data") |
51 |
} |
|
52 |
} |
|
53 | 494x |
all_objects <- list(object, ...) |
54 | 494x |
.aw(all_objects) |
55 |
} |
|
56 | ||
57 |
#' @export |
|
58 |
#' @rdname aw |
|
59 |
aw.mmkin <- function(object, ...) { |
|
60 | 247x |
if (ncol(object) > 1) stop("Please supply an mmkin column object") |
61 | 247x |
do.call(aw, object) |
62 |
} |
|
63 | ||
64 |
#' @export |
|
65 |
#' @rdname aw |
|
66 |
aw.mixed.mmkin <- function(object, ...) { |
|
67 | ! |
oo <- list(...) |
68 | ! |
data_object <- object$data[c("ds", "name", "time", "value")] |
69 | ! |
for (i in seq_along(oo)) { |
70 | ! |
if (!inherits(oo[[i]], "mixed.mmkin")) stop("Please supply objects inheriting from mixed.mmkin") |
71 | ! |
data_other_object <- oo[[i]]$data[c("ds", "name", "time", "value")] |
72 | ! |
if (!identical(data_object, data_other_object)) { |
73 | ! |
stop("It seems that the mixed.mmkin objects have not all been fitted to the same data") |
74 |
} |
|
75 |
} |
|
76 | ! |
all_objects <- list(object, ...) |
77 | ! |
.aw(all_objects) |
78 |
} |
|
79 | ||
80 |
#' @export |
|
81 |
#' @rdname aw |
|
82 |
aw.multistart <- function(object, ...) { |
|
83 | ! |
do.call(aw, object) |
84 |
} |
1 |
#' Calculate mean degradation parameters for an mmkin row object |
|
2 |
#' |
|
3 |
#' @return If random is FALSE (default), a named vector containing mean values |
|
4 |
#' of the fitted degradation model parameters. If random is TRUE, a list with |
|
5 |
#' fixed and random effects, in the format required by the start argument of |
|
6 |
#' nlme for the case of a single grouping variable ds. |
|
7 |
#' @param object An mmkin row object containing several fits of the same model to different datasets |
|
8 |
#' @param random Should a list with fixed and random effects be returned? |
|
9 |
#' @param test_log_parms If TRUE, log parameters are only considered in |
|
10 |
#' the mean calculations if their untransformed counterparts (most likely |
|
11 |
#' rate constants) pass the t-test for significant difference from zero. |
|
12 |
#' @param conf.level Possibility to adjust the required confidence level |
|
13 |
#' for parameter that are tested if requested by 'test_log_parms'. |
|
14 |
#' @param default_log_parms If set to a numeric value, this is used |
|
15 |
#' as a default value for the tested log parameters that failed the |
|
16 |
#' t-test. |
|
17 |
#' @export |
|
18 |
mean_degparms <- function(object, random = FALSE, test_log_parms = FALSE, conf.level = 0.6, |
|
19 |
default_log_parms = NA) |
|
20 |
{ |
|
21 | ! |
if (nrow(object) > 1) stop("Only row objects allowed") |
22 | 7271x |
parm_mat_trans <- sapply(object, parms, transformed = TRUE) |
23 | ||
24 | 7271x |
if (test_log_parms) { |
25 | 4668x |
parm_mat_dim <- dim(parm_mat_trans) |
26 | 4668x |
parm_mat_dimnames <- dimnames(parm_mat_trans) |
27 | ||
28 | 4668x |
log_parm_trans_names <- grep("^log_", rownames(parm_mat_trans), value = TRUE) |
29 | 4668x |
log_parm_names <- gsub("^log_", "", log_parm_trans_names) |
30 | ||
31 | 4668x |
t_test_back_OK <- matrix( |
32 | 4668x |
sapply(object, function(o) { |
33 | 49860x |
suppressWarnings(summary(o)$bpar[log_parm_names, "Pr(>t)"] < (1 - conf.level)) |
34 | 4668x |
}), nrow = length(log_parm_names)) |
35 | 4668x |
rownames(t_test_back_OK) <- log_parm_trans_names |
36 | ||
37 | 4668x |
parm_mat_trans_OK <- parm_mat_trans |
38 | 4668x |
for (trans_parm in log_parm_trans_names) { |
39 | 9398x |
parm_mat_trans_OK[trans_parm, ] <- ifelse(t_test_back_OK[trans_parm, ], |
40 | 9398x |
parm_mat_trans[trans_parm, ], log(default_log_parms)) |
41 |
} |
|
42 |
} else { |
|
43 | 2603x |
parm_mat_trans_OK <- parm_mat_trans |
44 |
} |
|
45 | ||
46 | 7271x |
mean_degparm_names <- setdiff(rownames(parm_mat_trans), names(object[[1]]$errparms)) |
47 | 7271x |
degparm_mat_trans <- parm_mat_trans[mean_degparm_names, , drop = FALSE] |
48 | 7271x |
degparm_mat_trans_OK <- parm_mat_trans_OK[mean_degparm_names, , drop = FALSE] |
49 | ||
50 |
# fixed in the sense of fixed effects, as this function was |
|
51 |
# written to supply starting parameters for nlme |
|
52 | 7271x |
fixed <- apply(degparm_mat_trans_OK, 1, mean, na.rm = TRUE) |
53 | 7271x |
if (random) { |
54 | 2322x |
random <- t(apply(degparm_mat_trans[mean_degparm_names, , drop = FALSE], 2, function(column) column - fixed)) |
55 |
# If we only have one parameter, apply returns a vector so we get a single row |
|
56 | ! |
if (nrow(degparm_mat_trans) == 1) random <- t(random) |
57 | 2322x |
rownames(random) <- levels(nlme_data(object)$ds) |
58 | ||
59 |
# For nlmixr we can specify starting values for standard deviations eta, and |
|
60 |
# we ignore uncertain parameters if test_log_parms is FALSE |
|
61 | 2322x |
eta <- apply(degparm_mat_trans_OK, 1, stats::sd, na.rm = TRUE) |
62 | ||
63 | 2322x |
return(list(fixed = fixed, random = list(ds = random), eta = eta)) |
64 |
} else { |
|
65 | 4949x |
return(fixed) |
66 |
} |
|
67 |
} |
|
68 |
1 |
# This file is part of the R package mkin |
|
2 | ||
3 |
# mkin is free software: you can redistribute it and/or modify it under the |
|
4 |
# terms of the GNU General Public License as published by the Free Software |
|
5 |
# Foundation, either version 3 of the License, or (at your option) any later |
|
6 |
# version. |
|
7 | ||
8 |
# This program is distributed in the hope that it will be useful, but WITHOUT |
|
9 |
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS |
|
10 |
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more |
|
11 |
# details. |
|
12 | ||
13 |
# You should have received a copy of the GNU General Public License along with |
|
14 |
# this program. If not, see <http://www.gnu.org/licenses/> |
|
15 | ||
16 |
#' Function to perform isometric log-ratio transformation |
|
17 |
#' |
|
18 |
#' This implementation is a special case of the class of isometric log-ratio |
|
19 |
#' transformations. |
|
20 |
#' |
|
21 |
#' @aliases ilr invilr |
|
22 |
#' @param x A numeric vector. Naturally, the forward transformation is only |
|
23 |
#' sensible for vectors with all elements being greater than zero. |
|
24 |
#' @return The result of the forward or backward transformation. The returned |
|
25 |
#' components always sum to 1 for the case of the inverse log-ratio |
|
26 |
#' transformation. |
|
27 |
#' @author René Lehmann and Johannes Ranke |
|
28 |
#' @seealso Another implementation can be found in R package |
|
29 |
#' \code{robCompositions}. |
|
30 |
#' @references Peter Filzmoser, Karel Hron (2008) Outlier Detection for |
|
31 |
#' Compositional Data Using Robust Methods. Math Geosci 40 233-248 |
|
32 |
#' @keywords manip |
|
33 |
#' @examples |
|
34 |
#' |
|
35 |
#' # Order matters |
|
36 |
#' ilr(c(0.1, 1, 10)) |
|
37 |
#' ilr(c(10, 1, 0.1)) |
|
38 |
#' # Equal entries give ilr transformations with zeros as elements |
|
39 |
#' ilr(c(3, 3, 3)) |
|
40 |
#' # Almost equal entries give small numbers |
|
41 |
#' ilr(c(0.3, 0.4, 0.3)) |
|
42 |
#' # Only the ratio between the numbers counts, not their sum |
|
43 |
#' invilr(ilr(c(0.7, 0.29, 0.01))) |
|
44 |
#' invilr(ilr(2.1 * c(0.7, 0.29, 0.01))) |
|
45 |
#' # Inverse transformation of larger numbers gives unequal elements |
|
46 |
#' invilr(-10) |
|
47 |
#' invilr(c(-10, 0)) |
|
48 |
#' # The sum of the elements of the inverse ilr is 1 |
|
49 |
#' sum(invilr(c(-10, 0))) |
|
50 |
#' # This is why we do not need all elements of the inverse transformation to go back: |
|
51 |
#' a <- c(0.1, 0.3, 0.5) |
|
52 |
#' b <- invilr(a) |
|
53 |
#' length(b) # Four elements |
|
54 |
#' ilr(c(b[1:3], 1 - sum(b[1:3]))) # Gives c(0.1, 0.3, 0.5) |
|
55 |
#' |
|
56 |
#' @export |
|
57 |
ilr <- function(x) { |
|
58 | 16x |
z <- vector() |
59 | 16x |
for (i in 1:(length(x) - 1)) { |
60 | 44x |
z[i] <- sqrt(i/(i+1)) * log((prod(x[1:i]))^(1/i) / x[i+1]) |
61 |
} |
|
62 | 16x |
return(z) |
63 |
} |
|
64 | ||
65 |
#' @rdname ilr |
|
66 |
#' @export |
|
67 |
invilr<-function(x) { |
|
68 | 529301x |
D <- length(x) + 1 |
69 | 529301x |
z <- c(x, 0) |
70 | 529301x |
y <- rep(0, D) |
71 | 529301x |
s <- sqrt(1:D*2:(D+1)) |
72 | 529301x |
q <- z/s |
73 | 529301x |
y[1] <- sum(q[1:D]) |
74 | 529301x |
for (i in 2:D) { |
75 | 1585969x |
y[i] <- sum(q[i:D]) - sqrt((i-1)/i) * z[i-1] |
76 |
} |
|
77 | 529301x |
z <- vector() |
78 | 529301x |
for (i in 1:D) { |
79 | 2115270x |
z[i] <- exp(y[i])/sum(exp(y)) |
80 |
} |
|
81 | ||
82 |
# Work around a numerical problem with NaN values returned by the above |
|
83 |
# Only works if there is only one NaN value: replace it with 1 |
|
84 |
# if the sum of the other components is < 1e-10 |
|
85 | 529301x |
if (sum(is.na(z)) == 1 && sum(z[!is.na(z)]) < 1e-10) |
86 | ! |
z = ifelse(is.na(z), 1, z) |
87 | ||
88 | 529301x |
return(z) |
89 |
} |
1 |
#' Function to calculate maximum time weighted average concentrations from |
|
2 |
#' kinetic models fitted with mkinfit |
|
3 |
#' |
|
4 |
#' This function calculates maximum moving window time weighted average |
|
5 |
#' concentrations (TWAs) for kinetic models fitted with \code{\link{mkinfit}}. |
|
6 |
#' Currently, only calculations for the parent are implemented for the SFO, |
|
7 |
#' FOMC, DFOP and HS models, using the analytical formulas given in the PEC |
|
8 |
#' soil section of the FOCUS guidance. |
|
9 |
#' |
|
10 |
#' @aliases max_twa_parent max_twa_sfo max_twa_fomc max_twa_dfop max_twa_hs |
|
11 |
#' @param fit An object of class \code{\link{mkinfit}}. |
|
12 |
#' @param windows The width of the time windows for which the TWAs should be |
|
13 |
#' calculated. |
|
14 |
#' @param M0 The initial concentration for which the maximum time weighted |
|
15 |
#' average over the decline curve should be calculated. The default is to use |
|
16 |
#' a value of 1, which means that a relative maximum time weighted average |
|
17 |
#' factor (f_twa) is calculated. |
|
18 |
#' @param k The rate constant in the case of SFO kinetics. |
|
19 |
#' @param t The width of the time window. |
|
20 |
#' @param alpha Parameter of the FOMC model. |
|
21 |
#' @param beta Parameter of the FOMC model. |
|
22 |
#' @param k1 The first rate constant of the DFOP or the HS kinetics. |
|
23 |
#' @param k2 The second rate constant of the DFOP or the HS kinetics. |
|
24 |
#' @param g Parameter of the DFOP model. |
|
25 |
#' @param tb Parameter of the HS model. |
|
26 |
#' @return For \code{max_twa_parent}, a numeric vector, named using the |
|
27 |
#' \code{windows} argument. For the other functions, a numeric vector of |
|
28 |
#' length one (also known as 'a number'). |
|
29 |
#' @author Johannes Ranke |
|
30 |
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
31 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
32 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
33 |
#' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
34 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
35 |
#' @examples |
|
36 |
#' |
|
37 |
#' fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE) |
|
38 |
#' max_twa_parent(fit, c(7, 21)) |
|
39 |
#' |
|
40 |
#' @export |
|
41 |
max_twa_parent <- function(fit, windows) { |
|
42 | 4x |
parms.all <- c(fit$bparms.optim, fit$bparms.fixed) |
43 | 4x |
obs_vars <- fit$obs_vars |
44 | 4x |
if (length(obs_vars) > 1) { |
45 | ! |
warning("Calculation of maximum time weighted average concentrations is", |
46 | ! |
"currently only implemented for the parent compound using", |
47 | ! |
"analytical solutions") |
48 |
} |
|
49 | 4x |
obs_var <- obs_vars[1] |
50 | 4x |
spec = fit$mkinmod$spec |
51 | 4x |
type = spec[[1]]$type |
52 | ||
53 | 4x |
M0 <- parms.all[paste0(obs_var, "_0")] |
54 | ||
55 | 4x |
if (type == "SFO") { |
56 | 1x |
k_name <- paste0("k_", obs_var) |
57 | 1x |
if (fit$mkinmod$use_of_ff == "min") { |
58 | ! |
k_name <- paste0(k_name, "_sink") |
59 |
} |
|
60 | 1x |
k <- parms.all[k_name] |
61 | 1x |
twafunc <- function(t) { |
62 | 1x |
max_twa_sfo(M0, k, t) |
63 |
} |
|
64 |
} |
|
65 | 4x |
if (type == "FOMC") { |
66 | 1x |
alpha <- parms.all["alpha"] |
67 | 1x |
beta <- parms.all["beta"] |
68 | 1x |
twafunc <- function(t) { |
69 | 1x |
max_twa_fomc(M0, alpha, beta, t) |
70 |
} |
|
71 |
} |
|
72 | 4x |
if (type == "DFOP") { |
73 | 1x |
k1 <- parms.all["k1"] |
74 | 1x |
k2 <- parms.all["k2"] |
75 | 1x |
g <- parms.all["g"] |
76 | 1x |
twafunc <- function(t) { |
77 | 1x |
max_twa_dfop(M0, k1, k2, g, t) |
78 |
} |
|
79 |
} |
|
80 | 4x |
if (type == "HS") { |
81 | 1x |
k1 <- parms.all["k1"] |
82 | 1x |
k2 <- parms.all["k2"] |
83 | 1x |
tb <- parms.all["tb"] |
84 | 1x |
twafunc <- function(t) { |
85 | 1x |
ifelse(t <= tb, |
86 | 1x |
max_twa_sfo(M0, k1, t), |
87 | 1x |
max_twa_hs(M0, k1, k2, tb, t) |
88 |
) |
|
89 |
} |
|
90 |
} |
|
91 | 4x |
if (type %in% c("IORE", "SFORB")) { |
92 | ! |
stop("Calculation of maximum time weighted average concentrations is currently ", |
93 | ! |
"not implemented for the ", type, " model.") |
94 |
} |
|
95 | 4x |
res <- twafunc(windows) |
96 | 4x |
names(res) <- windows |
97 | 4x |
return(res) |
98 |
} |
|
99 | ||
100 |
#' @rdname max_twa_parent |
|
101 |
#' @export |
|
102 |
max_twa_sfo <- function(M0 = 1, k, t) { |
|
103 | 1x |
M0 * (1 - exp(- k * t)) / (k * t) |
104 |
} |
|
105 | ||
106 |
#' @rdname max_twa_parent |
|
107 |
#' @export |
|
108 |
max_twa_fomc <- function(M0 = 1, alpha, beta, t) { |
|
109 | 1x |
M0 * (beta)/(t * (1 - alpha)) * ((t/beta + 1)^(1 - alpha) - 1) |
110 |
} |
|
111 | ||
112 |
#' @rdname max_twa_parent |
|
113 |
#' @export |
|
114 |
max_twa_dfop <- function(M0 = 1, k1, k2, g, t) { |
|
115 | 1x |
M0/t * ((g/k1) * (1 - exp(- k1 * t)) + ((1 - g)/k2) * (1 - exp(- k2 * t))) |
116 |
} |
|
117 | ||
118 |
#' @rdname max_twa_parent |
|
119 |
#' @export |
|
120 |
max_twa_hs <- function(M0 = 1, k1, k2, tb, t) { |
|
121 | 1x |
(M0 / t) * ( |
122 | 1x |
(1/k1) * (1 - exp(- k1 * tb)) + |
123 | 1x |
(exp(- k1 * tb) / k2) * (1 - exp(- k2 * (t - tb))) |
124 |
) |
|
125 |
} |
1 |
utils::globalVariables("D24_2014") |
|
2 | ||
3 |
#' Normalisation factors for aerobic soil degradation according to FOCUS guidance |
|
4 |
#' |
|
5 |
#' Time step normalisation factors for aerobic soil degradation as described |
|
6 |
#' in Appendix 8 to the FOCUS kinetics guidance (FOCUS 2014, p. 369). |
|
7 |
#' |
|
8 |
#' @param object An object containing information used for the calculations |
|
9 |
#' @param temperature Numeric vector of temperatures in °C |
|
10 |
#' @param moisture Numeric vector of moisture contents in \\% w/w |
|
11 |
#' @param field_moisture Numeric vector of moisture contents at field capacity |
|
12 |
#' (pF2) in \\% w/w |
|
13 |
#' @param study_moisture_ref_source Source for the reference value |
|
14 |
#' used to calculate the study moisture. If 'auto', preference is given |
|
15 |
#' to a reference moisture given in the meta information, otherwise |
|
16 |
#' the focus soil moisture for the soil class is used |
|
17 |
#' @param Q10 The Q10 value used for temperature normalisation |
|
18 |
#' @param walker The Walker exponent used for moisture normalisation |
|
19 |
#' @param f_na The factor to use for NA values. If set to NA, only factors |
|
20 |
#' for complete cases will be returned. |
|
21 |
#' @param \dots Currently not used |
|
22 |
#' @references |
|
23 |
#' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
24 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
25 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
26 |
#' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
27 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
28 |
#' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence |
|
29 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
30 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
31 |
#' Version 1.1, 18 December 2014 |
|
32 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
33 |
#' @seealso [focus_soil_moisture] |
|
34 |
#' @examples |
|
35 |
#' f_time_norm_focus(25, 20, 25) # 1.37, compare FOCUS 2014 p. 184 |
|
36 |
#' |
|
37 |
#' D24_2014$meta |
|
38 |
#' # No moisture normalisation in the first dataset, so we use f_na = 1 to get |
|
39 |
#' # temperature only normalisation as in the EU evaluation |
|
40 |
#' f_time_norm_focus(D24_2014, study_moisture_ref_source = "focus", f_na = 1) |
|
41 |
#' @export |
|
42 |
f_time_norm_focus <- function(object, ...) { |
|
43 | 765x |
UseMethod("f_time_norm_focus") |
44 |
} |
|
45 | ||
46 |
#' @rdname f_time_norm_focus |
|
47 |
#' @export |
|
48 |
f_time_norm_focus.numeric <- function(object, |
|
49 |
moisture = NA, field_moisture = NA, |
|
50 |
temperature = object, |
|
51 |
Q10 = 2.58, walker = 0.7, f_na = NA, ...) |
|
52 |
{ |
|
53 | 459x |
f_temp <- ifelse(is.na(temperature), |
54 | 459x |
f_na, |
55 | 459x |
ifelse(temperature <= 0, |
56 | 459x |
0, |
57 | 459x |
Q10^((temperature - 20)/10))) |
58 | 459x |
f_moist <- ifelse(is.na(moisture), |
59 | 459x |
f_na, |
60 | 459x |
ifelse(moisture >= field_moisture, |
61 | 459x |
1, |
62 | 459x |
(moisture / field_moisture)^walker)) |
63 | 459x |
f_time_norm <- f_temp * f_moist |
64 | 459x |
f_time_norm |
65 |
} |
|
66 | ||
67 |
#' @rdname f_time_norm_focus |
|
68 |
#' @export |
|
69 |
f_time_norm_focus.mkindsg <- function(object, |
|
70 |
study_moisture_ref_source = c("auto", "meta", "focus"), |
|
71 |
Q10 = 2.58, walker = 0.7, f_na = NA, ...) { |
|
72 | ||
73 | 306x |
study_moisture_ref_source <- match.arg(study_moisture_ref_source) |
74 | 306x |
meta <- object$meta |
75 | ||
76 | 306x |
if (is.null(meta$field_moisture)) { |
77 | 306x |
field_moisture <- focus_soil_moisture[meta$usda_soil_type, "pF2"] |
78 |
} else { |
|
79 | ! |
field_moisture <- ifelse(is.na(meta$field_moisture), |
80 | ! |
focus_soil_moisture[meta$usda_soil_type, "pF2"], |
81 | ! |
meta$field_moisture) |
82 |
} |
|
83 | ||
84 | 306x |
study_moisture_ref_focus <- |
85 | 306x |
focus_soil_moisture[as.matrix(meta[c("usda_soil_type", "study_moisture_ref_type")])] |
86 | ||
87 | 306x |
if (study_moisture_ref_source == "auto") { |
88 | 153x |
study_moisture_ref <- ifelse (is.na(meta$study_ref_moisture), |
89 | 153x |
study_moisture_ref_focus, |
90 | 153x |
meta$study_ref_moisture) |
91 |
} else { |
|
92 | 153x |
if (study_moisture_ref_source == "meta") { |
93 | ! |
study_moisture_ref <- meta$study_moisture_ref |
94 |
} else { |
|
95 | 153x |
study_moisture_ref <- study_moisture_ref_focus |
96 |
} |
|
97 |
} |
|
98 | ||
99 | 306x |
if ("study_moisture" %in% names(meta)) { |
100 | ! |
study_moisture <- ifelse(is.na(meta$study_moisture), |
101 | ! |
meta$rel_moisture * study_moisture_ref, |
102 | ! |
meta$study_moisture) |
103 |
} else { |
|
104 | 306x |
study_moisture <- meta$rel_moisture * study_moisture_ref |
105 |
} |
|
106 | ||
107 | 306x |
object$f_time_norm <- f_time_norm_focus(meta$temperature, |
108 | 306x |
moisture = study_moisture, field_moisture = field_moisture, |
109 | 306x |
Q10 = Q10, walker = walker, f_na = f_na) |
110 | 306x |
message("$f_time_norm was (re)set to normalised values") |
111 | 306x |
invisible(object$f_time_norm) |
112 |
} |
1 |
#' A dataset class for mkin |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' At the moment this dataset class is hardly used in mkin. For example, |
|
5 |
#' mkinfit does not take mkinds datasets as argument, but works with dataframes |
|
6 |
#' such as the on contained in the data field of mkinds objects. Some datasets |
|
7 |
#' provided by this package come as mkinds objects nevertheless. |
|
8 |
#' |
|
9 |
#' @importFrom R6 R6Class |
|
10 |
#' @examples |
|
11 |
#' |
|
12 |
#' mds <- mkinds$new("FOCUS A", FOCUS_2006_A) |
|
13 |
#' print(mds) |
|
14 |
#' |
|
15 |
#' @export |
|
16 |
mkinds <- R6Class("mkinds", |
|
17 |
public = list( |
|
18 | ||
19 |
#' @field title A full title for the dataset |
|
20 |
title = NULL, |
|
21 | ||
22 |
#' @field sampling_times The sampling times |
|
23 |
sampling_times = NULL, |
|
24 | ||
25 |
#' @field time_unit The time unit |
|
26 |
time_unit = NULL, |
|
27 | ||
28 |
#' @field observed Names of the observed variables |
|
29 |
observed = NULL, |
|
30 | ||
31 |
#' @field unit The unit of the observations |
|
32 |
unit = NULL, |
|
33 | ||
34 |
#' @field replicates The maximum number of replicates per sampling time |
|
35 |
replicates = NULL, |
|
36 | ||
37 |
#' @field data A data frame with at least the columns name, time |
|
38 |
#' and value in order to be compatible with mkinfit |
|
39 |
data = NULL, |
|
40 | ||
41 |
#' @description |
|
42 |
#' Create a new mkinds object |
|
43 |
#' @param title The dataset title |
|
44 |
#' @param data The data |
|
45 |
#' @param time_unit The time unit |
|
46 |
#' @param unit The unit of the observations |
|
47 |
initialize = function(title = "", data, time_unit = NA, unit = NA) { |
|
48 | ||
49 | 104x |
self$title <- title |
50 | 104x |
self$sampling_times <- sort(unique(data$time)) |
51 | 104x |
self$time_unit <- time_unit |
52 | 104x |
self$observed <- unique(data$name) |
53 | 104x |
self$unit <- unit |
54 | 104x |
self$replicates <- max(by(data, list(data$name, data$time), nrow)) |
55 | 104x |
if (is.null(data$override)) data$override <- NA |
56 | 104x |
if (is.null(data$err)) data$err <- 1 |
57 | 104x |
self$data <- data |
58 | ||
59 |
} |
|
60 |
) |
|
61 |
) |
|
62 | ||
63 |
#' Print mkinds objects |
|
64 |
#' |
|
65 |
#' @rdname mkinds |
|
66 |
#' @param x An [mkinds] object. |
|
67 |
#' @param data Should the data be printed? |
|
68 |
#' @param \dots Not used. |
|
69 |
#' @export |
|
70 |
print.mkinds <- function(x, data = FALSE, ...) { |
|
71 | 104x |
cat("<mkinds> with $title: ", x$title, "\n") |
72 | 104x |
cat("Observed compounds $observed: ", paste(x$observed, collapse = ", "), "\n") |
73 | 104x |
cat("Sampling times $sampling_times:\n") |
74 | 104x |
cat(paste(x$sampling_times, collapse = ", "), "\n") |
75 | 104x |
cat("With a maximum of ", x$replicates, " replicates\n") |
76 | 104x |
if (!is.na(x$time_unit)) cat("Time unit: ", x$time_unit, "\n") |
77 | 104x |
if (!is.na(x$unit)) cat("Observation unit: ", x$unit, "\n") |
78 | ! |
if (data) print(mkin_long_to_wide(x$data)) |
79 |
} |
|
80 | ||
81 |
#' A class for dataset groups for mkin |
|
82 |
#' |
|
83 |
#' @description |
|
84 |
#' A container for working with datasets that share at least one compound, |
|
85 |
#' so that combined evaluations are desirable. |
|
86 |
#' |
|
87 |
#' Time normalisation factors are initialised with a value of 1 for each |
|
88 |
#' dataset if no data are supplied. |
|
89 |
#' |
|
90 |
#' @examples |
|
91 |
#' |
|
92 |
#' mdsg <- mkindsg$new("Experimental X", experimental_data_for_UBA_2019[6:10]) |
|
93 |
#' print(mdsg) |
|
94 |
#' print(mdsg, verbose = TRUE) |
|
95 |
#' print(mdsg, verbose = TRUE, data = TRUE) |
|
96 |
#' |
|
97 |
#' @export |
|
98 |
mkindsg <- R6Class("mkindsg", |
|
99 |
public = list( |
|
100 | ||
101 |
#' @field title A title for the dataset group |
|
102 |
title = NULL, |
|
103 | ||
104 |
#' @field ds A list of mkinds objects |
|
105 |
ds = NULL, |
|
106 | ||
107 |
#' @field observed_n Occurrence counts of compounds in datasets |
|
108 |
observed_n = NULL, |
|
109 | ||
110 |
#' @field f_time_norm Time normalisation factors |
|
111 |
f_time_norm = NULL, |
|
112 | ||
113 |
#' @field meta A data frame with a row for each dataset, |
|
114 |
#' containing additional information in the form |
|
115 |
#' of categorical data (factors) or numerical data |
|
116 |
#' (e.g. temperature, moisture, |
|
117 |
#' or covariates like soil pH). |
|
118 |
meta = NULL, |
|
119 | ||
120 |
#' @description |
|
121 |
#' Create a new mkindsg object |
|
122 |
#' @param title The title |
|
123 |
#' @param ds A list of mkinds objects |
|
124 |
#' @param f_time_norm Time normalisation factors |
|
125 |
#' @param meta The meta data |
|
126 |
initialize = function(title = "", ds, |
|
127 |
f_time_norm = rep(1, length(ds)), meta) |
|
128 |
{ |
|
129 | 104x |
self$title <- title |
130 | 104x |
if (all(sapply(ds, inherits, "mkinds"))) { |
131 | 104x |
self$ds <- ds |
132 |
} else { |
|
133 | ! |
stop("Please supply a list of mkinds objects") |
134 |
} |
|
135 | ||
136 | 104x |
all_observed <- unlist(lapply(ds, function(x) x$observed)) |
137 | 104x |
observed <- factor(all_observed, levels = unique(all_observed)) |
138 | 104x |
self$observed_n <- table(observed) |
139 | 104x |
names(dimnames(self$observed_n)) <- NULL |
140 | 104x |
self$f_time_norm <- f_time_norm |
141 | ||
142 | 104x |
if (!missing(meta)) { |
143 | ! |
rownames(meta) <- lapply(ds, function(x) x$title) |
144 | ! |
self$meta <- meta |
145 |
} |
|
146 |
} |
|
147 |
) |
|
148 |
) |
|
149 | ||
150 |
#' Print mkindsg objects |
|
151 |
#' |
|
152 |
#' @rdname mkindsg |
|
153 |
#' @param x An [mkindsg] object. |
|
154 |
#' @param verbose Should the mkinds objects be printed? |
|
155 |
#' @param data Should the mkinds objects be printed with their data? |
|
156 |
#' @param \dots Not used. |
|
157 |
#' @export |
|
158 |
print.mkindsg <- function(x, data = FALSE, verbose = data, ...) { |
|
159 | 208x |
cat("<mkindsg> holding", length(x$ds), "mkinds objects\n") |
160 | 208x |
cat("Title $title: ", x$title, "\n") |
161 | 208x |
cat("Occurrence of observed compounds $observed_n:\n") |
162 | 208x |
print(x$observed_n) |
163 | 208x |
if (any(x$f_time_norm != 1)) { |
164 | 104x |
cat("Time normalisation factors $f_time_norm:\n") |
165 | 104x |
print(x$f_time_norm) |
166 |
} |
|
167 | 208x |
if (!is.null(x$meta)) { |
168 | 104x |
cat("Meta information $meta:\n") |
169 | 104x |
print(x$meta) |
170 |
} |
|
171 | 208x |
if (verbose) { |
172 | ! |
cat("\nDatasets $ds:") |
173 | ! |
for (ds in x$ds) { |
174 | ! |
cat("\n") |
175 | ! |
print(ds, data = data) |
176 |
} |
|
177 |
} |
|
178 |
} |
1 |
utils::globalVariables(c("name", "value_mean")) |
|
2 | ||
3 |
#' Calculate the minimum error to assume in order to pass the variance test |
|
4 |
#' |
|
5 |
#' This function finds the smallest relative error still resulting in passing |
|
6 |
#' the chi-squared test as defined in the FOCUS kinetics report from 2006. |
|
7 |
#' |
|
8 |
#' This function is used internally by \code{\link{summary.mkinfit}}. |
|
9 |
#' |
|
10 |
#' @param fit an object of class \code{\link{mkinfit}}. |
|
11 |
#' @param alpha The confidence level chosen for the chi-squared test. |
|
12 |
#' @importFrom stats qchisq aggregate |
|
13 |
#' @return A dataframe with the following components: \item{err.min}{The |
|
14 |
#' relative error, expressed as a fraction.} \item{n.optim}{The number of |
|
15 |
#' optimised parameters attributed to the data series.} \item{df}{The number of |
|
16 |
#' remaining degrees of freedom for the chi2 error level calculations. Note |
|
17 |
#' that mean values are used for the chi2 statistic and therefore every time |
|
18 |
#' point with observed values in the series only counts one time.} The |
|
19 |
#' dataframe has one row for the total dataset and one further row for each |
|
20 |
#' observed state variable in the model. |
|
21 |
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
22 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in EU |
|
23 |
#' Registration} Report of the FOCUS Work Group on Degradation Kinetics, EC |
|
24 |
#' Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
25 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
26 |
#' @keywords manip |
|
27 |
#' @examples |
|
28 |
#' |
|
29 |
#' SFO_SFO = mkinmod(parent = mkinsub("SFO", to = "m1"), |
|
30 |
#' m1 = mkinsub("SFO"), |
|
31 |
#' use_of_ff = "max") |
|
32 |
#' |
|
33 |
#' fit_FOCUS_D = mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE) |
|
34 |
#' round(mkinerrmin(fit_FOCUS_D), 4) |
|
35 |
#' \dontrun{ |
|
36 |
#' fit_FOCUS_E = mkinfit(SFO_SFO, FOCUS_2006_E, quiet = TRUE) |
|
37 |
#' round(mkinerrmin(fit_FOCUS_E), 4) |
|
38 |
#' } |
|
39 |
#' |
|
40 |
#' @export |
|
41 |
mkinerrmin <- function(fit, alpha = 0.05) |
|
42 |
{ |
|
43 | 53943x |
parms.optim <- fit$par |
44 | ||
45 | 53943x |
kinerrmin <- function(errdata, n.parms) { |
46 | 124726x |
means.mean <- mean(errdata$observed, na.rm = TRUE) |
47 | 124726x |
df = nrow(errdata) - n.parms |
48 | ||
49 | 124726x |
err.min <- sqrt((1 / qchisq(1 - alpha, df)) * |
50 | 124726x |
sum((errdata$observed - errdata$predicted)^2)/(means.mean^2)) |
51 | ||
52 | 124726x |
return(list(err.min = err.min, n.optim = n.parms, df = df)) |
53 |
} |
|
54 | ||
55 | 53943x |
errdata <- aggregate(cbind(observed, predicted) ~ time + variable, data = fit$data, mean, na.rm=TRUE) |
56 | 53943x |
errdata <- errdata[order(errdata$time, errdata$variable), ] |
57 | ||
58 |
# Remove values at time zero for variables whose value for state.ini is fixed, |
|
59 |
# as these will not have any effect in the optimization and should therefore not |
|
60 |
# be counted as degrees of freedom. |
|
61 | 53943x |
fixed_initials = gsub("_0$", "", rownames(subset(fit$fixed, type == "state"))) |
62 | 53943x |
errdata <- subset(errdata, !(time == 0 & variable %in% fixed_initials)) |
63 | ||
64 | 53943x |
n.optim.overall <- length(parms.optim) - length(fit$errparms) |
65 | ||
66 | 53943x |
errmin.overall <- kinerrmin(errdata, n.optim.overall) |
67 | 53943x |
errmin <- data.frame(err.min = errmin.overall$err.min, |
68 | 53943x |
n.optim = errmin.overall$n.optim, df = errmin.overall$df) |
69 | 53943x |
rownames(errmin) <- "All data" |
70 | ||
71 |
# The degrees of freedom are counted according to FOCUS kinetics (2011, p. 164) |
|
72 | 53943x |
for (obs_var in fit$obs_vars) |
73 |
{ |
|
74 | 70783x |
errdata.var <- subset(errdata, variable == obs_var) |
75 | ||
76 |
# Check if initial value is optimised |
|
77 | 70783x |
n.initials.optim <- length(grep(paste(obs_var, ".*", "_0", sep=""), names(parms.optim))) |
78 | ||
79 |
# Rate constants and IORE exponents are attributed to the source variable |
|
80 | 70783x |
n.k.optim <- length(grep(paste("^k", obs_var, sep="_"), names(parms.optim))) |
81 | 70783x |
n.k.optim <- n.k.optim + length(grep(paste("^log_k", obs_var, sep="_"), |
82 | 70783x |
names(parms.optim))) |
83 | 70783x |
n.k__iore.optim <- length(grep(paste("^k__iore", obs_var, sep="_"), names(parms.optim))) |
84 | 70783x |
n.k__iore.optim <- n.k__iore.optim + length(grep(paste("^log_k__iore", |
85 | 70783x |
obs_var, sep = "_"), names(parms.optim))) |
86 | ||
87 | 70783x |
n.N.optim <- length(grep(paste("^N", obs_var, sep="_"), names(parms.optim))) |
88 | ||
89 | 70783x |
n.ff.optim <- 0 |
90 |
# Formation fractions are attributed to the target variable, so look |
|
91 |
# for source compartments with formation fractions |
|
92 | 70783x |
for (source_var in fit$obs_vars) { |
93 | 112543x |
n.ff.source = length(grep(paste("^f", source_var, sep = "_"), |
94 | 112543x |
names(parms.optim))) |
95 | 112543x |
n.paths.source = length(fit$mkinmod$spec[[source_var]]$to) |
96 | 112543x |
for (target_var in fit$mkinmod$spec[[source_var]]$to) { |
97 | 46296x |
if (obs_var == target_var) { |
98 | 17974x |
n.ff.optim <- n.ff.optim + n.ff.source/n.paths.source |
99 |
} |
|
100 |
} |
|
101 |
} |
|
102 | ||
103 | 70783x |
n.optim <- sum(n.initials.optim, n.k.optim, n.k__iore.optim, n.N.optim, n.ff.optim) |
104 | ||
105 |
# FOMC, DFOP and HS parameters are only counted if we are looking at the |
|
106 |
# first variable in the model which is always the source variable |
|
107 | 70783x |
if (obs_var == fit$obs_vars[[1]]) { |
108 | 53943x |
special_parms = c("alpha", "log_alpha", "beta", "log_beta", |
109 | 53943x |
"k1", "log_k1", "k2", "log_k2", |
110 | 53943x |
"g", "g_ilr", "g_qlogis", "tb", "log_tb") |
111 | 53943x |
n.optim <- n.optim + length(intersect(special_parms, names(parms.optim))) |
112 |
} |
|
113 | ||
114 |
# Calculate and add a line to the dataframe holding the results |
|
115 | 70783x |
errmin.tmp <- kinerrmin(errdata.var, n.optim) |
116 | 70783x |
errmin[obs_var, c("err.min", "n.optim", "df")] <- errmin.tmp |
117 |
} |
|
118 | ||
119 | 53943x |
return(errmin) |
120 |
} |
1 |
#' Extract residuals from an mkinfit model |
|
2 |
#' |
|
3 |
#' @param object A \code{\link{mkinfit}} object |
|
4 |
#' @param standardized Should the residuals be standardized by dividing by the |
|
5 |
#' standard deviation obtained from the fitted error model? |
|
6 |
#' @param \dots Not used |
|
7 |
#' @export |
|
8 |
#' @examples |
|
9 |
#' f <- mkinfit("DFOP", FOCUS_2006_C, quiet = TRUE) |
|
10 |
#' residuals(f) |
|
11 |
#' residuals(f, standardized = TRUE) |
|
12 |
residuals.mkinfit <- function(object, standardized = FALSE, ...) { |
|
13 | 2493x |
res <- object$data[["residual"]] |
14 | 2493x |
if (standardized) { |
15 | 2428x |
if (object$err_mod == "const") { |
16 | 543x |
sigma_fitted <- object$errparms["sigma"] |
17 |
} |
|
18 | 2428x |
if (object$err_mod == "obs") { |
19 | 65x |
sigma_names = paste0("sigma_", object$data[["variable"]]) |
20 | 65x |
sigma_fitted <- object$errparms[sigma_names] |
21 |
} |
|
22 | 2428x |
if (object$err_mod == "tc") { |
23 | 1820x |
sigma_fitted <- sigma_twocomp(object$data[["predicted"]], |
24 | 1820x |
sigma_low = object$errparms[1], |
25 | 1820x |
rsd_high = object$errparms[2]) |
26 |
} |
|
27 | 2428x |
return(res / sigma_fitted) |
28 |
} |
|
29 | 65x |
return(res) |
30 |
} |
|
31 |
1 |
#' Calculate the AIC for a column of an mmkin object |
|
2 |
#' |
|
3 |
#' Provides a convenient way to compare different kinetic models fitted to the |
|
4 |
#' same dataset. |
|
5 |
#' |
|
6 |
#' @importFrom stats AIC BIC |
|
7 |
#' @param object An object of class \code{\link{mmkin}}, containing only one |
|
8 |
#' column. |
|
9 |
#' @param \dots For compatibility with the generic method |
|
10 |
#' @param k As in the generic method |
|
11 |
#' @return As in the generic method (a numeric value for single fits, or a |
|
12 |
#' dataframe if there are several fits in the column). |
|
13 |
#' @author Johannes Ranke |
|
14 |
#' @examples |
|
15 |
#' |
|
16 |
#' \dontrun{ # skip, as it takes > 10 s on winbuilder |
|
17 |
#' f <- mmkin(c("SFO", "FOMC", "DFOP"), |
|
18 |
#' list("FOCUS A" = FOCUS_2006_A, |
|
19 |
#' "FOCUS C" = FOCUS_2006_C), cores = 1, quiet = TRUE) |
|
20 |
#' # We get a warning because the FOMC model does not converge for the |
|
21 |
#' # FOCUS A dataset, as it is well described by SFO |
|
22 |
#' |
|
23 |
#' AIC(f["SFO", "FOCUS A"]) # We get a single number for a single fit |
|
24 |
#' AIC(f[["SFO", "FOCUS A"]]) # or when extracting an mkinfit object |
|
25 |
#' |
|
26 |
#' # For FOCUS A, the models fit almost equally well, so the higher the number |
|
27 |
#' # of parameters, the higher (worse) the AIC |
|
28 |
#' AIC(f[, "FOCUS A"]) |
|
29 |
#' AIC(f[, "FOCUS A"], k = 0) # If we do not penalize additional parameters, we get nearly the same |
|
30 |
#' BIC(f[, "FOCUS A"]) # Comparing the BIC gives a very similar picture |
|
31 |
#' |
|
32 |
#' # For FOCUS C, the more complex models fit better |
|
33 |
#' AIC(f[, "FOCUS C"]) |
|
34 |
#' BIC(f[, "FOCUS C"]) |
|
35 |
#' } |
|
36 |
#' |
|
37 |
#' @export |
|
38 |
AIC.mmkin <- function(object, ..., k = 2) |
|
39 |
{ |
|
40 |
# We can only handle a single column |
|
41 | 247x |
if (ncol(object) != 1) stop("Please provide a single column object") |
42 | 247x |
n.fits <- length(object) |
43 | 247x |
model_names <- rownames(object) |
44 | ||
45 | 247x |
code <- paste0("AIC(", |
46 | 247x |
paste0("object[[", 1:n.fits, "]]", collapse = ", "), |
47 | 247x |
", k = k)") |
48 | 247x |
res <- eval(parse(text = code)) |
49 | 247x |
if (n.fits > 1) rownames(res) <- model_names |
50 | 247x |
return(res) |
51 |
} |
|
52 | ||
53 |
#' @rdname AIC.mmkin |
|
54 |
#' @export |
|
55 |
BIC.mmkin <- function(object, ...) |
|
56 |
{ |
|
57 |
# We can only handle a single column |
|
58 | 247x |
if (ncol(object) != 1) stop("Please provide a single column object") |
59 | 247x |
n.fits <- length(object) |
60 | 247x |
model_names <- rownames(object) |
61 | ||
62 | 247x |
code <- paste0("BIC(", |
63 | 247x |
paste0("object[[", 1:n.fits, "]]", collapse = ", "), |
64 |
")") |
|
65 | 247x |
res <- eval(parse(text = code)) |
66 | 247x |
if (n.fits > 1) rownames(res) <- model_names |
67 | 247x |
return(res) |
68 |
} |
1 |
#' @importFrom nlme intervals |
|
2 |
#' @export |
|
3 |
nlme::intervals |
|
4 | ||
5 |
#' Confidence intervals for parameters in saem.mmkin objects |
|
6 |
#' |
|
7 |
#' @param object The fitted saem.mmkin object |
|
8 |
#' @param level The confidence level. Must be the default of 0.95 as this is what |
|
9 |
#' is available in the saemix object |
|
10 |
#' @param backtransform In case the model was fitted with mkin transformations, |
|
11 |
#' should we backtransform the parameters where a one to one correlation |
|
12 |
#' between transformed and backtransformed parameters exists? |
|
13 |
#' @param \dots For compatibility with the generic method |
|
14 |
#' @return An object with 'intervals.saem.mmkin' and 'intervals.lme' in the |
|
15 |
#' class attribute |
|
16 |
#' @export |
|
17 |
intervals.saem.mmkin <- function(object, level = 0.95, backtransform = TRUE, ...) |
|
18 |
{ |
|
19 | 2481x |
if (!identical(level, 0.95)) { |
20 | ! |
stop("Confidence intervals are only available for a level of 95%") |
21 |
} |
|
22 | ||
23 | 2481x |
mod_vars <- names(object$mkinmod$diffs) |
24 | ||
25 | 2481x |
pnames <- names(object$mean_dp_start) |
26 | ||
27 |
# Confidence intervals are available in the SaemixObject, so |
|
28 |
# we just need to extract them and put them into a list modelled |
|
29 |
# after the result of nlme::intervals.lme |
|
30 | ||
31 | 2481x |
conf.int <- object$so@results@conf.int |
32 | 2481x |
rownames(conf.int) <- conf.int$name |
33 | 2481x |
colnames(conf.int)[2] <- "est." |
34 | 2481x |
confint_trans <- as.matrix(conf.int[pnames, c("lower", "est.", "upper")]) |
35 | ||
36 |
# Fixed effects |
|
37 |
# In case objects were produced by earlier versions of saem |
|
38 | ! |
if (is.null(object$transformations)) object$transformations <- "mkin" |
39 | ||
40 | 2481x |
if (object$transformations == "mkin" & backtransform) { |
41 | 2286x |
bp <- backtransform_odeparms(confint_trans[, "est."], object$mkinmod, |
42 | 2286x |
object$transform_rates, object$transform_fractions) |
43 | 2286x |
bpnames <- names(bp) |
44 | ||
45 |
# Transform boundaries of CI for one parameter at a time, |
|
46 |
# with the exception of sets of formation fractions (single fractions are OK). |
|
47 | 2286x |
f_names_skip <- character(0) |
48 | 2286x |
for (box in mod_vars) { # Figure out sets of fractions to skip |
49 | 2396x |
f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE) |
50 | 2396x |
n_paths <- length(f_names) |
51 | ! |
if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names) |
52 |
} |
|
53 | ||
54 | 2286x |
confint_back <- matrix(NA, nrow = length(bp), ncol = 3, |
55 | 2286x |
dimnames = list(bpnames, colnames(confint_trans))) |
56 | 2286x |
confint_back[, "est."] <- bp |
57 | ||
58 | 2286x |
for (pname in pnames) { |
59 | 6314x |
if (!pname %in% f_names_skip) { |
60 | 6314x |
par.lower <- confint_trans[pname, "lower"] |
61 | 6314x |
par.upper <- confint_trans[pname, "upper"] |
62 | 6314x |
names(par.lower) <- names(par.upper) <- pname |
63 | 6314x |
bpl <- backtransform_odeparms(par.lower, object$mkinmod, |
64 | 6314x |
object$transform_rates, |
65 | 6314x |
object$transform_fractions) |
66 | 6314x |
bpu <- backtransform_odeparms(par.upper, object$mkinmod, |
67 | 6314x |
object$transform_rates, |
68 | 6314x |
object$transform_fractions) |
69 | 6314x |
confint_back[names(bpl), "lower"] <- bpl |
70 | 6314x |
confint_back[names(bpu), "upper"] <- bpu |
71 |
} |
|
72 |
} |
|
73 | 2286x |
confint_ret <- confint_back |
74 |
} else { |
|
75 | 195x |
confint_ret <- confint_trans |
76 |
} |
|
77 | 2481x |
attr(confint_ret, "label") <- "Fixed effects:" |
78 | ||
79 |
# Random effects |
|
80 | 2481x |
sdnames <- intersect(rownames(conf.int), paste("SD", pnames, sep = ".")) |
81 | 2481x |
corrnames <- grep("^Corr.", rownames(conf.int), value = TRUE) |
82 | 2481x |
ranef_ret <- as.matrix(conf.int[c(sdnames, corrnames), c("lower", "est.", "upper")]) |
83 | 2481x |
sdnames_ret <- paste0(gsub("SD\\.", "sd(", sdnames), ")") |
84 | 2481x |
corrnames_ret <- gsub("Corr\\.(.*)\\.(.*)", "corr(\\1,\\2)", corrnames) |
85 | 2481x |
rownames(ranef_ret) <- c(sdnames_ret, corrnames_ret) |
86 | ||
87 | 2481x |
attr(ranef_ret, "label") <- "Random effects:" |
88 | ||
89 | ||
90 |
# Error model |
|
91 | 2481x |
enames <- if (object$err_mod == "const") "a.1" else c("a.1", "b.1") |
92 | 2481x |
err_ret <- as.matrix(conf.int[enames, c("lower", "est.", "upper")]) |
93 | ||
94 | 2481x |
res <- list( |
95 | 2481x |
fixed = confint_ret, |
96 | 2481x |
random = ranef_ret, |
97 | 2481x |
errmod = err_ret |
98 |
) |
|
99 | 2481x |
class(res) <- c("intervals.saemix.mmkin", "intervals.lme") |
100 | 2481x |
attr(res, "level") <- level |
101 | 2481x |
return(res) |
102 |
} |
1 |
#' Update an mkinfit model with different arguments |
|
2 |
#' |
|
3 |
#' This function will return an updated mkinfit object. The fitted degradation |
|
4 |
#' model parameters from the old fit are used as starting values for the |
|
5 |
#' updated fit. Values specified as 'parms.ini' and/or 'state.ini' will |
|
6 |
#' override these starting values. |
|
7 |
#' |
|
8 |
#' @param object An mkinfit object to be updated |
|
9 |
#' @param \dots Arguments to \code{\link{mkinfit}} that should replace |
|
10 |
#' the arguments from the original call. Arguments set to NULL will |
|
11 |
#' remove arguments given in the original call |
|
12 |
#' @param evaluate Should the call be evaluated or returned as a call |
|
13 |
#' @examples |
|
14 |
#' \dontrun{ |
|
15 |
#' fit <- mkinfit("SFO", subset(FOCUS_2006_D, value != 0), quiet = TRUE) |
|
16 |
#' parms(fit) |
|
17 |
#' plot_err(fit) |
|
18 |
#' fit_2 <- update(fit, error_model = "tc") |
|
19 |
#' parms(fit_2) |
|
20 |
#' plot_err(fit_2) |
|
21 |
#' } |
|
22 |
#' @export |
|
23 |
update.mkinfit <- function(object, ..., evaluate = TRUE) |
|
24 |
{ |
|
25 | 5x |
call <- object$call |
26 | ||
27 | 5x |
update_arguments <- match.call(expand.dots = FALSE)$... |
28 | ||
29 |
# Get optimised ODE parameters and let parms.ini override them |
|
30 | 5x |
ode_optim_names <- intersect(names(object$bparms.optim), names(object$bparms.ode)) |
31 | 5x |
ode_start <- object$bparms.optim[ode_optim_names] |
32 | 5x |
if ("parms.ini" %in% names(update_arguments)) { |
33 | ! |
ode_start[names(update_arguments["parms.ini"])] <- update_arguments["parms.ini"] |
34 |
} |
|
35 | 5x |
if (length(ode_start)) update_arguments[["parms.ini"]] <- ode_start |
36 | ||
37 |
# Get optimised values for initial states and let state.ini override them |
|
38 | 5x |
state_optim_names <- intersect(names(object$bparms.optim), paste0(names(object$bparms.state), "_0")) |
39 | 5x |
state_start <- object$bparms.optim[state_optim_names] |
40 | 5x |
names(state_start) <- gsub("_0$", "", names(state_start)) |
41 | 5x |
if ("state.ini" %in% names(update_arguments)) { |
42 | ! |
state_start[names(update_arguments["state.ini"])] <- update_arguments["state.ini"] |
43 |
} |
|
44 | 5x |
if (length(state_start)) update_arguments[["state.ini"]] <- state_start |
45 | ||
46 | 5x |
if (length(update_arguments) > 0) { |
47 | 5x |
update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) |
48 | ||
49 | 5x |
for (a in names(update_arguments)[update_arguments_in_call]) { |
50 | 3x |
call[[a]] <- update_arguments[[a]] |
51 |
} |
|
52 | ||
53 | 5x |
update_arguments_not_in_call <- !update_arguments_in_call |
54 | 5x |
if(any(update_arguments_not_in_call)) { |
55 | 5x |
call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) |
56 | 5x |
call <- as.call(call) |
57 |
} |
|
58 |
} |
|
59 | 5x |
if(evaluate) eval(call, parent.frame()) |
60 | ! |
else call |
61 |
} |
1 |
#' Confidence intervals for parameters of mkinfit objects |
|
2 |
#' |
|
3 |
#' The default method 'quadratic' is based on the quadratic approximation of |
|
4 |
#' the curvature of the likelihood function at the maximum likelihood parameter |
|
5 |
#' estimates. |
|
6 |
#' The alternative method 'profile' is based on the profile likelihood for each |
|
7 |
#' parameter. The 'profile' method uses two nested optimisations and can take a |
|
8 |
#' very long time, even if parallelized by specifying 'cores' on unixoid |
|
9 |
#' platforms. The speed of the method could likely be improved by using the |
|
10 |
#' method of Venzon and Moolgavkar (1988). |
|
11 |
#' |
|
12 |
#' @param object An \code{\link{mkinfit}} object |
|
13 |
#' @param parm A vector of names of the parameters which are to be given |
|
14 |
#' confidence intervals. If missing, all parameters are considered. |
|
15 |
#' @param level The confidence level required |
|
16 |
#' @param alpha The allowed error probability, overrides 'level' if specified. |
|
17 |
#' @param cutoff Possibility to specify an alternative cutoff for the difference |
|
18 |
#' in the log-likelihoods at the confidence boundary. Specifying an explicit |
|
19 |
#' cutoff value overrides arguments 'level' and 'alpha' |
|
20 |
#' @param method The 'quadratic' method approximates the likelihood function at |
|
21 |
#' the optimised parameters using the second term of the Taylor expansion, |
|
22 |
#' using a second derivative (hessian) contained in the object. |
|
23 |
#' The 'profile' method searches the parameter space for the |
|
24 |
#' cutoff of the confidence intervals by means of a likelihood ratio test. |
|
25 |
#' @param transformed If the quadratic approximation is used, should it be |
|
26 |
#' applied to the likelihood based on the transformed parameters? |
|
27 |
#' @param backtransform If we approximate the likelihood in terms of the |
|
28 |
#' transformed parameters, should we backtransform the parameters with |
|
29 |
#' their confidence intervals? |
|
30 |
#' @param rel_tol If the method is 'profile', what should be the accuracy |
|
31 |
#' of the lower and upper bounds, relative to the estimate obtained from |
|
32 |
#' the quadratic method? |
|
33 |
#' @param cores The number of cores to be used for multicore processing. |
|
34 |
#' On Windows machines, cores > 1 is currently not supported. |
|
35 |
#' @param quiet Should we suppress the message "Profiling the likelihood" |
|
36 |
#' @return A matrix with columns giving lower and upper confidence limits for |
|
37 |
#' each parameter. |
|
38 |
#' @param \dots Not used |
|
39 |
#' @importFrom stats qnorm |
|
40 |
#' @references |
|
41 |
#' Bates DM and Watts GW (1988) Nonlinear regression analysis & its applications |
|
42 |
#' |
|
43 |
#' Pawitan Y (2013) In all likelihood - Statistical modelling and |
|
44 |
#' inference using likelihood. Clarendon Press, Oxford. |
|
45 |
#' |
|
46 |
#' Venzon DJ and Moolgavkar SH (1988) A Method for Computing |
|
47 |
#' Profile-Likelihood Based Confidence Intervals, Applied Statistics, 37, |
|
48 |
#' 87–94. |
|
49 |
#' @examples |
|
50 |
#' f <- mkinfit("SFO", FOCUS_2006_C, quiet = TRUE) |
|
51 |
#' confint(f, method = "quadratic") |
|
52 |
#' |
|
53 |
#' \dontrun{ |
|
54 |
#' confint(f, method = "profile") |
|
55 |
#' |
|
56 |
#' # Set the number of cores for the profiling method for further examples |
|
57 |
#' if (identical(Sys.getenv("NOT_CRAN"), "true")) { |
|
58 |
#' n_cores <- parallel::detectCores() - 1 |
|
59 |
#' } else { |
|
60 |
#' n_cores <- 1 |
|
61 |
#' } |
|
62 |
#' if (Sys.getenv("TRAVIS") != "") n_cores = 1 |
|
63 |
#' if (Sys.info()["sysname"] == "Windows") n_cores = 1 |
|
64 |
#' |
|
65 |
#' SFO_SFO <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO"), |
|
66 |
#' use_of_ff = "min", quiet = TRUE) |
|
67 |
#' SFO_SFO.ff <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO"), |
|
68 |
#' use_of_ff = "max", quiet = TRUE) |
|
69 |
#' f_d_1 <- mkinfit(SFO_SFO, subset(FOCUS_2006_D, value != 0), quiet = TRUE) |
|
70 |
#' system.time(ci_profile <- confint(f_d_1, method = "profile", cores = 1, quiet = TRUE)) |
|
71 |
#' # Using more cores does not save much time here, as parent_0 takes up most of the time |
|
72 |
#' # If we additionally exclude parent_0 (the confidence of which is often of |
|
73 |
#' # minor interest), we get a nice performance improvement if we use at least 4 cores |
|
74 |
#' system.time(ci_profile_no_parent_0 <- confint(f_d_1, method = "profile", |
|
75 |
#' c("k_parent_sink", "k_parent_m1", "k_m1_sink", "sigma"), cores = n_cores)) |
|
76 |
#' ci_profile |
|
77 |
#' ci_quadratic_transformed <- confint(f_d_1, method = "quadratic") |
|
78 |
#' ci_quadratic_transformed |
|
79 |
#' ci_quadratic_untransformed <- confint(f_d_1, method = "quadratic", transformed = FALSE) |
|
80 |
#' ci_quadratic_untransformed |
|
81 |
#' # Against the expectation based on Bates and Watts (1988), the confidence |
|
82 |
#' # intervals based on the internal parameter transformation are less |
|
83 |
#' # congruent with the likelihood based intervals. Note the superiority of the |
|
84 |
#' # interval based on the untransformed fit for k_m1_sink |
|
85 |
#' rel_diffs_transformed <- abs((ci_quadratic_transformed - ci_profile)/ci_profile) |
|
86 |
#' rel_diffs_untransformed <- abs((ci_quadratic_untransformed - ci_profile)/ci_profile) |
|
87 |
#' rel_diffs_transformed < rel_diffs_untransformed |
|
88 |
#' signif(rel_diffs_transformed, 3) |
|
89 |
#' signif(rel_diffs_untransformed, 3) |
|
90 |
#' |
|
91 |
#' |
|
92 |
#' # Investigate a case with formation fractions |
|
93 |
#' f_d_2 <- mkinfit(SFO_SFO.ff, subset(FOCUS_2006_D, value != 0), quiet = TRUE) |
|
94 |
#' ci_profile_ff <- confint(f_d_2, method = "profile", cores = n_cores) |
|
95 |
#' ci_profile_ff |
|
96 |
#' ci_quadratic_transformed_ff <- confint(f_d_2, method = "quadratic") |
|
97 |
#' ci_quadratic_transformed_ff |
|
98 |
#' ci_quadratic_untransformed_ff <- confint(f_d_2, method = "quadratic", transformed = FALSE) |
|
99 |
#' ci_quadratic_untransformed_ff |
|
100 |
#' rel_diffs_transformed_ff <- abs((ci_quadratic_transformed_ff - ci_profile_ff)/ci_profile_ff) |
|
101 |
#' rel_diffs_untransformed_ff <- abs((ci_quadratic_untransformed_ff - ci_profile_ff)/ci_profile_ff) |
|
102 |
#' # While the confidence interval for the parent rate constant is closer to |
|
103 |
#' # the profile based interval when using the internal parameter |
|
104 |
#' # transformation, the interval for the metabolite rate constant is 'better |
|
105 |
#' # without internal parameter transformation. |
|
106 |
#' rel_diffs_transformed_ff < rel_diffs_untransformed_ff |
|
107 |
#' rel_diffs_transformed_ff |
|
108 |
#' rel_diffs_untransformed_ff |
|
109 |
#' |
|
110 |
#' # The profiling for the following fit does not finish in a reasonable time, |
|
111 |
#' # therefore we use the quadratic approximation |
|
112 |
#' m_synth_DFOP_par <- mkinmod(parent = mkinsub("DFOP", c("M1", "M2")), |
|
113 |
#' M1 = mkinsub("SFO"), |
|
114 |
#' M2 = mkinsub("SFO"), |
|
115 |
#' use_of_ff = "max", quiet = TRUE) |
|
116 |
#' DFOP_par_c <- synthetic_data_for_UBA_2014[[12]]$data |
|
117 |
#' f_tc_2 <- mkinfit(m_synth_DFOP_par, DFOP_par_c, error_model = "tc", |
|
118 |
#' error_model_algorithm = "direct", quiet = TRUE) |
|
119 |
#' confint(f_tc_2, method = "quadratic") |
|
120 |
#' confint(f_tc_2, "parent_0", method = "quadratic") |
|
121 |
#' } |
|
122 |
#' @export |
|
123 |
confint.mkinfit <- function(object, parm, |
|
124 |
level = 0.95, alpha = 1 - level, cutoff, |
|
125 |
method = c("quadratic", "profile"), |
|
126 |
transformed = TRUE, backtransform = TRUE, |
|
127 |
cores = parallel::detectCores(), rel_tol = 0.01, quiet = FALSE, ...) |
|
128 |
{ |
|
129 | 1260x |
tparms <- parms(object, transformed = TRUE) |
130 | 1260x |
bparms <- parms(object, transformed = FALSE) |
131 | 1260x |
tpnames <- names(tparms) |
132 | 1260x |
bpnames <- names(bparms) |
133 | ||
134 | 1260x |
return_pnames <- if (missing(parm)) { |
135 | 210x |
if (backtransform) bpnames else tpnames |
136 |
} else { |
|
137 | 210x |
parm |
138 |
} |
|
139 | ||
140 | 1260x |
p <- length(return_pnames) |
141 | ||
142 | 1260x |
method <- match.arg(method) |
143 | ||
144 | 1260x |
a <- c(alpha / 2, 1 - (alpha / 2)) |
145 | ||
146 | 1260x |
quantiles <- qt(a, object$df.residual) |
147 | ||
148 | 1260x |
covar_pnames <- if (missing(parm)) { |
149 | 420x |
if (transformed) tpnames else bpnames |
150 |
} else { |
|
151 | 210x |
parm |
152 |
} |
|
153 | ||
154 | 1260x |
return_parms <- if (backtransform) bparms[return_pnames] |
155 | 1260x |
else tparms[return_pnames] |
156 | ||
157 | 1260x |
covar_parms <- if (transformed) tparms[covar_pnames] |
158 | 1260x |
else bparms[covar_pnames] |
159 | ||
160 | 1260x |
if (transformed) { |
161 | 840x |
covar <- try(solve(object$hessian), silent = TRUE) |
162 |
} else { |
|
163 | 420x |
covar <- try(solve(object$hessian_notrans), silent = TRUE) |
164 |
} |
|
165 | ||
166 |
# If inverting the covariance matrix failed or produced NA values |
|
167 | 1260x |
if (!is.numeric(covar) | is.na(covar[1])) { |
168 | ! |
ses <- lci <- uci <- rep(NA, p) |
169 |
} else { |
|
170 | 1260x |
ses <- sqrt(diag(covar))[covar_pnames] |
171 | 1260x |
lci <- covar_parms + quantiles[1] * ses |
172 | 1260x |
uci <- covar_parms + quantiles[2] * ses |
173 | 1260x |
if (transformed & backtransform) { |
174 | 630x |
lci_back <- backtransform_odeparms(lci, |
175 | 630x |
object$mkinmod, object$transform_rates, object$transform_fractions) |
176 | 630x |
uci_back <- backtransform_odeparms(uci, |
177 | 630x |
object$mkinmod, object$transform_rates, object$transform_fractions) |
178 | ||
179 | 630x |
return_errparm_names <- intersect(names(object$errparms), return_pnames) |
180 | 630x |
lci <- c(lci_back, lci[return_errparm_names]) |
181 | 630x |
uci <- c(uci_back, uci[return_errparm_names]) |
182 |
} |
|
183 |
} |
|
184 | 1260x |
ci <- cbind(lower = lci, upper = uci) |
185 | ||
186 | 1260x |
if (method == "profile") { |
187 | ||
188 | 210x |
ci_quadratic <- ci |
189 | ||
190 | 210x |
if (!quiet) message("Profiling the likelihood") |
191 | ||
192 | 210x |
lci <- uci <- rep(NA, p) |
193 | 210x |
names(lci) <- names(uci) <- return_pnames |
194 | ||
195 | 210x |
profile_pnames <- if(missing(parm)) names(parms(object)) |
196 | 210x |
else parm |
197 | ||
198 | 210x |
if (missing(cutoff)) { |
199 | 210x |
cutoff <- 0.5 * qchisq(1 - alpha, 1) |
200 |
} |
|
201 | ||
202 | 210x |
all_parms <- parms(object) |
203 | ||
204 | 210x |
get_ci <- function(pname) { |
205 | 3x |
pnames_free <- setdiff(names(all_parms), pname) |
206 | 3x |
profile_ll <- function(x) |
207 |
{ |
|
208 | 80x |
pll_cost <- function(P) { |
209 | 3132x |
parms_cost <- all_parms |
210 | 3132x |
parms_cost[pnames_free] <- P[pnames_free] |
211 | 3132x |
parms_cost[pname] <- x |
212 | 3132x |
- object$ll(parms_cost) |
213 |
} |
|
214 | 80x |
- nlminb(all_parms[pnames_free], pll_cost)$objective |
215 |
} |
|
216 | ||
217 | 3x |
cost <- function(x) { |
218 | 80x |
(cutoff - (object$logLik - profile_ll(x)))^2 |
219 |
} |
|
220 | ||
221 | 3x |
lower_quadratic <- ci_quadratic["lower"][pname] |
222 | 3x |
upper_quadratic <- ci_quadratic["upper"][pname] |
223 | 3x |
ltol <- if (!is.na(lower_quadratic)) rel_tol * lower_quadratic else .Machine$double.eps^0.25 |
224 | 3x |
utol <- if (!is.na(upper_quadratic)) rel_tol * upper_quadratic else .Machine$double.eps^0.25 |
225 | 3x |
lci_pname <- optimize(cost, lower = 0, upper = all_parms[pname], tol = ltol)$minimum |
226 | 3x |
uci_pname <- optimize(cost, lower = all_parms[pname], |
227 | 3x |
upper = ifelse(grepl("^f_|^g$", pname), 1, 15 * all_parms[pname]), |
228 | 3x |
tol = utol)$minimum |
229 | 3x |
return(c(lci_pname, uci_pname)) |
230 |
} |
|
231 | 210x |
ci <- t(parallel::mcmapply(get_ci, profile_pnames, mc.cores = cores)) |
232 |
} |
|
233 | ||
234 | 1257x |
colnames(ci) <- paste0( |
235 | 1257x |
format(100 * a, trim = TRUE, scientific = FALSE, digits = 3), "%") |
236 | ||
237 | 1257x |
return(ci) |
238 |
} |
1 |
#' Set non-detects and unquantified values in residue series without replicates |
|
2 |
#' |
|
3 |
#' This function automates replacing unquantified values in residue time and |
|
4 |
#' depth series. For time series, the function performs part of the residue |
|
5 |
#' processing proposed in the FOCUS kinetics guidance for parent compounds |
|
6 |
#' and metabolites. For two-dimensional residue series over time and depth, |
|
7 |
#' it automates the proposal of Boesten et al (2015). |
|
8 |
#' |
|
9 |
#' @param res_raw Character vector of a residue time series, or matrix of |
|
10 |
#' residue values with rows representing depth profiles for a specific sampling |
|
11 |
#' time, and columns representing time series of residues at the same depth. |
|
12 |
#' Values below the limit of detection (lod) have to be coded as "nd", values |
|
13 |
#' between the limit of detection and the limit of quantification, if any, have |
|
14 |
#' to be coded as "nq". Samples not analysed have to be coded as "na". All |
|
15 |
#' values that are not "na", "nd" or "nq" have to be coercible to numeric |
|
16 |
#' @param lod Limit of detection (numeric) |
|
17 |
#' @param loq Limit of quantification(numeric). Must be specified if the FOCUS rule to |
|
18 |
#' stop after the first non-detection is to be applied |
|
19 |
#' @param time_zero_presence Do we assume that residues occur at time zero? |
|
20 |
#' This only affects samples from the first sampling time that have been |
|
21 |
#' reported as "nd" (not detected). |
|
22 |
#' @references Boesten, J. J. T. I., van der Linden, A. M. A., Beltman, W. H. |
|
23 |
#' J. and Pol, J. W. (2015). Leaching of plant protection products and their |
|
24 |
#' transformation products; Proposals for improving the assessment of leaching |
|
25 |
#' to groundwater in the Netherlands — Version 2. Alterra report 2630, Alterra |
|
26 |
#' Wageningen UR (University & Research centre) |
|
27 |
#' @references FOCUS (2014) Generic Guidance for Estimating Persistence and Degradation |
|
28 |
#' Kinetics from Environmental Fate Studies on Pesticides in EU Registration, Version 1.1, |
|
29 |
#' 18 December 2014, p. 251 |
|
30 |
#' @return A numeric vector, if a vector was supplied, or a numeric matrix otherwise |
|
31 |
#' @export |
|
32 |
#' @examples |
|
33 |
#' # FOCUS (2014) p. 75/76 and 131/132 |
|
34 |
#' parent_1 <- c(.12, .09, .05, .03, "nd", "nd", "nd", "nd", "nd", "nd") |
|
35 |
#' set_nd_nq(parent_1, 0.02) |
|
36 |
#' parent_2 <- c(.12, .09, .05, .03, "nd", "nd", .03, "nd", "nd", "nd") |
|
37 |
#' set_nd_nq(parent_2, 0.02) |
|
38 |
#' set_nd_nq_focus(parent_2, 0.02, loq = 0.05) |
|
39 |
#' parent_3 <- c(.12, .09, .05, .03, "nd", "nd", .06, "nd", "nd", "nd") |
|
40 |
#' set_nd_nq(parent_3, 0.02) |
|
41 |
#' set_nd_nq_focus(parent_3, 0.02, loq = 0.05) |
|
42 |
#' metabolite <- c("nd", "nd", "nd", 0.03, 0.06, 0.10, 0.11, 0.10, 0.09, 0.05, 0.03, "nd", "nd") |
|
43 |
#' set_nd_nq(metabolite, 0.02) |
|
44 |
#' set_nd_nq_focus(metabolite, 0.02, 0.05) |
|
45 |
#' # |
|
46 |
#' # Boesten et al. (2015), p. 57/58 |
|
47 |
#' table_8 <- matrix( |
|
48 |
#' c(10, 10, rep("nd", 4), |
|
49 |
#' 10, 10, rep("nq", 2), rep("nd", 2), |
|
50 |
#' 10, 10, 10, "nq", "nd", "nd", |
|
51 |
#' "nq", 10, "nq", rep("nd", 3), |
|
52 |
#' "nd", "nq", "nq", rep("nd", 3), |
|
53 |
#' rep("nd", 6), rep("nd", 6)), |
|
54 |
#' ncol = 6, byrow = TRUE) |
|
55 |
#' set_nd_nq(table_8, 0.5, 1.5, time_zero_presence = TRUE) |
|
56 |
#' table_10 <- matrix( |
|
57 |
#' c(10, 10, rep("nd", 4), |
|
58 |
#' 10, 10, rep("nd", 4), |
|
59 |
#' 10, 10, 10, rep("nd", 3), |
|
60 |
#' "nd", 10, rep("nd", 4), |
|
61 |
#' rep("nd", 18)), |
|
62 |
#' ncol = 6, byrow = TRUE) |
|
63 |
#' set_nd_nq(table_10, 0.5, time_zero_presence = TRUE) |
|
64 |
set_nd_nq <- function(res_raw, lod, loq = NA, time_zero_presence = FALSE) { |
|
65 | 10x |
if (!is.character(res_raw)) { |
66 | ! |
stop("Please supply a vector or a matrix of character values") |
67 |
} |
|
68 | 10x |
if (is.vector(res_raw)) { |
69 | 8x |
was_vector <- TRUE |
70 | 8x |
res_raw <- as.matrix(res_raw) |
71 |
} else { |
|
72 | 2x |
was_vector <- FALSE |
73 | 2x |
if (!is.matrix(res_raw)) { |
74 | ! |
stop("Please supply a vector or a matrix of character values") |
75 |
} |
|
76 |
} |
|
77 | 10x |
nq <- 0.5 * (loq + lod) |
78 | 10x |
nda <- 0.5 * lod # not detected but adjacent to detection |
79 | 10x |
res_raw[res_raw == "nq"] <- nq |
80 | ||
81 | 10x |
if (!time_zero_presence) { |
82 | 8x |
for (j in 1:ncol(res_raw)) { |
83 | 3x |
if (res_raw[1, j] == "nd") res_raw[1, j] <- "na" |
84 |
} |
|
85 |
} |
|
86 | 10x |
res_raw[res_raw == "na"] <- NA |
87 | ||
88 | 10x |
not_nd_na <- function(value) !(grepl("nd", value) | is.na(value)) |
89 | ||
90 | 10x |
for (i in 1:nrow(res_raw)) { |
91 | 94x |
for (j in 1:ncol(res_raw)) { |
92 | 164x |
if (!is.na(res_raw[i, j]) && res_raw[i, j] == "nd") { |
93 | 98x |
if (i > 1) { # check earlier sample in same layer |
94 | 17x |
if (not_nd_na(res_raw[i - 1, j])) res_raw[i, j] <- "nda" |
95 |
} |
|
96 | 98x |
if (i < nrow(res_raw)) { # check later sample |
97 | 7x |
if (not_nd_na(res_raw[i + 1, j])) res_raw[i, j] <- "nda" |
98 |
} |
|
99 | 98x |
if (j > 1) { # check above sample at the same time |
100 | 9x |
if (not_nd_na(res_raw[i, j - 1])) res_raw[i, j] <- "nda" |
101 |
} |
|
102 | 98x |
if (j < ncol(res_raw)) { # check sample below at the same time |
103 | 2x |
if (not_nd_na(res_raw[i, j + 1])) res_raw[i, j] <- "nda" |
104 |
} |
|
105 |
} |
|
106 |
} |
|
107 |
} |
|
108 | 10x |
res_raw[res_raw == "nda"] <- nda |
109 | 10x |
res_raw[res_raw == "nd"] <- NA |
110 | ||
111 | 10x |
result <- as.numeric(res_raw) |
112 | 10x |
dim(result) <- dim(res_raw) |
113 | 10x |
dimnames(result) <- dimnames(res_raw) |
114 | 8x |
if (was_vector) result <- as.vector(result) |
115 | 10x |
return(result) |
116 |
} |
|
117 | ||
118 |
#' @describeIn set_nd_nq Set non-detects in residue time series according to FOCUS rules |
|
119 |
#' @param set_first_sample_nd Should the first sample be set to "first_sample_nd_value" |
|
120 |
#' in case it is a non-detection? |
|
121 |
#' @param first_sample_nd_value Value to be used for the first sample if it is a non-detection |
|
122 |
#' @param ignore_below_loq_after_first_nd Should we ignore values below the LOQ after the first |
|
123 |
#' non-detection that occurs after the quantified values? |
|
124 |
#' @export |
|
125 |
set_nd_nq_focus <- function(res_raw, lod, loq = NA, |
|
126 |
set_first_sample_nd = TRUE, first_sample_nd_value = 0, |
|
127 |
ignore_below_loq_after_first_nd = TRUE) |
|
128 |
{ |
|
129 | ||
130 | ! |
if (!is.vector(res_raw)) stop("FOCUS rules are only specified for one-dimensional time series") |
131 | ||
132 | 5x |
if (ignore_below_loq_after_first_nd & is.na(loq)) { |
133 | 1x |
stop("You need to specify an LOQ") |
134 |
} |
|
135 | ||
136 | 4x |
n <- length(res_raw) |
137 | 4x |
if (ignore_below_loq_after_first_nd) { |
138 | 4x |
for (i in 3:n) { |
139 | 35x |
if (!res_raw[i - 2] %in% c("na", "nd")) { |
140 | 21x |
if (res_raw[i - 1] == "nd") { |
141 | 5x |
res_remaining <- res_raw[i:n] |
142 | 5x |
res_remaining_unquantified <- ifelse(res_remaining == "na", TRUE, |
143 | 5x |
ifelse(res_remaining == "nd", TRUE, |
144 | 5x |
ifelse(res_remaining == "nq", TRUE, |
145 | 5x |
ifelse(suppressWarnings(as.numeric(res_remaining)) < loq, TRUE, FALSE)))) |
146 | 5x |
res_remaining_numeric <- suppressWarnings(as.numeric(res_remaining)) |
147 | 5x |
res_remaining_below_loq <- ifelse(res_remaining == "nq", TRUE, |
148 | 5x |
ifelse(!is.na(res_remaining_numeric) & res_remaining_numeric < loq, TRUE, FALSE)) |
149 | 5x |
if (all(res_remaining_unquantified)) { |
150 | 4x |
res_raw[i:n] <- ifelse(res_remaining_below_loq, "nd", res_remaining) |
151 |
} |
|
152 |
} |
|
153 |
} |
|
154 |
} |
|
155 |
} |
|
156 | ||
157 | 4x |
result <- set_nd_nq(res_raw, lod = lod, loq = loq) |
158 | ||
159 | 4x |
if (set_first_sample_nd) { |
160 | 1x |
if (res_raw[1] == "nd") result[1] <- first_sample_nd_value |
161 |
} |
|
162 | ||
163 | 4x |
return(result) |
164 |
} |
1 |
#' Function to plot the confidence intervals obtained using mkinfit |
|
2 |
#' |
|
3 |
#' This function plots the confidence intervals for the parameters fitted using |
|
4 |
#' \code{\link{mkinfit}}. |
|
5 |
#' |
|
6 |
#' @param object A fit represented in an \code{\link{mkinfit}} object. |
|
7 |
#' @return Nothing is returned by this function, as it is called for its side |
|
8 |
#' effect, namely to produce a plot. |
|
9 |
#' @author Johannes Ranke |
|
10 |
#' @examples |
|
11 |
#' |
|
12 |
#' \dontrun{ |
|
13 |
#' model <- mkinmod( |
|
14 |
#' T245 = mkinsub("SFO", to = c("phenol"), sink = FALSE), |
|
15 |
#' phenol = mkinsub("SFO", to = c("anisole")), |
|
16 |
#' anisole = mkinsub("SFO"), use_of_ff = "max") |
|
17 |
#' fit <- mkinfit(model, subset(mccall81_245T, soil == "Commerce"), quiet = TRUE) |
|
18 |
#' mkinparplot(fit) |
|
19 |
#' } |
|
20 |
#' @export |
|
21 |
mkinparplot <- function(object) { |
|
22 | 70x |
state.optim = rownames(subset(object$start, type == "state")) |
23 | 70x |
deparms.optim = rownames(subset(object$start, type == "deparm")) |
24 | 70x |
fractions.optim = grep("^f_", deparms.optim, value = TRUE) |
25 | 70x |
N.optim = grep("^N_", deparms.optim, value = TRUE) |
26 | ! |
if ("g" %in% deparms.optim) fractions.optim <- c("g", fractions.optim) |
27 | 70x |
rates.optim.unsorted = setdiff(deparms.optim, union(fractions.optim, N.optim)) |
28 | 70x |
rates.optim <- rownames(object$start[rates.optim.unsorted, ]) |
29 | 70x |
n.plot <- c(state.optim = length(state.optim), |
30 | 70x |
rates.optim = length(rates.optim), |
31 | 70x |
N.optim = length(N.optim), |
32 | 70x |
fractions.optim = length(fractions.optim)) |
33 | 70x |
n.plot <- n.plot[n.plot > 0] |
34 | ||
35 | 70x |
oldpar <- par(no.readonly = TRUE) |
36 | 70x |
on.exit(par(oldpar, no.readonly = TRUE)) |
37 | 70x |
layout(matrix(1:length(n.plot), ncol = 1), heights = n.plot + 1) |
38 | ||
39 | 70x |
s <- summary(object) |
40 | 70x |
bpar <- data.frame(t(s$bpar[, c("Estimate", "Lower", "Upper")])) |
41 | 70x |
par(mar = c(2.1, 2.1, 0.1, 2.1)) |
42 | 70x |
par(cex = 1) |
43 | 70x |
for (type in names(n.plot)) { |
44 | 140x |
parnames <- get(type) |
45 | 140x |
values <- bpar[parnames] |
46 | 140x |
values_with_confints <- data.frame(t(subset(data.frame(t(values)), !is.na("Lower")))) |
47 | 140x |
xlim = switch(type, |
48 | 140x |
state.optim = range(c(0, unlist(values)), |
49 | 140x |
na.rm = TRUE, finite = TRUE), |
50 | 140x |
rates.optim = range(c(0, unlist(values)), |
51 | 140x |
na.rm = TRUE, finite = TRUE), |
52 | 140x |
N.optim = range(c(0, 1, unlist(values)), |
53 | 140x |
na.rm = TRUE, finite = TRUE), |
54 | 140x |
fractions.optim = range(c(0, 1, unlist(values)), |
55 | 140x |
na.rm = TRUE, finite = TRUE)) |
56 | 140x |
parname_index <- length(parnames):1 # Reverse order for strip chart |
57 | ||
58 | 140x |
stripchart(values["Estimate", ][parname_index], |
59 | 140x |
xlim = xlim, |
60 | 140x |
ylim = c(0.5, length(get(type)) + 0.5), |
61 | 140x |
yaxt = "n") |
62 | 70x |
if (type %in% c("rates.optim", "fractions.optim")) abline(v = 0, lty = 2) |
63 | ! |
if (type %in% c("N.optim", "fractions.optim")) abline(v = 1, lty = 2) |
64 | 140x |
position <- ifelse(values["Estimate", ] < mean(xlim), "right", "left") |
65 | 140x |
text(ifelse(position == "left", min(xlim), max(xlim)), |
66 | 140x |
parname_index, parnames, |
67 | 140x |
pos = ifelse(position == "left", 4, 2)) |
68 | ||
69 | 140x |
values.upper.nonInf <- ifelse(values["Upper", ] == Inf, 1.5 * xlim[[2]], values["Upper", ]) |
70 |
# Suppress warnings for non-existing arrow lengths |
|
71 | 140x |
suppressWarnings(arrows(as.numeric(values["Lower", ]), parname_index, |
72 | 140x |
as.numeric(values.upper.nonInf), parname_index, |
73 | 140x |
code = 3, angle = 90, length = 0.05)) |
74 |
} |
|
75 |
} |
1 |
#' Summary method for class "saem.mmkin" |
|
2 |
#' |
|
3 |
#' Lists model equations, initial parameter values, optimised parameters |
|
4 |
#' for fixed effects (population), random effects (deviations from the |
|
5 |
#' population mean) and residual error model, as well as the resulting |
|
6 |
#' endpoints such as formation fractions and DT50 values. Optionally |
|
7 |
#' (default is FALSE), the data are listed in full. |
|
8 |
#' |
|
9 |
#' @param object an object of class [saem.mmkin] |
|
10 |
#' @param x an object of class [summary.saem.mmkin] |
|
11 |
#' @param data logical, indicating whether the full data should be included in |
|
12 |
#' the summary. |
|
13 |
#' @param verbose Should the summary be verbose? |
|
14 |
#' @param distimes logical, indicating whether DT50 and DT90 values should be |
|
15 |
#' included. |
|
16 |
#' @param digits Number of digits to use for printing |
|
17 |
#' @param \dots optional arguments passed to methods like \code{print}. |
|
18 |
#' @inheritParams endpoints |
|
19 |
#' @return The summary function returns a list based on the [saemix::SaemixObject] |
|
20 |
#' obtained in the fit, with at least the following additional components |
|
21 |
#' \item{saemixversion, mkinversion, Rversion}{The saemix, mkin and R versions used} |
|
22 |
#' \item{date.fit, date.summary}{The dates where the fit and the summary were |
|
23 |
#' produced} |
|
24 |
#' \item{diffs}{The differential equations used in the degradation model} |
|
25 |
#' \item{use_of_ff}{Was maximum or minimum use made of formation fractions} |
|
26 |
#' \item{data}{The data} |
|
27 |
#' \item{confint_trans}{Transformed parameters as used in the optimisation, with confidence intervals} |
|
28 |
#' \item{confint_back}{Backtransformed parameters, with confidence intervals if available} |
|
29 |
#' \item{confint_errmod}{Error model parameters with confidence intervals} |
|
30 |
#' \item{ff}{The estimated formation fractions derived from the fitted |
|
31 |
#' model.} |
|
32 |
#' \item{distimes}{The DT50 and DT90 values for each observed variable.} |
|
33 |
#' \item{SFORB}{If applicable, eigenvalues of SFORB components of the model.} |
|
34 |
#' The print method is called for its side effect, i.e. printing the summary. |
|
35 |
#' @importFrom stats predict vcov |
|
36 |
#' @author Johannes Ranke for the mkin specific parts |
|
37 |
#' saemix authors for the parts inherited from saemix. |
|
38 |
#' @examples |
|
39 |
#' # Generate five datasets following DFOP-SFO kinetics |
|
40 |
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
41 |
#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "m1"), |
|
42 |
#' m1 = mkinsub("SFO"), quiet = TRUE) |
|
43 |
#' set.seed(1234) |
|
44 |
#' k1_in <- rlnorm(5, log(0.1), 0.3) |
|
45 |
#' k2_in <- rlnorm(5, log(0.02), 0.3) |
|
46 |
#' g_in <- plogis(rnorm(5, qlogis(0.5), 0.3)) |
|
47 |
#' f_parent_to_m1_in <- plogis(rnorm(5, qlogis(0.3), 0.3)) |
|
48 |
#' k_m1_in <- rlnorm(5, log(0.02), 0.3) |
|
49 |
#' |
|
50 |
#' pred_dfop_sfo <- function(k1, k2, g, f_parent_to_m1, k_m1) { |
|
51 |
#' mkinpredict(dfop_sfo, |
|
52 |
#' c(k1 = k1, k2 = k2, g = g, f_parent_to_m1 = f_parent_to_m1, k_m1 = k_m1), |
|
53 |
#' c(parent = 100, m1 = 0), |
|
54 |
#' sampling_times) |
|
55 |
#' } |
|
56 |
#' |
|
57 |
#' ds_mean_dfop_sfo <- lapply(1:5, function(i) { |
|
58 |
#' mkinpredict(dfop_sfo, |
|
59 |
#' c(k1 = k1_in[i], k2 = k2_in[i], g = g_in[i], |
|
60 |
#' f_parent_to_m1 = f_parent_to_m1_in[i], k_m1 = k_m1_in[i]), |
|
61 |
#' c(parent = 100, m1 = 0), |
|
62 |
#' sampling_times) |
|
63 |
#' }) |
|
64 |
#' names(ds_mean_dfop_sfo) <- paste("ds", 1:5) |
|
65 |
#' |
|
66 |
#' ds_syn_dfop_sfo <- lapply(ds_mean_dfop_sfo, function(ds) { |
|
67 |
#' add_err(ds, |
|
68 |
#' sdfunc = function(value) sqrt(1^2 + value^2 * 0.07^2), |
|
69 |
#' n = 1)[[1]] |
|
70 |
#' }) |
|
71 |
#' |
|
72 |
#' \dontrun{ |
|
73 |
#' # Evaluate using mmkin and saem |
|
74 |
#' f_mmkin_dfop_sfo <- mmkin(list(dfop_sfo), ds_syn_dfop_sfo, |
|
75 |
#' quiet = TRUE, error_model = "tc", cores = 5) |
|
76 |
#' f_saem_dfop_sfo <- saem(f_mmkin_dfop_sfo) |
|
77 |
#' print(f_saem_dfop_sfo) |
|
78 |
#' illparms(f_saem_dfop_sfo) |
|
79 |
#' f_saem_dfop_sfo_2 <- update(f_saem_dfop_sfo, |
|
80 |
#' no_random_effect = c("parent_0", "log_k_m1")) |
|
81 |
#' illparms(f_saem_dfop_sfo_2) |
|
82 |
#' intervals(f_saem_dfop_sfo_2) |
|
83 |
#' summary(f_saem_dfop_sfo_2, data = TRUE) |
|
84 |
#' # Add a correlation between random effects of g and k2 |
|
85 |
#' cov_model_3 <- f_saem_dfop_sfo_2$so@model@covariance.model |
|
86 |
#' cov_model_3["log_k2", "g_qlogis"] <- 1 |
|
87 |
#' cov_model_3["g_qlogis", "log_k2"] <- 1 |
|
88 |
#' f_saem_dfop_sfo_3 <- update(f_saem_dfop_sfo, |
|
89 |
#' covariance.model = cov_model_3) |
|
90 |
#' intervals(f_saem_dfop_sfo_3) |
|
91 |
#' # The correlation does not improve the fit judged by AIC and BIC, although |
|
92 |
#' # the likelihood is higher with the additional parameter |
|
93 |
#' anova(f_saem_dfop_sfo, f_saem_dfop_sfo_2, f_saem_dfop_sfo_3) |
|
94 |
#' } |
|
95 |
#' |
|
96 |
#' @export |
|
97 |
summary.saem.mmkin <- function(object, data = FALSE, verbose = FALSE, |
|
98 |
covariates = NULL, covariate_quantile = 0.5, |
|
99 |
distimes = TRUE, ...) { |
|
100 | ||
101 | 800x |
mod_vars <- names(object$mkinmod$diffs) |
102 | ||
103 | 800x |
pnames <- names(object$mean_dp_start) |
104 | 800x |
names_fixed_effects <- object$so@results@name.fixed |
105 | 800x |
n_fixed <- length(names_fixed_effects) |
106 | ||
107 | 800x |
conf.int <- object$so@results@conf.int |
108 | 800x |
rownames(conf.int) <- conf.int$name |
109 | 800x |
confint_trans <- as.matrix(parms(object, ci = TRUE)) |
110 | 800x |
colnames(confint_trans)[1] <- "est." |
111 | ||
112 |
# In case objects were produced by earlier versions of saem |
|
113 | ! |
if (is.null(object$transformations)) object$transformations <- "mkin" |
114 | ||
115 | 800x |
if (object$transformations == "mkin") { |
116 | 396x |
bp <- backtransform_odeparms(confint_trans[pnames, "est."], object$mkinmod, |
117 | 396x |
object$transform_rates, object$transform_fractions) |
118 | 396x |
bpnames <- names(bp) |
119 | ||
120 |
# Transform boundaries of CI for one parameter at a time, |
|
121 |
# with the exception of sets of formation fractions (single fractions are OK). |
|
122 | 396x |
f_names_skip <- character(0) |
123 | 396x |
for (box in mod_vars) { # Figure out sets of fractions to skip |
124 | 492x |
f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE) |
125 | 492x |
n_paths <- length(f_names) |
126 | ! |
if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names) |
127 |
} |
|
128 | ||
129 | 396x |
confint_back <- matrix(NA, nrow = length(bp), ncol = 3, |
130 | 396x |
dimnames = list(bpnames, colnames(confint_trans))) |
131 | 396x |
confint_back[, "est."] <- bp |
132 | ||
133 | 396x |
for (pname in pnames) { |
134 | 1291x |
if (!pname %in% f_names_skip) { |
135 | 1291x |
par.lower <- confint_trans[pname, "lower"] |
136 | 1291x |
par.upper <- confint_trans[pname, "upper"] |
137 | 1291x |
names(par.lower) <- names(par.upper) <- pname |
138 | 1291x |
bpl <- backtransform_odeparms(par.lower, object$mkinmod, |
139 | 1291x |
object$transform_rates, |
140 | 1291x |
object$transform_fractions) |
141 | 1291x |
bpu <- backtransform_odeparms(par.upper, object$mkinmod, |
142 | 1291x |
object$transform_rates, |
143 | 1291x |
object$transform_fractions) |
144 | 1291x |
confint_back[names(bpl), "lower"] <- bpl |
145 | 1291x |
confint_back[names(bpu), "upper"] <- bpu |
146 |
} |
|
147 |
} |
|
148 |
} else { |
|
149 | 404x |
confint_back <- confint_trans[names_fixed_effects, ] |
150 |
} |
|
151 | ||
152 |
# Correlation of fixed effects (inspired by summary.nlme) |
|
153 | 800x |
cov_so <- try(solve(object$so@results@fim), silent = TRUE) |
154 | 800x |
if (inherits(cov_so, "try-error")) { |
155 | ! |
object$corFixed <- NA |
156 |
} else { |
|
157 | 800x |
varFix <- cov_so[1:n_fixed, 1:n_fixed] |
158 | 800x |
stdFix <- sqrt(diag(varFix)) |
159 | 800x |
object$corFixed <- array( |
160 | 800x |
t(varFix/stdFix)/stdFix, |
161 | 800x |
dim(varFix), |
162 | 800x |
list(names_fixed_effects, names_fixed_effects)) |
163 |
} |
|
164 | ||
165 |
# Random effects |
|
166 | 800x |
sdnames <- intersect(rownames(conf.int), paste0("SD.", pnames)) |
167 | 800x |
corrnames <- grep("^Corr.", rownames(conf.int), value = TRUE) |
168 | 800x |
confint_ranef <- as.matrix(conf.int[c(sdnames, corrnames), c("estimate", "lower", "upper")]) |
169 | 800x |
colnames(confint_ranef)[1] <- "est." |
170 | ||
171 |
# Error model |
|
172 | 800x |
enames <- if (object$err_mod == "const") "a.1" else c("a.1", "b.1") |
173 | 800x |
confint_errmod <- as.matrix(conf.int[enames, c("estimate", "lower", "upper")]) |
174 | 800x |
colnames(confint_errmod)[1] <- "est." |
175 | ||
176 | 800x |
object$confint_trans <- confint_trans |
177 | 800x |
object$confint_ranef <- confint_ranef |
178 | 800x |
object$confint_errmod <- confint_errmod |
179 | 800x |
object$confint_back <- confint_back |
180 | ||
181 | 800x |
object$date.summary = date() |
182 | 800x |
object$use_of_ff = object$mkinmod$use_of_ff |
183 | 800x |
object$error_model_algorithm = object$mmkin_orig[[1]]$error_model_algorithm |
184 | 800x |
err_mod = object$mmkin_orig[[1]]$err_mod |
185 | ||
186 | 800x |
object$diffs <- object$mkinmod$diffs |
187 | 800x |
object$print_data <- data # boolean: Should we print the data? |
188 | 800x |
so_pred <- object$so@results@predictions |
189 | ||
190 | 800x |
names(object$data)[4] <- "observed" # rename value to observed |
191 | ||
192 | 800x |
object$verbose <- verbose |
193 | ||
194 | 800x |
object$fixed <- object$mmkin_orig[[1]]$fixed |
195 | 800x |
ll <-try(logLik(object$so, method = "is"), silent = TRUE) |
196 | 800x |
if (inherits(ll, "try-error")) { |
197 | ! |
object$logLik <- object$AIC <- object $BIC <- NA |
198 |
} else { |
|
199 | 800x |
object$logLik = logLik(object$so, method = "is") |
200 | 800x |
object$AIC = AIC(object$so) |
201 | 800x |
object$BIC = BIC(object$so) |
202 |
} |
|
203 | ||
204 | 800x |
ep <- endpoints(object) |
205 | 800x |
object$covariates <- ep$covariates |
206 | 800x |
if (length(ep$ff) != 0) |
207 | 330x |
object$ff <- ep$ff |
208 | 800x |
if (distimes) object$distimes <- ep$distimes |
209 | ! |
if (length(ep$SFORB) != 0) object$SFORB <- ep$SFORB |
210 | 800x |
class(object) <- c("summary.saem.mmkin") |
211 | 800x |
return(object) |
212 |
} |
|
213 | ||
214 |
#' @rdname summary.saem.mmkin |
|
215 |
#' @export |
|
216 |
print.summary.saem.mmkin <- function(x, digits = max(3, getOption("digits") - 3), verbose = x$verbose, ...) { |
|
217 | 242x |
cat("saemix version used for fitting: ", x$saemixversion, "\n") |
218 | 242x |
cat("mkin version used for pre-fitting: ", x$mkinversion, "\n") |
219 | 242x |
cat("R version used for fitting: ", x$Rversion, "\n") |
220 | ||
221 | 242x |
cat("Date of fit: ", x$date.fit, "\n") |
222 | 242x |
cat("Date of summary:", x$date.summary, "\n") |
223 | ||
224 | 242x |
cat("\nEquations:\n") |
225 | 242x |
nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]]) |
226 | 242x |
writeLines(strwrap(nice_diffs, exdent = 11)) |
227 | ||
228 | 242x |
cat("\nData:\n") |
229 | 242x |
cat(nrow(x$data), "observations of", |
230 | 242x |
length(unique(x$data$name)), "variable(s) grouped in", |
231 | 242x |
length(unique(x$data$ds)), "datasets\n") |
232 | ||
233 | 242x |
cat("\nModel predictions using solution type", x$solution_type, "\n") |
234 | ||
235 | 242x |
cat("\nFitted in", x$time[["elapsed"]], "s\n") |
236 | 242x |
cat("Using", paste(x$so@options$nbiter.saemix, collapse = ", "), |
237 | 242x |
"iterations and", x$so@options$nb.chains, "chains\n") |
238 | ||
239 | 242x |
cat("\nVariance model: ") |
240 | 242x |
cat(switch(x$err_mod, |
241 | 242x |
const = "Constant variance", |
242 | 242x |
obs = "Variance unique to each observed variable", |
243 | 242x |
tc = "Two-component variance function"), "\n") |
244 | ||
245 | 242x |
cat("\nStarting values for degradation parameters:\n") |
246 | 242x |
print(x$mean_dp_start, digits = digits) |
247 | ||
248 | 242x |
cat("\nFixed degradation parameter values:\n") |
249 | 242x |
if(length(x$fixed$value) == 0) cat("None\n") |
250 | ! |
else print(x$fixed, digits = digits) |
251 | ||
252 | 242x |
cat("\nStarting values for random effects (square root of initial entries in omega):\n") |
253 | 242x |
print(sqrt(x$so@model@omega.init), digits = digits) |
254 | ||
255 | 242x |
cat("\nStarting values for error model parameters:\n") |
256 | 242x |
errparms <- x$so@model@error.init |
257 | 242x |
names(errparms) <- x$so@model@name.sigma |
258 | 242x |
errparms <- errparms[x$so@model@indx.res] |
259 | 242x |
print(errparms, digits = digits) |
260 | ||
261 | 242x |
cat("\nResults:\n\n") |
262 | 242x |
cat("Likelihood computed by importance sampling\n") |
263 | 242x |
print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik, |
264 | 242x |
row.names = " "), digits = digits) |
265 | ||
266 | 242x |
cat("\nOptimised parameters:\n") |
267 | 242x |
print(x$confint_trans, digits = digits) |
268 | ||
269 | 242x |
if (identical(x$corFixed, NA)) { |
270 | ! |
cat("\nCorrelation is not available\n") |
271 |
} else { |
|
272 | 242x |
corr <- x$corFixed |
273 | 242x |
class(corr) <- "correlation" |
274 | 242x |
print(corr, title = "\nCorrelation:", rdig = digits, ...) |
275 |
} |
|
276 | ||
277 | 242x |
cat("\nRandom effects:\n") |
278 | 242x |
print(x$confint_ranef, digits = digits) |
279 | ||
280 | 242x |
cat("\nVariance model:\n") |
281 | 242x |
print(x$confint_errmod, digits = digits) |
282 | ||
283 | 242x |
if (x$transformations == "mkin") { |
284 | 125x |
cat("\nBacktransformed parameters:\n") |
285 | 125x |
print(x$confint_back, digits = digits) |
286 |
} |
|
287 | ||
288 | 242x |
if (!is.null(x$covariates)) { |
289 | ! |
cat("\nCovariates used for endpoints below:\n") |
290 | ! |
print(x$covariates) |
291 |
} |
|
292 | ||
293 | 242x |
printSFORB <- !is.null(x$SFORB) |
294 | 242x |
if(printSFORB){ |
295 | ! |
cat("\nEstimated Eigenvalues of SFORB model(s):\n") |
296 | ! |
print(x$SFORB, digits = digits,...) |
297 |
} |
|
298 | ||
299 | 242x |
printff <- !is.null(x$ff) |
300 | 242x |
if(printff){ |
301 | 117x |
cat("\nResulting formation fractions:\n") |
302 | 117x |
print(data.frame(ff = x$ff), digits = digits,...) |
303 |
} |
|
304 | ||
305 | 242x |
printdistimes <- !is.null(x$distimes) |
306 | 242x |
if(printdistimes){ |
307 | 242x |
cat("\nEstimated disappearance times:\n") |
308 | 242x |
print(x$distimes, digits = digits,...) |
309 |
} |
|
310 | ||
311 | 242x |
if (x$print_data){ |
312 | ! |
cat("\nData:\n") |
313 | ! |
print(format(x$data, digits = digits, ...), row.names = FALSE) |
314 |
} |
|
315 | ||
316 | 242x |
invisible(x) |
317 |
} |
1 |
#' Convert a dataframe from long to wide format |
|
2 |
#' |
|
3 |
#' This function takes a dataframe in the long form, i.e. with a row for each |
|
4 |
#' observed value, and converts it into a dataframe with one independent |
|
5 |
#' variable and several dependent variables as columns. |
|
6 |
#' |
|
7 |
#' @param long_data The dataframe must contain one variable called "time" with |
|
8 |
#' the time values specified by the \code{time} argument, one column called |
|
9 |
#' "name" with the grouping of the observed values, and finally one column of |
|
10 |
#' observed values called "value". |
|
11 |
#' @param time The name of the time variable in the long input data. |
|
12 |
#' @param outtime The name of the time variable in the wide output data. |
|
13 |
#' @return Dataframe in wide format. |
|
14 |
#' @author Johannes Ranke |
|
15 |
#' @examples |
|
16 |
#' |
|
17 |
#' mkin_long_to_wide(FOCUS_2006_D) |
|
18 |
#' |
|
19 |
#' @export mkin_long_to_wide |
|
20 |
mkin_long_to_wide <- function(long_data, time = "time", outtime = "time") |
|
21 |
{ |
|
22 | 494x |
colnames <- unique(long_data$name) |
23 | 494x |
wide_data <- data.frame(time = subset(long_data, name == colnames[1], time)) |
24 | 494x |
names(wide_data) <- outtime |
25 | 494x |
for (var in colnames) { |
26 | 741x |
wide_data[var] <- subset(long_data, name == var, value) |
27 |
} |
|
28 | 494x |
return(wide_data) |
29 |
} |
1 |
#' Lack-of-fit test for models fitted to data with replicates |
|
2 |
#' |
|
3 |
#' This is a generic function with a method currently only defined for mkinfit |
|
4 |
#' objects. It fits an anova model to the data contained in the object and |
|
5 |
#' compares the likelihoods using the likelihood ratio test |
|
6 |
#' \code{\link[lmtest]{lrtest.default}} from the lmtest package. |
|
7 |
#' |
|
8 |
#' The anova model is interpreted as the simplest form of an mkinfit model, |
|
9 |
#' assuming only a constant variance about the means, but not enforcing any |
|
10 |
#' structure of the means, so we have one model parameter for every mean |
|
11 |
#' of replicate samples. |
|
12 |
#' |
|
13 |
#' @param object A model object with a defined loftest method |
|
14 |
#' @param \dots Not used |
|
15 |
#' @export |
|
16 |
loftest <- function(object, ...) { |
|
17 | 2x |
UseMethod("loftest") |
18 |
} |
|
19 | ||
20 |
#' @rdname loftest |
|
21 |
#' @importFrom stats logLik lm dnorm coef |
|
22 |
#' @seealso lrtest |
|
23 |
#' @examples |
|
24 |
#' \dontrun{ |
|
25 |
#' test_data <- subset(synthetic_data_for_UBA_2014[[12]]$data, name == "parent") |
|
26 |
#' sfo_fit <- mkinfit("SFO", test_data, quiet = TRUE) |
|
27 |
#' plot_res(sfo_fit) # We see a clear pattern in the residuals |
|
28 |
#' loftest(sfo_fit) # We have a clear lack of fit |
|
29 |
#' # |
|
30 |
#' # We try a different model (the one that was used to generate the data) |
|
31 |
#' dfop_fit <- mkinfit("DFOP", test_data, quiet = TRUE) |
|
32 |
#' plot_res(dfop_fit) # We don't see systematic deviations, but heteroscedastic residuals |
|
33 |
#' # therefore we should consider adapting the error model, although we have |
|
34 |
#' loftest(dfop_fit) # no lack of fit |
|
35 |
#' # |
|
36 |
#' # This is the anova model used internally for the comparison |
|
37 |
#' test_data_anova <- test_data |
|
38 |
#' test_data_anova$time <- as.factor(test_data_anova$time) |
|
39 |
#' anova_fit <- lm(value ~ time, data = test_data_anova) |
|
40 |
#' summary(anova_fit) |
|
41 |
#' logLik(anova_fit) # We get the same likelihood and degrees of freedom |
|
42 |
#' # |
|
43 |
#' test_data_2 <- synthetic_data_for_UBA_2014[[12]]$data |
|
44 |
#' m_synth_SFO_lin <- mkinmod(parent = list(type = "SFO", to = "M1"), |
|
45 |
#' M1 = list(type = "SFO", to = "M2"), |
|
46 |
#' M2 = list(type = "SFO"), use_of_ff = "max") |
|
47 |
#' sfo_lin_fit <- mkinfit(m_synth_SFO_lin, test_data_2, quiet = TRUE) |
|
48 |
#' plot_res(sfo_lin_fit) # not a good model, we try parallel formation |
|
49 |
#' loftest(sfo_lin_fit) |
|
50 |
#' # |
|
51 |
#' m_synth_SFO_par <- mkinmod(parent = list(type = "SFO", to = c("M1", "M2")), |
|
52 |
#' M1 = list(type = "SFO"), |
|
53 |
#' M2 = list(type = "SFO"), use_of_ff = "max") |
|
54 |
#' sfo_par_fit <- mkinfit(m_synth_SFO_par, test_data_2, quiet = TRUE) |
|
55 |
#' plot_res(sfo_par_fit) # much better for metabolites |
|
56 |
#' loftest(sfo_par_fit) |
|
57 |
#' # |
|
58 |
#' m_synth_DFOP_par <- mkinmod(parent = list(type = "DFOP", to = c("M1", "M2")), |
|
59 |
#' M1 = list(type = "SFO"), |
|
60 |
#' M2 = list(type = "SFO"), use_of_ff = "max") |
|
61 |
#' dfop_par_fit <- mkinfit(m_synth_DFOP_par, test_data_2, quiet = TRUE) |
|
62 |
#' plot_res(dfop_par_fit) # No visual lack of fit |
|
63 |
#' loftest(dfop_par_fit) # no lack of fit found by the test |
|
64 |
#' # |
|
65 |
#' # The anova model used for comparison in the case of transformation products |
|
66 |
#' test_data_anova_2 <- dfop_par_fit$data |
|
67 |
#' test_data_anova_2$variable <- as.factor(test_data_anova_2$variable) |
|
68 |
#' test_data_anova_2$time <- as.factor(test_data_anova_2$time) |
|
69 |
#' anova_fit_2 <- lm(observed ~ time:variable - 1, data = test_data_anova_2) |
|
70 |
#' summary(anova_fit_2) |
|
71 |
#' } |
|
72 |
#' @export |
|
73 |
loftest.mkinfit <- function(object, ...) { |
|
74 | ||
75 | 2x |
name_function <- function(x) { |
76 | 2x |
object_name <- paste(x$mkinmod$name, "with error model", x$err_mod) |
77 | 2x |
if (length(x$bparms.fixed) > 0) { |
78 | ! |
object_name <- paste(object_name, |
79 | ! |
"and fixed parameter(s)", |
80 | ! |
paste(names(x$bparms.fixed), collapse = ", ")) |
81 |
} |
|
82 | 2x |
return(object_name) |
83 |
} |
|
84 | ||
85 |
# Check if we have replicates in the data |
|
86 | 2x |
if (max(aggregate(object$data$observed, |
87 | 2x |
by = list(object$data$variable, object$data$time), length)$x) == 1) { |
88 | 1x |
stop("Not defined for fits to data without replicates") |
89 |
} |
|
90 | ||
91 | 1x |
data_anova <- object$data |
92 | 1x |
data_anova$time <- as.factor(data_anova$time) |
93 | 1x |
data_anova$variable <- as.factor(data_anova$variable) |
94 | 1x |
if (nlevels(data_anova$variable) == 1) { |
95 | 1x |
object_2 <- lm(observed ~ time - 1, data = data_anova) |
96 |
} else { |
|
97 | ! |
object_2 <- lm(observed ~ variable:time - 1, |
98 | ! |
data = data_anova) |
99 |
} |
|
100 | ||
101 | 1x |
object_2$mkinmod <- list(name = "ANOVA") |
102 | 1x |
object_2$err_mod <- "const" |
103 | 1x |
sigma_mle <- sqrt(sum(residuals(object_2)^2)/nobs(object_2)) |
104 | 1x |
object_2$logLik <- sum(dnorm(x = object_2$residuals, |
105 | 1x |
mean = 0, sd = sigma_mle, log = TRUE)) |
106 | 1x |
object_2$data <- object$data # to make the nobs.mkinfit method work |
107 | 1x |
object_2$bparms.optim <- coef(object_2) |
108 | 1x |
object_2$errparms <- 1 # We have estimated one error model parameter |
109 | 1x |
class(object_2) <- "mkinfit" |
110 | ||
111 | 1x |
lmtest::lrtest.default(object_2, object, name = name_function) |
112 |
} |
1 |
#' Add normally distributed errors to simulated kinetic degradation data |
|
2 |
#' |
|
3 |
#' Normally distributed errors are added to data predicted for a specific |
|
4 |
#' degradation model using \code{\link{mkinpredict}}. The variance of the error |
|
5 |
#' may depend on the predicted value and is specified as a standard deviation. |
|
6 |
#' |
|
7 |
#' @param prediction A prediction from a kinetic model as produced by |
|
8 |
#' \code{\link{mkinpredict}}. |
|
9 |
#' @param sdfunc A function taking the predicted value as its only argument and |
|
10 |
#' returning a standard deviation that should be used for generating the |
|
11 |
#' random error terms for this value. |
|
12 |
#' @param secondary The names of state variables that should have an initial |
|
13 |
#' value of zero |
|
14 |
#' @param n The number of datasets to be generated. |
|
15 |
#' @param LOD The limit of detection (LOD). Values that are below the LOD after |
|
16 |
#' adding the random error will be set to NA. |
|
17 |
#' @param reps The number of replicates to be generated within the datasets. |
|
18 |
#' @param digits The number of digits to which the values will be rounded. |
|
19 |
#' @param seed The seed used for the generation of random numbers. If NA, the |
|
20 |
#' seed is not set. |
|
21 |
#' @importFrom stats rnorm |
|
22 |
#' @return A list of datasets compatible with \code{\link{mmkin}}, i.e. the |
|
23 |
#' components of the list are datasets compatible with \code{\link{mkinfit}}. |
|
24 |
#' @author Johannes Ranke |
|
25 |
#' @references Ranke J and Lehmann R (2015) To t-test or not to t-test, that is |
|
26 |
#' the question. XV Symposium on Pesticide Chemistry 2-4 September 2015, |
|
27 |
#' Piacenza, Italy |
|
28 |
#' https://jrwb.de/posters/piacenza_2015.pdf |
|
29 |
#' @examples |
|
30 |
#' |
|
31 |
#' # The kinetic model |
|
32 |
#' m_SFO_SFO <- mkinmod(parent = mkinsub("SFO", "M1"), |
|
33 |
#' M1 = mkinsub("SFO"), use_of_ff = "max") |
|
34 |
#' |
|
35 |
#' # Generate a prediction for a specific set of parameters |
|
36 |
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
37 |
#' |
|
38 |
#' # This is the prediction used for the "Type 2 datasets" on the Piacenza poster |
|
39 |
#' # from 2015 |
|
40 |
#' d_SFO_SFO <- mkinpredict(m_SFO_SFO, |
|
41 |
#' c(k_parent = 0.1, f_parent_to_M1 = 0.5, |
|
42 |
#' k_M1 = log(2)/1000), |
|
43 |
#' c(parent = 100, M1 = 0), |
|
44 |
#' sampling_times) |
|
45 |
#' |
|
46 |
#' # Add an error term with a constant (independent of the value) standard deviation |
|
47 |
#' # of 10, and generate three datasets |
|
48 |
#' d_SFO_SFO_err <- add_err(d_SFO_SFO, function(x) 10, n = 3, seed = 123456789 ) |
|
49 |
#' |
|
50 |
#' # Name the datasets for nicer plotting |
|
51 |
#' names(d_SFO_SFO_err) <- paste("Dataset", 1:3) |
|
52 |
#' |
|
53 |
#' # Name the model in the list of models (with only one member in this case) for |
|
54 |
#' # nicer plotting later on. Be quiet and use only one core not to offend CRAN |
|
55 |
#' # checks |
|
56 |
#' \dontrun{ |
|
57 |
#' f_SFO_SFO <- mmkin(list("SFO-SFO" = m_SFO_SFO), |
|
58 |
#' d_SFO_SFO_err, cores = 1, |
|
59 |
#' quiet = TRUE) |
|
60 |
#' |
|
61 |
#' plot(f_SFO_SFO) |
|
62 |
#' |
|
63 |
#' # We would like to inspect the fit for dataset 3 more closely |
|
64 |
#' # Using double brackets makes the returned object an mkinfit object |
|
65 |
#' # instead of a list of mkinfit objects, so plot.mkinfit is used |
|
66 |
#' plot(f_SFO_SFO[[3]], show_residuals = TRUE) |
|
67 |
#' |
|
68 |
#' # If we use single brackets, we should give two indices (model and dataset), |
|
69 |
#' # and plot.mmkin is used |
|
70 |
#' plot(f_SFO_SFO[1, 3]) |
|
71 |
#' } |
|
72 |
#' |
|
73 |
#' @export |
|
74 |
add_err <- function(prediction, sdfunc, secondary = c("M1", "M2"), |
|
75 |
n = 10, LOD = 0.1, reps = 2, digits = 1, seed = NA) |
|
76 |
{ |
|
77 | 842x |
if (!is.na(seed)) set.seed(seed) |
78 | ||
79 | 862x |
prediction <- as.data.frame(prediction) |
80 | ||
81 |
# The output of mkinpredict is in wide format |
|
82 | 862x |
d_long = mkin_wide_to_long(prediction, time = "time") |
83 | ||
84 |
# Set up the list to be returned |
|
85 | 862x |
d_return = list() |
86 | ||
87 |
# Generate datasets one by one in a loop |
|
88 | 862x |
for (i in 1:n) { |
89 | 1712x |
d_rep = data.frame(lapply(d_long, rep, each = reps)) |
90 | 1712x |
d_rep$value = rnorm(length(d_rep$value), d_rep$value, sdfunc(d_rep$value)) |
91 | ||
92 | 1712x |
d_rep[d_rep$time == 0 & d_rep$name %in% secondary, "value"] <- 0 |
93 | ||
94 |
# Set values below the LOD to NA |
|
95 | 1712x |
d_NA <- transform(d_rep, value = ifelse(value < LOD, NA, value)) |
96 | ||
97 |
# Round the values for convenience |
|
98 | 1712x |
d_NA$value <- round(d_NA$value, digits) |
99 | ||
100 | 1712x |
d_return[[i]] <- d_NA |
101 |
} |
|
102 | ||
103 | 862x |
return(d_return) |
104 |
} |
1 |
utils::globalVariables(c("name", "time", "value")) |
|
2 | ||
3 |
#' Convert a dataframe with observations over time into long format |
|
4 |
#' |
|
5 |
#' This function simply takes a dataframe with one independent variable and |
|
6 |
#' several dependent variable and converts it into the long form as required by |
|
7 |
#' \code{\link{mkinfit}}. |
|
8 |
#' |
|
9 |
#' @param wide_data The dataframe must contain one variable with the time |
|
10 |
#' values specified by the \code{time} argument and usually more than one |
|
11 |
#' column of observed values. |
|
12 |
#' @param time The name of the time variable. |
|
13 |
#' @return Dataframe in long format as needed for \code{\link{mkinfit}}. |
|
14 |
#' @author Johannes Ranke |
|
15 |
#' @keywords manip |
|
16 |
#' @examples |
|
17 |
#' |
|
18 |
#' wide <- data.frame(t = c(1,2,3), x = c(1,4,7), y = c(3,4,5)) |
|
19 |
#' mkin_wide_to_long(wide) |
|
20 |
#' |
|
21 |
#' @export |
|
22 |
mkin_wide_to_long <- function(wide_data, time = "t") |
|
23 |
{ |
|
24 | 1127x |
wide_data <- as.data.frame(wide_data) |
25 | 1127x |
colnames <- names(wide_data) |
26 | ! |
if (!(time %in% colnames)) stop("The data in wide format have to contain a variable named ", time, ".") |
27 | 1127x |
vars <- subset(colnames, colnames != time) |
28 | 1127x |
n <- length(colnames) - 1 |
29 | 1127x |
long_data <- data.frame( |
30 | 1127x |
name = rep(vars, each = length(wide_data[[time]])), |
31 | 1127x |
time = as.numeric(rep(wide_data[[time]], n)), |
32 | 1127x |
value = as.numeric(unlist(wide_data[vars])), |
33 | 1127x |
row.names = NULL) |
34 | 1127x |
return(long_data) |
35 |
} |
1 |
#' Single First-Order kinetics |
|
2 |
#' |
|
3 |
#' Function describing exponential decline from a defined starting value. |
|
4 |
#' |
|
5 |
#' @family parent solutions |
|
6 |
#' @param t Time. |
|
7 |
#' @param parent_0 Starting value for the response variable at time zero. |
|
8 |
#' @param k Kinetic rate constant. |
|
9 |
#' @return The value of the response variable at time \code{t}. |
|
10 |
#' @references |
|
11 |
#' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
12 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
13 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
14 |
#' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
15 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
16 |
#' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence |
|
17 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
18 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
19 |
#' Version 1.1, 18 December 2014 |
|
20 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
21 |
#' @examples |
|
22 |
#' |
|
23 |
#' \dontrun{plot(function(x) SFO.solution(x, 100, 3), 0, 2)} |
|
24 |
#' |
|
25 |
#' @export |
|
26 |
SFO.solution <- function(t, parent_0, k) |
|
27 |
{ |
|
28 | 2338849x |
parent = parent_0 * exp(-k * t) |
29 |
} |
|
30 | ||
31 |
#' First-Order Multi-Compartment kinetics |
|
32 |
#' |
|
33 |
#' Function describing exponential decline from a defined starting value, with |
|
34 |
#' a decreasing rate constant. |
|
35 |
#' |
|
36 |
#' The form given here differs slightly from the original reference by |
|
37 |
#' Gustafson and Holden (1990). The parameter \code{beta} corresponds to 1/beta |
|
38 |
#' in the original equation. |
|
39 |
#' |
|
40 |
#' @family parent solutions |
|
41 |
#' @inherit SFO.solution |
|
42 |
#' @param alpha Shape parameter determined by coefficient of variation of rate |
|
43 |
#' constant values. |
|
44 |
#' @param beta Location parameter. |
|
45 |
#' @note The solution of the FOMC kinetic model reduces to the |
|
46 |
#' \code{\link{SFO.solution}} for large values of \code{alpha} and \code{beta} |
|
47 |
#' with \eqn{k = \frac{\beta}{\alpha}}{k = beta/alpha}. |
|
48 |
#' @references |
|
49 |
#' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence |
|
50 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
51 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
52 |
#' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, |
|
53 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
54 |
#' |
|
55 |
#' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence |
|
56 |
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in |
|
57 |
#' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, |
|
58 |
#' Version 1.1, 18 December 2014 |
|
59 |
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} |
|
60 |
#' |
|
61 |
#' Gustafson DI and Holden LR (1990) Nonlinear pesticide dissipation in soil: |
|
62 |
#' A new model based on spatial variability. \emph{Environmental Science and |
|
63 |
#' Technology} \bold{24}, 1032-1038 |
|
64 |
#' @examples |
|
65 |
#' |
|
66 |
#' plot(function(x) FOMC.solution(x, 100, 10, 2), 0, 2, ylim = c(0, 100)) |
|
67 |
#' |
|
68 |
#' @export |
|
69 |
FOMC.solution <- function(t, parent_0, alpha, beta) |
|
70 |
{ |
|
71 | 32626x |
parent = parent_0 / (t/beta + 1)^alpha |
72 |
} |
|
73 | ||
74 |
#' Indeterminate order rate equation kinetics |
|
75 |
#' |
|
76 |
#' Function describing exponential decline from a defined starting value, with |
|
77 |
#' a concentration dependent rate constant. |
|
78 |
#' |
|
79 |
#' @family parent solutions |
|
80 |
#' @inherit SFO.solution |
|
81 |
#' @param k__iore Rate constant. Note that this depends on the concentration |
|
82 |
#' units used. |
|
83 |
#' @param N Exponent describing the nonlinearity of the rate equation |
|
84 |
#' @note The solution of the IORE kinetic model reduces to the |
|
85 |
#' \code{\link{SFO.solution}} if N = 1. The parameters of the IORE model can |
|
86 |
#' be transformed to equivalent parameters of the FOMC mode - see the NAFTA |
|
87 |
#' guidance for details. |
|
88 |
#' @references NAFTA Technical Working Group on Pesticides (not dated) Guidance |
|
89 |
#' for Evaluating and Calculating Degradation Kinetics in Environmental Media |
|
90 |
#' @examples |
|
91 |
#' |
|
92 |
#' plot(function(x) IORE.solution(x, 100, 0.2, 1.3), 0, 2, ylim = c(0, 100)) |
|
93 |
#' \dontrun{ |
|
94 |
#' fit.fomc <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE) |
|
95 |
#' fit.iore <- mkinfit("IORE", FOCUS_2006_C, quiet = TRUE) |
|
96 |
#' fit.iore.deS <- mkinfit("IORE", FOCUS_2006_C, solution_type = "deSolve", quiet = TRUE) |
|
97 |
#' |
|
98 |
#' print(data.frame(fit.fomc$par, fit.iore$par, fit.iore.deS$par, |
|
99 |
#' row.names = paste("model par", 1:4))) |
|
100 |
#' print(rbind(fomc = endpoints(fit.fomc)$distimes, iore = endpoints(fit.iore)$distimes, |
|
101 |
#' iore.deS = endpoints(fit.iore)$distimes)) |
|
102 |
#' } |
|
103 |
#' |
|
104 |
#' @export |
|
105 |
IORE.solution <- function(t, parent_0, k__iore, N) |
|
106 |
{ |
|
107 | 42328x |
parent = (parent_0^(1 - N) - (1 - N) * k__iore * t)^(1/(1 - N)) |
108 |
} |
|
109 | ||
110 |
#' Double First-Order in Parallel kinetics |
|
111 |
#' |
|
112 |
#' Function describing decline from a defined starting value using the sum of |
|
113 |
#' two exponential decline functions. |
|
114 |
#' |
|
115 |
#' @family parent solutions |
|
116 |
#' @inherit SFO.solution |
|
117 |
#' @param t Time. |
|
118 |
#' @param k1 First kinetic constant. |
|
119 |
#' @param k2 Second kinetic constant. |
|
120 |
#' @param g Fraction of the starting value declining according to the first |
|
121 |
#' kinetic constant. |
|
122 |
#' @examples |
|
123 |
#' |
|
124 |
#' plot(function(x) DFOP.solution(x, 100, 5, 0.5, 0.3), 0, 4, ylim = c(0,100)) |
|
125 |
#' |
|
126 |
#' @export |
|
127 |
DFOP.solution <- function(t, parent_0, k1, k2, g) |
|
128 |
{ |
|
129 | 1904176x |
parent = g * parent_0 * exp(-k1 * t) + |
130 | 1904176x |
(1 - g) * parent_0 * exp(-k2 * t) |
131 |
} |
|
132 | ||
133 |
#' Hockey-Stick kinetics |
|
134 |
#' |
|
135 |
#' Function describing two exponential decline functions with a break point |
|
136 |
#' between them. |
|
137 |
#' |
|
138 |
#' @family parent solutions |
|
139 |
#' @inherit DFOP.solution |
|
140 |
#' @param tb Break point. Before this time, exponential decline according to |
|
141 |
#' \code{k1} is calculated, after this time, exponential decline proceeds |
|
142 |
#' according to \code{k2}. |
|
143 |
#' @examples |
|
144 |
#' |
|
145 |
#' plot(function(x) HS.solution(x, 100, 2, 0.3, 0.5), 0, 2, ylim=c(0,100)) |
|
146 |
#' |
|
147 |
#' @export |
|
148 |
HS.solution <- function(t, parent_0, k1, k2, tb) |
|
149 |
{ |
|
150 | 22552x |
parent = ifelse(t <= tb, |
151 | 22552x |
parent_0 * exp(-k1 * t), |
152 | 22552x |
parent_0 * exp(-k1 * tb) * exp(-k2 * (t - tb))) |
153 |
} |
|
154 | ||
155 |
#' Single First-Order Reversible Binding kinetics |
|
156 |
#' |
|
157 |
#' Function describing the solution of the differential equations describing |
|
158 |
#' the kinetic model with first-order terms for a two-way transfer from a free |
|
159 |
#' to a bound fraction, and a first-order degradation term for the free |
|
160 |
#' fraction. The initial condition is a defined amount in the free fraction |
|
161 |
#' and no substance in the bound fraction. |
|
162 |
#' |
|
163 |
#' @family parent solutions |
|
164 |
#' @inherit SFO.solution |
|
165 |
#' @param k_12 Kinetic constant describing transfer from free to bound. |
|
166 |
#' @param k_21 Kinetic constant describing transfer from bound to free. |
|
167 |
#' @param k_1output Kinetic constant describing degradation of the free |
|
168 |
#' fraction. |
|
169 |
#' @return The value of the response variable, which is the sum of free and |
|
170 |
#' bound fractions at time \code{t}. |
|
171 |
#' @examples |
|
172 |
#' |
|
173 |
#' \dontrun{plot(function(x) SFORB.solution(x, 100, 0.5, 2, 3), 0, 2)} |
|
174 |
#' |
|
175 |
#' @export |
|
176 |
SFORB.solution = function(t, parent_0, k_12, k_21, k_1output) { |
|
177 | 9240x |
sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21) |
178 | 9240x |
b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp |
179 | 9240x |
b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp |
180 | ||
181 | 9240x |
parent = parent_0 * |
182 | 9240x |
(((k_12 + k_21 - b1)/(b2 - b1)) * exp(-b1 * t) + |
183 | 9240x |
((k_12 + k_21 - b2)/(b1 - b2)) * exp(-b2 * t)) |
184 |
} |
|
185 | ||
186 |
#' Logistic kinetics |
|
187 |
#' |
|
188 |
#' Function describing exponential decline from a defined starting value, with |
|
189 |
#' an increasing rate constant, supposedly caused by microbial growth |
|
190 |
#' |
|
191 |
#' @family parent solutions |
|
192 |
#' @inherit SFO.solution |
|
193 |
#' @param kmax Maximum rate constant. |
|
194 |
#' @param k0 Minimum rate constant effective at time zero. |
|
195 |
#' @param r Growth rate of the increase in the rate constant. |
|
196 |
#' @note The solution of the logistic model reduces to the |
|
197 |
#' \code{\link{SFO.solution}} if \code{k0} is equal to \code{kmax}. |
|
198 |
#' @examples |
|
199 |
#' |
|
200 |
#' # Reproduce the plot on page 57 of FOCUS (2014) |
|
201 |
#' plot(function(x) logistic.solution(x, 100, 0.08, 0.0001, 0.2), |
|
202 |
#' from = 0, to = 100, ylim = c(0, 100), |
|
203 |
#' xlab = "Time", ylab = "Residue") |
|
204 |
#' plot(function(x) logistic.solution(x, 100, 0.08, 0.0001, 0.4), |
|
205 |
#' from = 0, to = 100, add = TRUE, lty = 2, col = 2) |
|
206 |
#' plot(function(x) logistic.solution(x, 100, 0.08, 0.0001, 0.8), |
|
207 |
#' from = 0, to = 100, add = TRUE, lty = 3, col = 3) |
|
208 |
#' plot(function(x) logistic.solution(x, 100, 0.08, 0.001, 0.2), |
|
209 |
#' from = 0, to = 100, add = TRUE, lty = 4, col = 4) |
|
210 |
#' plot(function(x) logistic.solution(x, 100, 0.08, 0.08, 0.2), |
|
211 |
#' from = 0, to = 100, add = TRUE, lty = 5, col = 5) |
|
212 |
#' legend("topright", inset = 0.05, |
|
213 |
#' legend = paste0("k0 = ", c(0.0001, 0.0001, 0.0001, 0.001, 0.08), |
|
214 |
#' ", r = ", c(0.2, 0.4, 0.8, 0.2, 0.2)), |
|
215 |
#' lty = 1:5, col = 1:5) |
|
216 |
#' |
|
217 |
#' # Fit with synthetic data |
|
218 |
#' logistic <- mkinmod(parent = mkinsub("logistic")) |
|
219 |
#' |
|
220 |
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
221 |
#' parms_logistic <- c(kmax = 0.08, k0 = 0.0001, r = 0.2) |
|
222 |
#' d_logistic <- mkinpredict(logistic, |
|
223 |
#' parms_logistic, c(parent = 100), |
|
224 |
#' sampling_times) |
|
225 |
#' d_2_1 <- add_err(d_logistic, |
|
226 |
#' sdfunc = function(x) sigma_twocomp(x, 0.5, 0.07), |
|
227 |
#' n = 1, reps = 2, digits = 5, LOD = 0.1, seed = 123456)[[1]] |
|
228 |
#' |
|
229 |
#' m <- mkinfit("logistic", d_2_1, quiet = TRUE) |
|
230 |
#' plot_sep(m) |
|
231 |
#' summary(m)$bpar |
|
232 |
#' endpoints(m)$distimes |
|
233 |
#' |
|
234 |
#' @export |
|
235 |
logistic.solution <- function(t, parent_0, kmax, k0, r) |
|
236 |
{ |
|
237 | 56304x |
parent = parent_0 * (kmax / (kmax - k0 + k0 * exp (r * t))) ^(kmax/r) |
238 |
} |
1 |
#' Plot the distribution of log likelihoods from multistart objects |
|
2 |
#' |
|
3 |
#' Produces a histogram of log-likelihoods. In addition, the likelihood of the |
|
4 |
#' original fit is shown as a red vertical line. |
|
5 |
#' |
|
6 |
#' @param object The [multistart] object |
|
7 |
#' @param breaks Passed to [hist] |
|
8 |
#' @param lpos Positioning of the legend. |
|
9 |
#' @param main Title of the plot |
|
10 |
#' @param \dots Passed to [hist] |
|
11 |
#' @seealso [multistart] |
|
12 |
#' @export |
|
13 |
llhist <- function(object, breaks = "Sturges", lpos = "topleft", main = "", |
|
14 |
...) |
|
15 |
{ |
|
16 | 176x |
oldpar <- par(no.readonly = TRUE) |
17 | 176x |
on.exit(par(oldpar, no.readonly = TRUE)) |
18 | ||
19 | 176x |
if (inherits(object, "multistart.saem.mmkin")) { |
20 | 176x |
llfunc <- function(object) { |
21 | ! |
if (inherits(object$so, "try-error")) return(NA) |
22 | 1408x |
else return(logLik(object$so)) |
23 |
} |
|
24 |
} else { |
|
25 | ! |
stop("llhist is only implemented for multistart.saem.mmkin objects") |
26 |
} |
|
27 | ||
28 | 176x |
ll_orig <- logLik(attr(object, "orig")) |
29 | 176x |
ll <- stats::na.omit(sapply(object, llfunc)) |
30 | ||
31 | 176x |
par(las = 1) |
32 | 176x |
h <- hist(ll, freq = TRUE, |
33 | 176x |
xlab = "", main = main, |
34 | 176x |
ylab = "Frequency of log likelihoods", breaks = breaks, ...) |
35 | ||
36 | 176x |
freq_factor <- h$counts[1] / h$density[1] |
37 | ||
38 | 176x |
abline(v = ll_orig, col = 2) |
39 | ||
40 | 176x |
legend(lpos, inset = c(0.05, 0.05), bty = "n", |
41 | 176x |
lty = 1, col = c(2), |
42 | 176x |
legend = "original fit") |
43 |
} |
1 |
#' Calculated the log-likelihood of a fitted mkinfit object |
|
2 |
#' |
|
3 |
#' This function returns the product of the likelihood densities of each |
|
4 |
#' observed value, as calculated as part of the fitting procedure using |
|
5 |
#' \code{\link{dnorm}}, i.e. assuming normal distribution, and with the means |
|
6 |
#' predicted by the degradation model, and the standard deviations predicted by |
|
7 |
#' the error model. |
|
8 |
#' |
|
9 |
#' The total number of estimated parameters returned with the value of the |
|
10 |
#' likelihood is calculated as the sum of fitted degradation model parameters |
|
11 |
#' and the fitted error model parameters. |
|
12 |
#' |
|
13 |
#' @param object An object of class \code{\link{mkinfit}}. |
|
14 |
#' @param \dots For compatibility with the generic method |
|
15 |
#' @return An object of class \code{\link{logLik}} with the number of estimated |
|
16 |
#' parameters (degradation model parameters plus variance model parameters) |
|
17 |
#' as attribute. |
|
18 |
#' @author Johannes Ranke |
|
19 |
#' @seealso Compare the AIC of columns of \code{\link{mmkin}} objects using |
|
20 |
#' \code{\link{AIC.mmkin}}. |
|
21 |
#' @examples |
|
22 |
#' |
|
23 |
#' \dontrun{ |
|
24 |
#' sfo_sfo <- mkinmod( |
|
25 |
#' parent = mkinsub("SFO", to = "m1"), |
|
26 |
#' m1 = mkinsub("SFO") |
|
27 |
#' ) |
|
28 |
#' d_t <- subset(FOCUS_2006_D, value != 0) |
|
29 |
#' f_nw <- mkinfit(sfo_sfo, d_t, quiet = TRUE) # no weighting (weights are unity) |
|
30 |
#' f_obs <- update(f_nw, error_model = "obs") |
|
31 |
#' f_tc <- update(f_nw, error_model = "tc") |
|
32 |
#' AIC(f_nw, f_obs, f_tc) |
|
33 |
#' } |
|
34 |
#' |
|
35 |
#' @export |
|
36 |
logLik.mkinfit <- function(object, ...) { |
|
37 | 166798x |
val <- object$logLik |
38 |
# Number of estimated parameters |
|
39 | 166798x |
attr(val, "df") <- length(object$bparms.optim) + length(object$errparms) |
40 | 166798x |
attr(val, "nobs") <- nobs(object) |
41 | 166798x |
class(val) <- "logLik" |
42 | 166798x |
return(val) |
43 |
} |
1 |
#' Number of observations on which an mkinfit object was fitted |
|
2 |
#' |
|
3 |
#' @importFrom stats nobs |
|
4 |
#' @param object An mkinfit object |
|
5 |
#' @param \dots For compatibility with the generic method |
|
6 |
#' @return The number of rows in the data included in the mkinfit object |
|
7 |
#' @export |
|
8 | 166810x |
nobs.mkinfit <- function(object, ...) nrow(object$data) |
1 |
#' Two-component error model |
|
2 |
#' |
|
3 |
#' Function describing the standard deviation of the measurement error in |
|
4 |
#' dependence of the measured value \eqn{y}: |
|
5 |
#' |
|
6 |
#' \deqn{\sigma = \sqrt{ \sigma_{low}^2 + y^2 * {rsd}_{high}^2}} sigma = |
|
7 |
#' sqrt(sigma_low^2 + y^2 * rsd_high^2) |
|
8 |
#' |
|
9 |
#' This is the error model used for example by Werner et al. (1978). The model |
|
10 |
#' proposed by Rocke and Lorenzato (1995) can be written in this form as well, |
|
11 |
#' but assumes approximate lognormal distribution of errors for high values of |
|
12 |
#' y. |
|
13 |
#' |
|
14 |
#' @param y The magnitude of the observed value |
|
15 |
#' @param sigma_low The asymptotic minimum of the standard deviation for low |
|
16 |
#' observed values |
|
17 |
#' @param rsd_high The coefficient describing the increase of the standard |
|
18 |
#' deviation with the magnitude of the observed value |
|
19 |
#' @return The standard deviation of the response variable. |
|
20 |
#' @references Werner, Mario, Brooks, Samuel H., and Knott, Lancaster B. (1978) |
|
21 |
#' Additive, Multiplicative, and Mixed Analytical Errors. Clinical Chemistry |
|
22 |
#' 24(11), 1895-1898. |
|
23 |
#' |
|
24 |
#' Rocke, David M. and Lorenzato, Stefan (1995) A two-component model for |
|
25 |
#' measurement error in analytical chemistry. Technometrics 37(2), 176-184. |
|
26 |
#' |
|
27 |
#' Ranke J and Meinecke S (2019) Error Models for the Kinetic Evaluation of Chemical |
|
28 |
#' Degradation Data. *Environments* 6(12) 124 |
|
29 |
#' \doi{10.3390/environments6120124}. |
|
30 |
#' |
|
31 |
#' @examples |
|
32 |
#' times <- c(0, 1, 3, 7, 14, 28, 60, 90, 120) |
|
33 |
#' d_pred <- data.frame(time = times, parent = 100 * exp(- 0.03 * times)) |
|
34 |
#' set.seed(123456) |
|
35 |
#' d_syn <- add_err(d_pred, function(y) sigma_twocomp(y, 1, 0.07), |
|
36 |
#' reps = 2, n = 1)[[1]] |
|
37 |
#' f_nls <- nls(value ~ SSasymp(time, 0, parent_0, lrc), data = d_syn, |
|
38 |
#' start = list(parent_0 = 100, lrc = -3)) |
|
39 |
#' library(nlme) |
|
40 |
#' f_gnls <- gnls(value ~ SSasymp(time, 0, parent_0, lrc), |
|
41 |
#' data = d_syn, na.action = na.omit, |
|
42 |
#' start = list(parent_0 = 100, lrc = -3)) |
|
43 |
#' if (length(findFunction("varConstProp")) > 0) { |
|
44 |
#' f_gnls_tc <- update(f_gnls, weights = varConstProp()) |
|
45 |
#' f_gnls_tc_sf <- update(f_gnls_tc, control = list(sigma = 1)) |
|
46 |
#' } |
|
47 |
#' f_mkin <- mkinfit("SFO", d_syn, error_model = "const", quiet = TRUE) |
|
48 |
#' f_mkin_tc <- mkinfit("SFO", d_syn, error_model = "tc", quiet = TRUE) |
|
49 |
#' plot_res(f_mkin_tc, standardized = TRUE) |
|
50 |
#' AIC(f_nls, f_gnls, f_gnls_tc, f_gnls_tc_sf, f_mkin, f_mkin_tc) |
|
51 |
#' @export |
|
52 |
sigma_twocomp <- function(y, sigma_low, rsd_high) { |
|
53 | 4250x |
sqrt(sigma_low^2 + y^2 * rsd_high^2) |
54 |
} |
1 |
#' @rdname mkinmod |
|
2 |
#' @param submodel Character vector of length one to specify the submodel type. |
|
3 |
#' See \code{\link{mkinmod}} for the list of allowed submodel names. |
|
4 |
#' @param to Vector of the names of the state variable to which a |
|
5 |
#' transformation shall be included in the model. |
|
6 |
#' @param sink Should a pathway to sink be included in the model in addition to |
|
7 |
#' the pathways to other state variables? |
|
8 |
#' @param full_name An optional name to be used e.g. for plotting fits |
|
9 |
#' performed with the model. You can use non-ASCII characters here, but then |
|
10 |
#' your R code will not be portable, \emph{i.e.} may produce unintended plot |
|
11 |
#' results on other operating systems or system configurations. |
|
12 |
#' @return A list for use with \code{\link{mkinmod}}. |
|
13 |
#' @export |
|
14 |
mkinsub <- function(submodel, to = NULL, sink = TRUE, full_name = NA) |
|
15 |
{ |
|
16 | 9864x |
return(list(type = submodel, to = to, sink = sink, full_name = full_name)) |
17 |
} |