From b9be19af5e3085216d0cd5af439332f631fa8b92 Mon Sep 17 00:00:00 2001 From: Johannes Ranke Date: Mon, 15 Feb 2021 17:36:12 +0100 Subject: Fully rebuild docs, rerun tests and check --- vignettes/web_only/mkin_benchmarks.rda | Bin 1081 -> 1137 bytes 1 file changed, 0 insertions(+), 0 deletions(-) (limited to 'vignettes/web_only') diff --git a/vignettes/web_only/mkin_benchmarks.rda b/vignettes/web_only/mkin_benchmarks.rda index d2b82805..8c3369a2 100644 Binary files a/vignettes/web_only/mkin_benchmarks.rda and b/vignettes/web_only/mkin_benchmarks.rda differ -- cgit v1.2.3 From 40b78bed232798ecbeb72759cdf8d400ea35b31f Mon Sep 17 00:00:00 2001 From: Johannes Ranke Date: Fri, 23 Jul 2021 13:55:34 +0200 Subject: Some example evaluations of dimethenamid data Evaluations with nlme, saemix and nlmixr are included --- DESCRIPTION | 4 +- R/dimethenamid_2018.R | 33 +- R/mkinsub.R | 5 - vignettes/references.bib | 23 +- vignettes/web_only/.build.timestamp | 0 vignettes/web_only/dimethenamid_2018.R | 66 + vignettes/web_only/dimethenamid_2018.html | 1864 ++++++++++++++++++++ vignettes/web_only/dimethenamid_2018.rmd | 374 ++++ .../figure-html/f_parent_mkin_dfop_const-1.png | Bin 0 -> 60693 bytes .../f_parent_mkin_dfop_const_test-1.png | Bin 0 -> 60929 bytes .../figure-html/f_parent_mkin_dfop_tc_test-1.png | Bin 0 -> 62234 bytes .../figure-html/f_parent_mkin_sfo_const-1.png | Bin 0 -> 58445 bytes .../f_parent_nlmixr_saem_dfop_const-1.png | Bin 0 -> 92167 bytes .../figure-html/f_parent_nlmixr_saem_dfop_tc-1.png | Bin 0 -> 76934 bytes .../f_parent_nlmixr_saem_sfo_const-1.png | Bin 0 -> 62426 bytes .../figure-html/f_parent_nlmixr_saem_sfo_tc-1.png | Bin 0 -> 70230 bytes .../figure-html/f_parent_saemix_dfop_const-1.png | Bin 0 -> 41208 bytes .../f_parent_saemix_dfop_const_moreiter-1.png | Bin 0 -> 39456 bytes .../figure-html/f_parent_saemix_dfop_tc-1.png | Bin 0 -> 31646 bytes .../f_parent_saemix_dfop_tc_moreiter-1.png | Bin 0 -> 32077 bytes .../figure-html/f_parent_saemix_sfo_const-1.png | Bin 0 -> 35758 bytes .../figure-html/f_parent_saemix_sfo_tc-1.png | Bin 0 -> 30708 bytes .../f_parent_saemix_sfo_tc_moreiter-1.png | Bin 0 -> 30416 bytes .../figure-html/plot_parent_nlme-1.png | Bin 0 -> 60491 bytes 24 files changed, 2349 insertions(+), 20 deletions(-) create mode 100644 vignettes/web_only/.build.timestamp create mode 100644 vignettes/web_only/dimethenamid_2018.R create mode 100644 vignettes/web_only/dimethenamid_2018.html create mode 100644 vignettes/web_only/dimethenamid_2018.rmd create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const_moreiter-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc_moreiter-1.png create mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png (limited to 'vignettes/web_only') diff --git a/DESCRIPTION b/DESCRIPTION index c6151839..4689cb2a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: mkin Type: Package Title: Kinetic Evaluation of Chemical Degradation Data -Version: 1.0.5 -Date: 2021-06-11 +Version: 1.1.0 +Date: 2021-06-23 Authors@R: c( person("Johannes", "Ranke", role = c("aut", "cre", "cph"), email = "jranke@uni-bremen.de", diff --git a/R/dimethenamid_2018.R b/R/dimethenamid_2018.R index 6e0bda0c..770649e2 100644 --- a/R/dimethenamid_2018.R +++ b/R/dimethenamid_2018.R @@ -15,7 +15,7 @@ #' @source Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria (2018) #' Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour #' Rev. 2 - November 2017 -#' \url{http://registerofquestions.efsa.europa.eu/roqFrontend/outputLoader?output=ON-5211} +#' \url{https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716} #' @examples #' print(dimethenamid_2018) #' dmta_ds <- lapply(1:8, function(i) { @@ -43,15 +43,30 @@ #' list("DFOP-SFO3+" = dfop_sfo3_plus), #' dmta_ds, quiet = TRUE, error_model = "tc") #' nlmixr_model(f_dmta_mkin_tc) -#' f_dmta_nlmixr_focei <- nlmixr(f_dmta_mkin_tc, est = "focei", -#' control = nlmixr::foceiControl(print = 500)) +#' # The focei fit takes about four minutes on my system +#' system.time( +#' f_dmta_nlmixr_focei <- nlmixr(f_dmta_mkin_tc, est = "focei", +#' control = nlmixr::foceiControl(print = 500)) +#' ) #' summary(f_dmta_nlmixr_focei) #' plot(f_dmta_nlmixr_focei) -#' # saem has a problem with this model/data combination, maybe because of the -#' # overparameterised error model, to be investigated -#' #f_dmta_nlmixr_saem <- nlmixr(f_dmta_mkin_tc, est = "saem", -#' # control = saemControl(print = 500)) -#' #summary(f_dmta_nlmixr_saem) -#' #plot(f_dmta_nlmixr_saem) +#' # Using saemix takes about 18 minutes +#' system.time( +#' f_dmta_saemix <- saem(f_dmta_mkin_tc, test_log_parms = TRUE) +#' ) +#' +#' # nlmixr with est = "saem" is pretty fast with default iteration numbers, most +#' # of the time (about 2.5 minutes) is spent for calculating the log likelihood at the end +#' # The likelihood calculated for the nlmixr fit is much lower than that found by saemix +#' # Also, the trace plot and the plot of the individual predictions is not +#' # convincing for the parent. It seems we are fitting an overparameterised +#' # model, so the result we get strongly depends on starting parameters and control settings. +#' system.time( +#' f_dmta_nlmixr_saem <- nlmixr(f_dmta_mkin_tc, est = "saem", +#' control = nlmixr::saemControl(print = 500, logLik = TRUE, nmc = 9)) +#' ) +#' traceplot(f_dmta_nlmixr_saem$nm) +#' summary(f_dmta_nlmixr_saem) +#' plot(f_dmta_nlmixr_saem) #' } "dimethenamid_2018" diff --git a/R/mkinsub.R b/R/mkinsub.R index 886f712c..93af3f16 100644 --- a/R/mkinsub.R +++ b/R/mkinsub.R @@ -1,8 +1,3 @@ -#' Function to set up a kinetic submodel for one state variable -#' -#' This is a convenience function to set up the lists used as arguments for -#' \code{\link{mkinmod}}. -#' #' @rdname mkinmod #' @param submodel Character vector of length one to specify the submodel type. #' See \code{\link{mkinmod}} for the list of allowed submodel names. diff --git a/vignettes/references.bib b/vignettes/references.bib index 18b93fd3..f7eb4692 100644 --- a/vignettes/references.bib +++ b/vignettes/references.bib @@ -1,6 +1,3 @@ -% This file was originally created with JabRef 2.7b. -% Encoding: ISO8859_1 - @BOOK{bates1988, title = {Nonlinear regression and its applications}, publisher = {Wiley-Interscience}, @@ -97,7 +94,7 @@ @Techreport{ranke2014, title = {{Prüfung und Validierung von Modellierungssoftware als Alternative zu ModelMaker 4.0}}, - author = {J. Ranke}, + author = {J. Ranke}, year = 2014, institution = {Umweltbundesamt}, volume = {Projektnummer 27452} @@ -146,3 +143,21 @@ Volume = {45}, Type = {Journal} } + + +@article{efsa_2018_dimethenamid, + author = {EFSA}, + issue = {4}, + journal = {EFSA Journal}, + pages = {5211}, + title = {Peer review of the pesticide risk assessment of the active substance dimethenamid-P}, + volume = {16}, + year = {2018} +} + +@techreport{dimethenamid_rar_2018_b8, + author = {{Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria}}, + year = {2018}, + title = {{Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour, Rev. 2 - November 2017}}, + url = {https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716} +} diff --git a/vignettes/web_only/.build.timestamp b/vignettes/web_only/.build.timestamp new file mode 100644 index 00000000..e69de29b diff --git a/vignettes/web_only/dimethenamid_2018.R b/vignettes/web_only/dimethenamid_2018.R new file mode 100644 index 00000000..625cceb8 --- /dev/null +++ b/vignettes/web_only/dimethenamid_2018.R @@ -0,0 +1,66 @@ +## ---- include = FALSE--------------------------------------------------------- +require(knitr) +options(digits = 5) +opts_chunk$set( + comment = "", + tidy = FALSE, + cache = TRUE +) + +## ----dimethenamid_data-------------------------------------------------------- +library(mkin) +dmta_ds <- lapply(1:8, function(i) { + ds_i <- dimethenamid_2018$ds[[i]]$data + ds_i[ds_i$name == "DMTAP", "name"] <- "DMTA" + ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i] + ds_i +}) +names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title) +dmta_ds[["Borstel"]] <- rbind(dmta_ds[["Borstel 1"]], dmta_ds[["Borstel 2"]]) +dmta_ds[["Borstel 1"]] <- NULL +dmta_ds[["Borstel 2"]] <- NULL +dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]]) +dmta_ds[["Elliot 1"]] <- NULL +dmta_ds[["Elliot 2"]] <- NULL + +## ----f_parent_mkin------------------------------------------------------------ +f_parent_mkin_const <- mmkin(c("SFO", "DFOP"), dmta_ds, + error_model = "const", quiet = TRUE) +f_parent_mkin_tc <- mmkin(c("SFO", "DFOP"), dmta_ds, + error_model = "tc", quiet = TRUE) + +## ----f_parent_mkin_sfo_const-------------------------------------------------- +plot(mixed(f_parent_mkin_const["SFO", ])) + +## ----f_parent_mkin_dfop_const------------------------------------------------- +plot(mixed(f_parent_mkin_const["DFOP", ])) + +## ----f_parent_mkin_dfop_const_test-------------------------------------------- +plot(mixed(f_parent_mkin_const["DFOP", ]), test_log_parms = TRUE) + +## ----f_parent_mkin_dfop_tc_test----------------------------------------------- +plot(mixed(f_parent_mkin_tc["DFOP", ]), test_log_parms = TRUE) + +## ----f_parent_nlme, warning = FALSE------------------------------------------- +f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ]) +#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ]) # error +f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ]) +f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ]) + +## ----f_parent_nlme_logchol, warning = FALSE, eval = FALSE--------------------- +# f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ], +# random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1))) +# anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better +# f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc, +# random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1))) +# # using log Cholesky parameterisation for random effects (nlme default) does +# # not converge and gives lots of warnings about the LME step not converging + +## ----AIC_parent_nlme---------------------------------------------------------- +anova( + f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc +) + +## ----plot_parent_nlme--------------------------------------------------------- +plot(f_parent_nlme_dfop_tc) + diff --git a/vignettes/web_only/dimethenamid_2018.html b/vignettes/web_only/dimethenamid_2018.html new file mode 100644 index 00000000..e84a435c --- /dev/null +++ b/vignettes/web_only/dimethenamid_2018.html @@ -0,0 +1,1864 @@ + + + + + + + + + + + + + + +Example evaluations of the dimethenamid data from 2018 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + +
+
+
+
+
+ +
+ + + + + + + +

Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany
Privatdozent at the University of Bremen

+
+

Introduction

+

During the preparation of the journal article on nonlinear mixed-effects models in degradation kinetics (submitted) and the analysis of the dimethenamid degradation data analysed therein, a need for a more detailed analysis using not only nlme and saemix, but also nlmixr for fitting the mixed-effects models was identified.

+

This vignette is an attempt to satisfy this need.

+
+
+

Data

+

Residue data forming the basis for the endpoints derived in the conclusion on the peer review of the pesticide risk assessment of dimethenamid-P published by the European Food Safety Authority (EFSA) in 2018 (EFSA 2018) were transcribed from the risk assessment report (Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria 2018) which can be downloaded from the EFSA register of questions.

+

The data are available in the mkin package. The following code (hidden by default, please use the button to the right to show it) treats the data available for the racemic mixture dimethenamid (DMTA) and its enantiomer dimethenamid-P (DMTAP) in the same way, as no difference between their degradation behaviour was identified in the EU risk assessment. The observation times of each dataset are multiplied with the corresponding normalisation factor also available in the dataset, in order to make it possible to describe all datasets with a single set of parameters.

+

Also, datasets observed in the same soil are merged, resulting in dimethenamid (DMTA) data from six soils.

+
library(mkin)
+dmta_ds <- lapply(1:8, function(i) {
+  ds_i <- dimethenamid_2018$ds[[i]]$data
+  ds_i[ds_i$name == "DMTAP", "name"] <-  "DMTA"
+  ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i]
+  ds_i
+})
+names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title)
+dmta_ds[["Borstel"]] <- rbind(dmta_ds[["Borstel 1"]], dmta_ds[["Borstel 2"]])
+dmta_ds[["Borstel 1"]] <- NULL
+dmta_ds[["Borstel 2"]] <- NULL
+dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]])
+dmta_ds[["Elliot 1"]] <- NULL
+dmta_ds[["Elliot 2"]] <- NULL
+
+
+

Parent degradation

+

We evaluate the observed degradation of the parent compound using simple exponential decline (SFO) and biexponential decline (DFOP), using constant variance (const) and a two-component variance (tc) as error models.

+
+

Separate evaluations

+

As a first step, to get a visual impression of the fit of the different models, we do separate evaluations for each soil using the mmkin function from the mkin package:

+
f_parent_mkin_const <- mmkin(c("SFO", "DFOP"), dmta_ds,
+  error_model = "const", quiet = TRUE)
+f_parent_mkin_tc <- mmkin(c("SFO", "DFOP"), dmta_ds,
+  error_model = "tc", quiet = TRUE)
+

The plot of the individual SFO fits shown below suggests that at least in some datasets the degradation slows down towards later time points, and that the scatter of the residuals error is smaller for smaller values (panel to the right):

+
plot(mixed(f_parent_mkin_const["SFO", ]))
+

+

Using biexponential decline (DFOP) results in a slightly more random scatter of the residuals:

+
plot(mixed(f_parent_mkin_const["DFOP", ]))
+

+

The population curve (bold line) in the above plot results from taking the mean of the individual transformed parameters, i.e. of log k1 and log k2, as well as of the logit of the g parameter of the DFOP model). Here, this procedure does not result in parameters that represent the degradation well, because in some datasets the fitted value for k2 is extremely close to zero, leading to a log k2 value that dominates the average. This is alleviated if only rate constants that pass the t-test for significant difference from zero (on the untransformed scale) are considered in the averaging:

+
plot(mixed(f_parent_mkin_const["DFOP", ]), test_log_parms = TRUE)
+

+

While this is visually much more satisfactory, such an average procedure could introduce a bias, as not all results from the individual fits enter the population curve with the same weight. This is where nonlinear mixed-effects models can help out by treating all datasets with equally by fitting a parameter distribution model together with the degradation model and the error model (see below).

+

The remaining trend of the residuals to be higher for higher predicted residues is reduced by using the two-component error model:

+
plot(mixed(f_parent_mkin_tc["DFOP", ]), test_log_parms = TRUE)
+

+
+
+

Nonlinear mixed-effects models

+

Instead of taking a model selection decision for each of the individual fits, we fit nonlinear mixed-effects models (using different fitting algorithms as implemented in different packages) and do model selection using all available data at the same time. In order to make sure that these decisions are not unduly influenced by the type of algorithm used, by implementation details or by the use of wrong control parameters, we compare the model selection results obtained with different R packages, with different algorithms and checking control parameters.

+
+

nlme

+

The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We use would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.

+
f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ])
+#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ]) # error
+f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ])
+f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ])
+

Note that overparameterisation is also indicated by warnings obtained when fitting SFO or DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in some iterations). In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.

+
f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ],
+  random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1)))
+anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better
+f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc,
+  random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))
+# using log Cholesky parameterisation for random effects (nlme default) does
+# not converge and gives lots of warnings about the LME step not converging
+

The model comparison function of the nlme package can directly be applied to these fits showing a similar goodness-of-fit of the SFO model, but a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.

+
anova(
+  f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
+)
+
                        Model df    AIC    BIC  logLik   Test L.Ratio p-value
+f_parent_nlme_sfo_const     1  5 818.63 834.00 -404.31                       
+f_parent_nlme_sfo_tc        2  6 820.61 839.06 -404.31 1 vs 2   0.014  0.9049
+f_parent_nlme_dfop_tc       3 10 687.84 718.59 -333.92 2 vs 3 140.771  <.0001
+

The selected model (DFOP with two-component error) fitted to the data assuming no correlations between random effects is shown below.

+
plot(f_parent_nlme_dfop_tc)
+

+
+
+

saemix

+

The saemix package provided the first Open Source implementation of the Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. SAEM fits of degradation models can be performed using an interface to the saemix package available in current development versions of the mkin package.

+

The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit.

+

The convergence plot for the SFO model using constant variance is shown below.

+
library(saemix)
+f_parent_saemix_sfo_const <- saem(f_parent_mkin_const["SFO", ], quiet = TRUE,
+  transformations = "saemix")
+plot(f_parent_saemix_sfo_const$so, plot.type = "convergence")
+

+

Obviously the default number of iterations is sufficient to reach convergence. This can also be said for the SFO fit using the two-component error model.

+
f_parent_saemix_sfo_tc <- saem(f_parent_mkin_tc["SFO", ], quiet = TRUE,
+  transformations = "saemix")
+plot(f_parent_saemix_sfo_tc$so, plot.type = "convergence")
+

+

When fitting the DFOP model with constant variance, parameter convergence is not as unambiguous. Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence.

+
f_parent_saemix_dfop_const <- saem(f_parent_mkin_const["DFOP", ], quiet = TRUE,
+  control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
+    save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
+  transformations = "saemix")
+plot(f_parent_saemix_dfop_const$so, plot.type = "convergence")
+

+

The same applies to the case where the DFOP model is fitted with the two-component error model.

+
f_parent_saemix_dfop_tc_moreiter <- saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE,
+  control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
+    save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
+  transformations = "saemix")
+plot(f_parent_saemix_dfop_tc_moreiter$so, plot.type = "convergence")
+

+

The four combinations can be compared using the model comparison function from the saemix package:

+
compare.saemix(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
+  f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc$so)
+
Likelihoods calculated by importance sampling
+
     AIC    BIC
+1 818.37 817.33
+2 820.38 819.14
+3 725.91 724.04
+4 688.09 686.01
+

As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. The numeric values are reasonably close to the ones obtained using nlme, considering that the algorithms for fitting the model and for the likelihood calculation are quite different.

+
+
+

nlmixr

+

In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.

+

First, the focei algorithm is used for the four model combinations and the goodness of fit of the results is compared.

+
f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei")
+f_parent_nlmixr_focei_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "focei")
+f_parent_nlmixr_focei_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "focei")
+f_parent_nlmixr_focei_dfop_tc<- nlmixr(f_parent_mkin_tc["DFOP", ], est = "focei")
+
AIC(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
+  f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm)
+
                                    df    AIC
+f_parent_nlmixr_focei_sfo_const$nm   5 818.63
+f_parent_nlmixr_focei_sfo_tc$nm      6 820.61
+f_parent_nlmixr_focei_dfop_const$nm  9 728.11
+f_parent_nlmixr_focei_dfop_tc$nm    10 687.82
+

The AIC values are very close to the ones obtained with nlme.

+

Secondly, we use the SAEM estimation routine and check the convergence plots for SFO with constant variance

+
f_parent_nlmixr_saem_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE))
+traceplot(f_parent_nlmixr_saem_sfo_const$nm)
+

+

for SFO with two-component error

+
f_parent_nlmixr_saem_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE))
+nlmixr::traceplot(f_parent_nlmixr_saem_sfo_tc$nm)
+

+

For DFOP with constant variance, the convergence plots show considerable instability of the fit, which can be alleviated by increasing the number of iterations and the number of parallel chains for the first phase of algorithm.

+
f_parent_nlmixr_saem_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000), nmc = 15)
+nlmixr::traceplot(f_parent_nlmixr_saem_dfop_const$nm)
+

+

For DFOP with two-component error, the same increase in iterations and parallel chains was used, but using the two-component error appears to lead to a less erratic convergence, so this may not be necessary to this degree.

+
f_parent_nlmixr_saem_dfop_tc <- nlmixr(f_parent_mkin_tc["DFOP", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000, nmc = 15))
+nlmixr::traceplot(f_parent_nlmixr_saem_dfop_tc$nm)
+

+

The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using the two-component error model is given as Infinity.

+
AIC(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
+  f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm)
+
                                   df    AIC
+f_parent_nlmixr_saem_sfo_const$nm   5 820.54
+f_parent_nlmixr_saem_sfo_tc$nm      6 835.26
+f_parent_nlmixr_saem_dfop_const$nm  9 850.72
+f_parent_nlmixr_saem_dfop_tc$nm    10    Inf
+
+
+
+
+

References

+ +
+
+

EFSA. 2018. “Peer Review of the Pesticide Risk Assessment of the Active Substance Dimethenamid-P.” EFSA Journal 16 (4): 5211.

+
+
+

Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria. 2018. “Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour, Rev. 2 - November 2017.” https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716.

+
+
+
+ + + +
+
+ +
+ + + + + + + + + + + + + + + + + diff --git a/vignettes/web_only/dimethenamid_2018.rmd b/vignettes/web_only/dimethenamid_2018.rmd new file mode 100644 index 00000000..d3541a34 --- /dev/null +++ b/vignettes/web_only/dimethenamid_2018.rmd @@ -0,0 +1,374 @@ +--- +title: Example evaluations of the dimethenamid data from 2018 +author: Johannes Ranke +date: Last change 23 June 2021, built on `r format(Sys.Date(), format = "%d %b %Y")` +output: + html_document: + toc: true + toc_float: true + code_folding: hide + fig_retina: null +bibliography: ../references.bib +vignette: > + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +[Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany](http://www.jrwb.de)
+[Privatdozent at the University of Bremen](http://chem.uft.uni-bremen.de/ranke) + +```{r, include = FALSE} +require(knitr) +options(digits = 5) +opts_chunk$set( + comment = "", + tidy = FALSE, + cache = TRUE +) +``` + +# Introduction + +During the preparation of the journal article on nonlinear mixed-effects models in +degradation kinetics (submitted) and the analysis of the dimethenamid degradation +data analysed therein, a need for a more detailed analysis using not only nlme and saemix, +but also nlmixr for fitting the mixed-effects models was identified. + +This vignette is an attempt to satisfy this need. + +# Data + +Residue data forming the basis for the endpoints derived in the conclusion on +the peer review of the pesticide risk assessment of dimethenamid-P published by +the European Food Safety Authority (EFSA) in 2018 [@efsa_2018_dimethenamid] +were transcribed from the risk assessment report [@dimethenamid_rar_2018_b8] +which can be downloaded from the +[EFSA register of questions](https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716). + +The data are [available in the mkin +package](https://pkgdown.jrwb.de/mkin/reference/dimethenamid_2018.html). The +following code (hidden by default, please use the button to the right to show +it) treats the data available for the racemic mixture dimethenamid (DMTA) and +its enantiomer dimethenamid-P (DMTAP) in the same way, as no difference between +their degradation behaviour was identified in the EU risk assessment. The +observation times of each dataset are multiplied with the corresponding +normalisation factor also available in the dataset, in order to make it +possible to describe all datasets with a single set of parameters. + +Also, datasets observed in the same soil are merged, resulting in dimethenamid +(DMTA) data from six soils. + +```{r dimethenamid_data} +library(mkin) +dmta_ds <- lapply(1:8, function(i) { + ds_i <- dimethenamid_2018$ds[[i]]$data + ds_i[ds_i$name == "DMTAP", "name"] <- "DMTA" + ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i] + ds_i +}) +names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title) +dmta_ds[["Borstel"]] <- rbind(dmta_ds[["Borstel 1"]], dmta_ds[["Borstel 2"]]) +dmta_ds[["Borstel 1"]] <- NULL +dmta_ds[["Borstel 2"]] <- NULL +dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]]) +dmta_ds[["Elliot 1"]] <- NULL +dmta_ds[["Elliot 2"]] <- NULL +``` + +# Parent degradation + +We evaluate the observed degradation of the parent compound using simple +exponential decline (SFO) and biexponential decline (DFOP), using constant +variance (const) and a two-component variance (tc) as error models. + +## Separate evaluations + +As a first step, to get a visual impression of the fit of the different models, +we do separate evaluations for each soil using the mmkin function from the +mkin package: + +```{r f_parent_mkin} +f_parent_mkin_const <- mmkin(c("SFO", "DFOP"), dmta_ds, + error_model = "const", quiet = TRUE) +f_parent_mkin_tc <- mmkin(c("SFO", "DFOP"), dmta_ds, + error_model = "tc", quiet = TRUE) +``` + +The plot of the individual SFO fits shown below suggests that at least in some +datasets the degradation slows down towards later time points, and that the +scatter of the residuals error is smaller for smaller values (panel to the +right): + +```{r f_parent_mkin_sfo_const} +plot(mixed(f_parent_mkin_const["SFO", ])) +``` + +Using biexponential decline (DFOP) results in a slightly more random +scatter of the residuals: + +```{r f_parent_mkin_dfop_const} +plot(mixed(f_parent_mkin_const["DFOP", ])) +``` + +The population curve (bold line) in the above plot results from taking the mean +of the individual transformed parameters, i.e. of log k1 and log k2, as well as +of the logit of the g parameter of the DFOP model). Here, this procedure +does not result in parameters that represent the degradation well, because in some +datasets the fitted value for k2 is extremely close to zero, leading to a log +k2 value that dominates the average. This is alleviated if only rate constants +that pass the t-test for significant difference from zero (on the untransformed +scale) are considered in the averaging: + +```{r f_parent_mkin_dfop_const_test} +plot(mixed(f_parent_mkin_const["DFOP", ]), test_log_parms = TRUE) +``` + +While this is visually much more satisfactory, such an average procedure could +introduce a bias, as not all results from the individual fits enter the +population curve with the same weight. This is where nonlinear mixed-effects +models can help out by treating all datasets with equally by fitting a +parameter distribution model together with the degradation model and the error +model (see below). + +The remaining trend of the residuals to be higher for higher predicted residues +is reduced by using the two-component error model: + +```{r f_parent_mkin_dfop_tc_test} +plot(mixed(f_parent_mkin_tc["DFOP", ]), test_log_parms = TRUE) +``` + +## Nonlinear mixed-effects models + +Instead of taking a model selection decision for each of the individual fits, we fit +nonlinear mixed-effects models (using different fitting algorithms as implemented in +different packages) and do model selection using all available data at the same time. +In order to make sure that these decisions are not unduly influenced by the +type of algorithm used, by implementation details or by the use of wrong control +parameters, we compare the model selection results obtained with different R +packages, with different algorithms and checking control parameters. + +### nlme + +The nlme package was the first R extension providing facilities to fit nonlinear +mixed-effects models. We use would like to do model selection from all four +combinations of degradation models and error models based on the AIC. +However, fitting the DFOP model with constant variance and using default +control parameters results in an error, signalling that the maximum number +of 50 iterations was reached, potentially indicating overparameterisation. +However, the algorithm converges when the two-component error model is +used in combination with the DFOP model. This can be explained by the fact +that the smaller residues observed at later sampling times get more +weight when using the two-component error model which will counteract the +tendency of the algorithm to try parameter combinations unsuitable for +fitting these data. + +```{r f_parent_nlme, warning = FALSE} +f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ]) +#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ]) # error +f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ]) +f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ]) +``` + +Note that overparameterisation is also indicated by warnings obtained when +fitting SFO or DFOP with the two-component error model ('false convergence' in +the 'LME step' in some iterations). In addition to these fits, attempts +were also made to include correlations between random effects by using the +log Cholesky parameterisation of the matrix specifying them. The code +used for these attempts can be made visible below. + +```{r f_parent_nlme_logchol, warning = FALSE, eval = FALSE} +f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ], + random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1))) +anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better +f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc, + random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1))) +# using log Cholesky parameterisation for random effects (nlme default) does +# not converge and gives lots of warnings about the LME step not converging +``` + +The model comparison function of the nlme package can directly be applied +to these fits showing a similar goodness-of-fit of the SFO model, but a much +lower AIC for the DFOP model fitted with the two-component error model. +Also, the likelihood ratio test indicates that this difference is significant. +as the p-value is below 0.0001. + +```{r AIC_parent_nlme} +anova( + f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc +) +``` + +The selected model (DFOP with two-component error) fitted to the data assuming +no correlations between random effects is shown below. + +```{r plot_parent_nlme} +plot(f_parent_nlme_dfop_tc) +``` + +### saemix + +The saemix package provided the first Open Source implementation of the +Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. +SAEM fits of degradation models can be performed using an interface to the +saemix package available in current development versions of the mkin package. + +The corresponding SAEM fits of the four combinations of degradation and error +models are fitted below. As there is no convergence criterion implemented in +the saemix package, the convergence plots need to be manually checked for every +fit. + +The convergence plot for the SFO model using constant variance is shown below. + +```{r f_parent_saemix_sfo_const, results = 'hide'} +library(saemix) +f_parent_saemix_sfo_const <- saem(f_parent_mkin_const["SFO", ], quiet = TRUE, + transformations = "saemix") +plot(f_parent_saemix_sfo_const$so, plot.type = "convergence") +``` + +Obviously the default number of iterations is sufficient to reach convergence. +This can also be said for the SFO fit using the two-component error model. + +```{r f_parent_saemix_sfo_tc, results = 'hide'} +f_parent_saemix_sfo_tc <- saem(f_parent_mkin_tc["SFO", ], quiet = TRUE, + transformations = "saemix") +plot(f_parent_saemix_sfo_tc$so, plot.type = "convergence") +``` + +When fitting the DFOP model with constant variance, parameter convergence +is not as unambiguous. Therefore, the number of iterations in the first +phase of the algorithm was increased, leading to visually satisfying +convergence. + +```{r f_parent_saemix_dfop_const, results = 'hide'} +f_parent_saemix_dfop_const <- saem(f_parent_mkin_const["DFOP", ], quiet = TRUE, + control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE, + save = FALSE, save.graphs = FALSE, displayProgress = FALSE), + transformations = "saemix") +plot(f_parent_saemix_dfop_const$so, plot.type = "convergence") +``` + +The same applies to the case where the DFOP model is fitted with the +two-component error model. Convergence of the variance of k2 is enhanced +by using the two-component error, it remains pretty stable already after 200 +iterations of the first phase. + +```{r f_parent_saemix_dfop_tc_moreiter, results = 'hide'} +f_parent_saemix_dfop_tc_moreiter <- saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE, + control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE, + save = FALSE, save.graphs = FALSE, displayProgress = FALSE), + transformations = "saemix") +plot(f_parent_saemix_dfop_tc_moreiter$so, plot.type = "convergence") +``` + +The four combinations can be compared using the model comparison function from the +saemix package: + +```{r AIC_parent_saemix} +compare.saemix(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so, + f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so) +``` + +As in the case of nlme fits, the DFOP model fitted with two-component error +(number 4) gives the lowest AIC. The numeric values are reasonably close to +the ones obtained using nlme, considering that the algorithms for fitting the +model and for the likelihood calculation are quite different. + +In order to check the influence of the likelihood calculation algorithms +implemented in saemix, the likelihood from Gaussian quadrature is added +to the best fit, and the AIC values obtained from the three methods +are compared. + +```{r AIC_parent_saemix_methods} +f_parent_saemix_dfop_tc_moreiter$so <- + llgq.saemix(f_parent_saemix_dfop_tc_moreiter$so) +AIC(f_parent_saemix_dfop_tc_moreiter$so) +AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "gq") +AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "lin") +``` + +The AIC values based on importance sampling and Gaussian quadrature are quite +similar. Using linearisation is less accurate, but still gives a similar value. + + +### nlmixr + +In the last years, a lot of effort has been put into the nlmixr package which +is designed for pharmacokinetics, where nonlinear mixed-effects models are +routinely used, but which can also be used for related data like chemical +degradation data. A current development branch of the mkin package provides +an interface between mkin and nlmixr. Here, we check if we get equivalent +results when using a refined version of the First Order Conditional Estimation +(FOCE) algorithm used in nlme, namely First Order Conditional Estimation with +Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr. + +First, the focei algorithm is used for the four model combinations and the +goodness of fit of the results is compared. + +```{r f_parent_nlmixr_focei, results = "hide", message = FALSE, warning = FALSE} +f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei") +f_parent_nlmixr_focei_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "focei") +f_parent_nlmixr_focei_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "focei") +f_parent_nlmixr_focei_dfop_tc<- nlmixr(f_parent_mkin_tc["DFOP", ], est = "focei") +``` + +```{r AIC_parent_nlmixr_focei} +AIC(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm, + f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm) +``` + +The AIC values are very close to the ones obtained with nlme. + +Secondly, we use the SAEM estimation routine and check the convergence plots for +SFO with constant variance + +```{r f_parent_nlmixr_saem_sfo_const, results = "hide", warning = FALSE, message = FALSE} +f_parent_nlmixr_saem_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "saem", + control = nlmixr::saemControl(logLik = TRUE)) +traceplot(f_parent_nlmixr_saem_sfo_const$nm) +``` + +for SFO with two-component error + +```{r f_parent_nlmixr_saem_sfo_tc, results = "hide", warning = FALSE, message = FALSE} +f_parent_nlmixr_saem_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "saem", + control = nlmixr::saemControl(logLik = TRUE)) +nlmixr::traceplot(f_parent_nlmixr_saem_sfo_tc$nm) +``` + +For DFOP with constant variance, the convergence plots show considerable instability +of the fit, which can be alleviated by increasing the number of iterations and +the number of parallel chains for the first phase of algorithm. + +```{r f_parent_nlmixr_saem_dfop_const, results = "hide", warning = FALSE, message = FALSE} +f_parent_nlmixr_saem_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "saem", + control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000), nmc = 15) +nlmixr::traceplot(f_parent_nlmixr_saem_dfop_const$nm) +``` + +For DFOP with two-component error, the same increase in iterations and parallel +chains was used, but using the two-component error appears to lead to a less +erratic convergence, so this may not be necessary to this degree. + + +```{r f_parent_nlmixr_saem_dfop_tc, results = "hide", warning = FALSE, message = FALSE} +f_parent_nlmixr_saem_dfop_tc <- nlmixr(f_parent_mkin_tc["DFOP", ], est = "saem", + control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000, nmc = 15)) +nlmixr::traceplot(f_parent_nlmixr_saem_dfop_tc$nm) +``` + +The AIC values are internally calculated using Gaussian quadrature. For an +unknown reason, the AIC value obtained for the DFOP fit using the two-component +error model is given as Infinity. + +```{r AIC_parent_nlmixr_saem} +AIC(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm, + f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm) +``` + + + + +# References + + diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png new file mode 100644 index 00000000..de699f30 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png new file mode 100644 index 00000000..5f752168 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png new file mode 100644 index 00000000..0265c22f Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png new file mode 100644 index 00000000..9bbb57c7 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png new file mode 100644 index 00000000..043a1fca Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png new file mode 100644 index 00000000..7d2aea59 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png new file mode 100644 index 00000000..032d6043 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png new file mode 100644 index 00000000..a602715c Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png new file mode 100644 index 00000000..621d34f2 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const_moreiter-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const_moreiter-1.png new file mode 100644 index 00000000..e127b354 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const_moreiter-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png new file mode 100644 index 00000000..ecc6ccf3 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png new file mode 100644 index 00000000..1337ea8f Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png new file mode 100644 index 00000000..492a7888 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png new file mode 100644 index 00000000..5e3b9c13 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc_moreiter-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc_moreiter-1.png new file mode 100644 index 00000000..3ca2804d Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc_moreiter-1.png differ diff --git a/vignettes/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png b/vignettes/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png new file mode 100644 index 00000000..a48f41b2 Binary files /dev/null and b/vignettes/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png differ -- cgit v1.2.3 From 0b754ffa91b9496bdd2f892cf3ca2bd887028dea Mon Sep 17 00:00:00 2001 From: Johannes Ranke Date: Tue, 27 Jul 2021 18:22:01 +0200 Subject: Fix dimethenamid vignette problems and update docs --- docs/dev/404.html | 2 +- docs/dev/articles/index.html | 4 +- docs/dev/articles/web_only/dimethenamid_2018.html | 420 +++++++++++ .../accessible-code-block-0.0.1/empty-anchor.js | 15 + .../figure-html/f_parent_mkin_dfop_const-1.png | Bin 0 -> 145534 bytes .../f_parent_mkin_dfop_const_test-1.png | Bin 0 -> 146181 bytes .../figure-html/f_parent_mkin_dfop_tc_test-1.png | Bin 0 -> 150274 bytes .../figure-html/f_parent_mkin_sfo_const-1.png | Bin 0 -> 141499 bytes .../f_parent_nlmixr_saem_dfop_const-1.png | Bin 0 -> 180061 bytes .../figure-html/f_parent_nlmixr_saem_dfop_tc-1.png | Bin 0 -> 151832 bytes .../f_parent_nlmixr_saem_sfo_const-1.png | Bin 0 -> 124946 bytes .../figure-html/f_parent_nlmixr_saem_sfo_tc-1.png | Bin 0 -> 140491 bytes .../figure-html/f_parent_saemix_dfop_const-1.png | Bin 0 -> 58759 bytes .../f_parent_saemix_dfop_tc_moreiter-1.png | Bin 0 -> 45420 bytes .../figure-html/f_parent_saemix_sfo_const-1.png | Bin 0 -> 59913 bytes .../figure-html/f_parent_saemix_sfo_tc-1.png | Bin 0 -> 53550 bytes .../figure-html/plot_parent_nlme-1.png | Bin 0 -> 147409 bytes .../header-attrs-2.9/header-attrs.js | 12 + docs/dev/authors.html | 2 +- docs/dev/index.html | 2 +- docs/dev/news/index.html | 2 +- docs/dev/pkgdown.yml | 3 +- docs/dev/reference/Rplot005.png | Bin 59049 -> 59600 bytes docs/dev/reference/dimethenamid_2018-2.png | Bin 0 -> 245108 bytes docs/dev/reference/dimethenamid_2018.html | 217 +++++- docs/dev/reference/endpoints.html | 2 +- docs/dev/reference/index.html | 2 +- docs/dev/reference/mean_degparms.html | 2 +- docs/dev/reference/mkinmod.html | 12 +- docs/dev/reference/nlme-1.png | Bin 68943 -> 69667 bytes docs/dev/reference/nlme-2.png | Bin 94409 -> 93394 bytes docs/dev/reference/nlme.html | 18 +- docs/dev/reference/nlme.mmkin.html | 9 +- docs/dev/reference/nlmixr.mmkin.html | 28 +- docs/dev/reference/plot.mixed.mmkin-3.png | Bin 173260 -> 173794 bytes docs/dev/reference/plot.mixed.mmkin-4.png | Bin 176346 -> 176972 bytes docs/dev/reference/plot.mixed.mmkin.html | 6 +- docs/dev/reference/reexports.html | 2 +- docs/dev/reference/saem-5.png | Bin 174406 -> 174405 bytes docs/dev/reference/saem.html | 480 ++++++------- docs/dev/reference/summary.nlmixr.mmkin.html | 792 ++------------------- docs/dev/reference/tffm0.html | 2 +- docs/dev/sitemap.xml | 3 + vignettes/web_only/dimethenamid_2018.html | 109 ++- vignettes/web_only/dimethenamid_2018.rmd | 57 +- 45 files changed, 1131 insertions(+), 1072 deletions(-) create mode 100644 docs/dev/articles/web_only/dimethenamid_2018.html create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/accessible-code-block-0.0.1/empty-anchor.js create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.9/header-attrs.js create mode 100644 docs/dev/reference/dimethenamid_2018-2.png (limited to 'vignettes/web_only') diff --git a/docs/dev/404.html b/docs/dev/404.html index 98c0b1e0..38898979 100644 --- a/docs/dev/404.html +++ b/docs/dev/404.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/articles/index.html b/docs/dev/articles/index.html index 3896120a..c0338df8 100644 --- a/docs/dev/articles/index.html +++ b/docs/dev/articles/index.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 @@ -161,6 +161,8 @@
Performance benefit by using compiled model definitions in mkin
+
Example evaluations of the dimethenamid data from 2018
+
diff --git a/docs/dev/articles/web_only/dimethenamid_2018.html b/docs/dev/articles/web_only/dimethenamid_2018.html new file mode 100644 index 00000000..7648f75a --- /dev/null +++ b/docs/dev/articles/web_only/dimethenamid_2018.html @@ -0,0 +1,420 @@ + + + + + + + +Example evaluations of the dimethenamid data from 2018 • mkin + + + + + + + + + + + +
+
+ + + + +
+
+
+

Example evaluations of the dimethenamid data from 2018

+

Johannes Ranke

+ +

Last change 27 July 2021, built on 27 Jul 2021

+ + Source: vignettes/web_only/dimethenamid_2018.rmd + + +
+ + + +

Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany
Privatdozent at the University of Bremen

+
+

+Introduction

+

During the preparation of the journal article on nonlinear mixed-effects models in degradation kinetics (submitted) and the analysis of the dimethenamid degradation data analysed therein, a need for a more detailed analysis using not only nlme and saemix, but also nlmixr for fitting the mixed-effects models was identified.

+

This vignette is an attempt to satisfy this need.

+
+
+

+Data

+

Residue data forming the basis for the endpoints derived in the conclusion on the peer review of the pesticide risk assessment of dimethenamid-P published by the European Food Safety Authority (EFSA) in 2018 (EFSA 2018) were transcribed from the risk assessment report (Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria 2018) which can be downloaded from the EFSA register of questions.

+

The data are available in the mkin package. The following code (hidden by default, please use the button to the right to show it) treats the data available for the racemic mixture dimethenamid (DMTA) and its enantiomer dimethenamid-P (DMTAP) in the same way, as no difference between their degradation behaviour was identified in the EU risk assessment. The observation times of each dataset are multiplied with the corresponding normalisation factor also available in the dataset, in order to make it possible to describe all datasets with a single set of parameters.

+

Also, datasets observed in the same soil are merged, resulting in dimethenamid (DMTA) data from six soils.

+
+library(mkin)
+dmta_ds <- lapply(1:8, function(i) {
+  ds_i <- dimethenamid_2018$ds[[i]]$data
+  ds_i[ds_i$name == "DMTAP", "name"] <-  "DMTA"
+  ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i]
+  ds_i
+})
+names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title)
+dmta_ds[["Borstel"]] <- rbind(dmta_ds[["Borstel 1"]], dmta_ds[["Borstel 2"]])
+dmta_ds[["Borstel 1"]] <- NULL
+dmta_ds[["Borstel 2"]] <- NULL
+dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]])
+dmta_ds[["Elliot 1"]] <- NULL
+dmta_ds[["Elliot 2"]] <- NULL
+
+
+

+Parent degradation

+

We evaluate the observed degradation of the parent compound using simple exponential decline (SFO) and biexponential decline (DFOP), using constant variance (const) and a two-component variance (tc) as error models.

+
+

+Separate evaluations

+

As a first step, to get a visual impression of the fit of the different models, we do separate evaluations for each soil using the mmkin function from the mkin package:

+
+f_parent_mkin_const <- mmkin(c("SFO", "DFOP"), dmta_ds,
+  error_model = "const", quiet = TRUE)
+f_parent_mkin_tc <- mmkin(c("SFO", "DFOP"), dmta_ds,
+  error_model = "tc", quiet = TRUE)
+

The plot of the individual SFO fits shown below suggests that at least in some datasets the degradation slows down towards later time points, and that the scatter of the residuals error is smaller for smaller values (panel to the right):

+
+plot(mixed(f_parent_mkin_const["SFO", ]))
+

+

Using biexponential decline (DFOP) results in a slightly more random scatter of the residuals:

+
+plot(mixed(f_parent_mkin_const["DFOP", ]))
+

+

The population curve (bold line) in the above plot results from taking the mean of the individual transformed parameters, i.e. of log k1 and log k2, as well as of the logit of the g parameter of the DFOP model). Here, this procedure does not result in parameters that represent the degradation well, because in some datasets the fitted value for k2 is extremely close to zero, leading to a log k2 value that dominates the average. This is alleviated if only rate constants that pass the t-test for significant difference from zero (on the untransformed scale) are considered in the averaging:

+
+plot(mixed(f_parent_mkin_const["DFOP", ]), test_log_parms = TRUE)
+

+

While this is visually much more satisfactory, such an average procedure could introduce a bias, as not all results from the individual fits enter the population curve with the same weight. This is where nonlinear mixed-effects models can help out by treating all datasets with equally by fitting a parameter distribution model together with the degradation model and the error model (see below).

+

The remaining trend of the residuals to be higher for higher predicted residues is reduced by using the two-component error model:

+
+plot(mixed(f_parent_mkin_tc["DFOP", ]), test_log_parms = TRUE)
+

+
+
+

+Nonlinear mixed-effects models

+

Instead of taking a model selection decision for each of the individual fits, we fit nonlinear mixed-effects models (using different fitting algorithms as implemented in different packages) and do model selection using all available data at the same time. In order to make sure that these decisions are not unduly influenced by the type of algorithm used, by implementation details or by the use of wrong control parameters, we compare the model selection results obtained with different R packages, with different algorithms and checking control parameters.

+
+

+nlme

+

The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We use would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.

+
+library(nlme)
+f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ])
+#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ])
+# maxIter = 50 reached
+f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ])
+f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ])
+

Note that overparameterisation is also indicated by warnings obtained when fitting SFO or DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in some iterations). In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.

+
+f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ],
+  random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1)))
+anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better
+#f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc,
+#  random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))
+# using log Cholesky parameterisation for random effects (nlme default) does
+# not converge here and gives lots of warnings about the LME step not converging
+

The model comparison function of the nlme package can directly be applied to these fits showing a similar goodness-of-fit of the SFO model, but a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.

+
+anova(
+  f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
+)
+
                        Model df    AIC    BIC  logLik   Test L.Ratio p-value
+f_parent_nlme_sfo_const     1  5 818.63 834.00 -404.31                       
+f_parent_nlme_sfo_tc        2  6 820.61 839.06 -404.31 1 vs 2   0.014  0.9049
+f_parent_nlme_dfop_tc       3 10 687.84 718.59 -333.92 2 vs 3 140.771  <.0001
+

The selected model (DFOP with two-component error) fitted to the data assuming no correlations between random effects is shown below.

+
+plot(f_parent_nlme_dfop_tc)
+

+
+
+

+saemix

+

The saemix package provided the first Open Source implementation of the Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. SAEM fits of degradation models can be performed using an interface to the saemix package available in current development versions of the mkin package.

+

The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit.

+

The convergence plot for the SFO model using constant variance is shown below.

+
+library(saemix)
+f_parent_saemix_sfo_const <- mkin::saem(f_parent_mkin_const["SFO", ], quiet = TRUE,
+  transformations = "saemix")
+plot(f_parent_saemix_sfo_const$so, plot.type = "convergence")
+

+

Obviously the default number of iterations is sufficient to reach convergence. This can also be said for the SFO fit using the two-component error model.

+
+f_parent_saemix_sfo_tc <- mkin::saem(f_parent_mkin_tc["SFO", ], quiet = TRUE,
+  transformations = "saemix")
+plot(f_parent_saemix_sfo_tc$so, plot.type = "convergence")
+

+

When fitting the DFOP model with constant variance, parameter convergence is not as unambiguous (see the failure of nlme with the default number of iterations above). Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence.

+
+f_parent_saemix_dfop_const <- mkin::saem(f_parent_mkin_const["DFOP", ], quiet = TRUE,
+  control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
+    save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
+  transformations = "saemix")
+plot(f_parent_saemix_dfop_const$so, plot.type = "convergence")
+

+

The same applies to the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced by using the two-component error, it remains more or less stable already after 200 iterations of the first phase.

+
+f_parent_saemix_dfop_tc_moreiter <- mkin::saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE,
+  control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
+    save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
+  transformations = "saemix")
+plot(f_parent_saemix_dfop_tc_moreiter$so, plot.type = "convergence")
+

+

The four combinations can be compared using the model comparison function from the saemix package:

+
+compare.saemix(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
+  f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so)
+
Likelihoods calculated by importance sampling
+
     AIC    BIC
+1 818.37 817.33
+2 820.38 819.14
+3 725.91 724.04
+4 683.64 681.55
+

As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. The numeric values are reasonably close to the ones obtained using nlme, considering that the algorithms for fitting the model and for the likelihood calculation are quite different.

+

In order to check the influence of the likelihood calculation algorithms implemented in saemix, the likelihood from Gaussian quadrature is added to the best fit, and the AIC values obtained from the three methods are compared.

+
+f_parent_saemix_dfop_tc_moreiter$so <-
+  llgq.saemix(f_parent_saemix_dfop_tc_moreiter$so)
+AIC(f_parent_saemix_dfop_tc_moreiter$so)
+
[1] 683.64
+
+AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "gq")
+
[1] 683.7
+
+AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "lin")
+
[1] 683.17
+

The AIC values based on importance sampling and Gaussian quadrature are quite similar. Using linearisation is less accurate, but still gives a similar value.

+
+
+

+nlmixr

+

In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.

+

First, the focei algorithm is used for the four model combinations and the goodness of fit of the results is compared.

+
+library(nlmixr)
+f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei")
+f_parent_nlmixr_focei_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "focei")
+f_parent_nlmixr_focei_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "focei")
+f_parent_nlmixr_focei_dfop_tc<- nlmixr(f_parent_mkin_tc["DFOP", ], est = "focei")
+
+AIC(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
+  f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm)
+
                                    df    AIC
+f_parent_nlmixr_focei_sfo_const$nm   5 818.63
+f_parent_nlmixr_focei_sfo_tc$nm      6 820.61
+f_parent_nlmixr_focei_dfop_const$nm  9 728.11
+f_parent_nlmixr_focei_dfop_tc$nm    10 687.82
+

The AIC values are very close to the ones obtained with nlme which are repeated below for convenience.

+
+AIC(
+  f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
+)
+
                        df    AIC
+f_parent_nlme_sfo_const  5 818.63
+f_parent_nlme_sfo_tc     6 820.61
+f_parent_nlme_dfop_tc   10 687.84
+

Secondly, we use the SAEM estimation routine and check the convergence plots for SFO with constant variance

+
+f_parent_nlmixr_saem_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE))
+traceplot(f_parent_nlmixr_saem_sfo_const$nm)
+

+

for SFO with two-component error

+
+f_parent_nlmixr_saem_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE))
+traceplot(f_parent_nlmixr_saem_sfo_tc$nm)
+

+

For DFOP with constant variance, the convergence plots show considerable instability of the fit, which can be alleviated by increasing the number of iterations and the number of parallel chains for the first phase of algorithm.

+
+f_parent_nlmixr_saem_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000), nmc = 15)
+traceplot(f_parent_nlmixr_saem_dfop_const$nm)
+

+

For DFOP with two-component error, the same increase in iterations and parallel chains was used, but using the two-component error appears to lead to a less erratic convergence, so this may not be necessary to this degree.

+
+f_parent_nlmixr_saem_dfop_tc <- nlmixr(f_parent_mkin_tc["DFOP", ], est = "saem",
+  control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000, nmc = 15))
+traceplot(f_parent_nlmixr_saem_dfop_tc$nm)
+

+

The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using the two-component error model is given as Infinity.

+
+AIC(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
+  f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm)
+
                                   df    AIC
+f_parent_nlmixr_saem_sfo_const$nm   5 820.54
+f_parent_nlmixr_saem_sfo_tc$nm      6 835.26
+f_parent_nlmixr_saem_dfop_const$nm  9 842.84
+f_parent_nlmixr_saem_dfop_tc$nm    10 684.51
+

The following table gives the AIC values obtained with the three packages.

+
+AIC_all <- data.frame(
+  nlme = c(AIC(f_parent_nlme_sfo_const), AIC(f_parent_nlme_sfo_tc), NA, AIC(f_parent_nlme_dfop_tc)),
+  nlmixr_focei = sapply(list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
+  f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm), AIC),
+  saemix = sapply(list(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
+    f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so), AIC),
+  nlmixr_saem = sapply(list(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
+  f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm), AIC)
+)
+kable(AIC_all)
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
nlmenlmixr_foceisaemixnlmixr_saem
818.63818.63818.37820.54
820.61820.61820.38835.26
NA728.11725.91842.84
687.84687.82683.64684.51
+
+
+
+
+

+References

+ +
+
+

EFSA. 2018. “Peer Review of the Pesticide Risk Assessment of the Active Substance Dimethenamid-P.” EFSA Journal 16 (4): 5211.

+
+
+

Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria. 2018. “Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour, Rev. 2 - November 2017.” https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716.

+
+
+
+
+ + + +
+ + + +
+

Developed by Johannes Ranke.

+
+ +
+

Site built with pkgdown 1.6.1.

+
+ +
+
+ + + + + + diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/accessible-code-block-0.0.1/empty-anchor.js b/docs/dev/articles/web_only/dimethenamid_2018_files/accessible-code-block-0.0.1/empty-anchor.js new file mode 100644 index 00000000..ca349fd6 --- /dev/null +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/accessible-code-block-0.0.1/empty-anchor.js @@ -0,0 +1,15 @@ +// Hide empty tag within highlighted CodeBlock for screen reader accessibility (see https://github.com/jgm/pandoc/issues/6352#issuecomment-626106786) --> +// v0.0.1 +// Written by JooYoung Seo (jooyoung@psu.edu) and Atsushi Yasumoto on June 1st, 2020. + +document.addEventListener('DOMContentLoaded', function() { + const codeList = document.getElementsByClassName("sourceCode"); + for (var i = 0; i < codeList.length; i++) { + var linkList = codeList[i].getElementsByTagName('a'); + for (var j = 0; j < linkList.length; j++) { + if (linkList[j].innerHTML === "") { + linkList[j].setAttribute('aria-hidden', 'true'); + } + } + } +}); diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png new file mode 100644 index 00000000..c51afe54 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png new file mode 100644 index 00000000..080f0dde Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png new file mode 100644 index 00000000..a3933e54 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png new file mode 100644 index 00000000..8dee2e3c Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png new file mode 100644 index 00000000..54a8c1a6 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png new file mode 100644 index 00000000..91f3d977 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png new file mode 100644 index 00000000..c84f2926 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png new file mode 100644 index 00000000..cfef9dfc Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png new file mode 100644 index 00000000..a4695eea Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png new file mode 100644 index 00000000..1c8fc837 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png new file mode 100644 index 00000000..469ebafd Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png new file mode 100644 index 00000000..d26bcc09 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png new file mode 100644 index 00000000..6edeb794 Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.9/header-attrs.js b/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.9/header-attrs.js new file mode 100644 index 00000000..dd57d92e --- /dev/null +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.9/header-attrs.js @@ -0,0 +1,12 @@ +// Pandoc 2.9 adds attributes on both header and div. We remove the former (to +// be compatible with the behavior of Pandoc < 2.8). +document.addEventListener('DOMContentLoaded', function(e) { + var hs = document.querySelectorAll("div.section[class*='level'] > :first-child"); + var i, h, a; + for (i = 0; i < hs.length; i++) { + h = hs[i]; + if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6 + a = h.attributes; + while (a.length > 0) h.removeAttribute(a[0].name); + } +}); diff --git a/docs/dev/authors.html b/docs/dev/authors.html index 4208dc24..943cba1b 100644 --- a/docs/dev/authors.html +++ b/docs/dev/authors.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/index.html b/docs/dev/index.html index 6e3fa6e1..8049b3a1 100644 --- a/docs/dev/index.html +++ b/docs/dev/index.html @@ -38,7 +38,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/news/index.html b/docs/dev/news/index.html index 234ba02f..cfe577cf 100644 --- a/docs/dev/news/index.html +++ b/docs/dev/news/index.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/pkgdown.yml b/docs/dev/pkgdown.yml index b2c50e79..16f7f0d6 100644 --- a/docs/dev/pkgdown.yml +++ b/docs/dev/pkgdown.yml @@ -10,7 +10,8 @@ articles: web_only/NAFTA_examples: NAFTA_examples.html web_only/benchmarks: benchmarks.html web_only/compiled_models: compiled_models.html -last_built: 2021-06-17T12:41Z + web_only/dimethenamid_2018: dimethenamid_2018.html +last_built: 2021-07-27T15:54Z urls: reference: https://pkgdown.jrwb.de/mkin/reference article: https://pkgdown.jrwb.de/mkin/articles diff --git a/docs/dev/reference/Rplot005.png b/docs/dev/reference/Rplot005.png index 55aa7eec..92c7cc2d 100644 Binary files a/docs/dev/reference/Rplot005.png and b/docs/dev/reference/Rplot005.png differ diff --git a/docs/dev/reference/dimethenamid_2018-2.png b/docs/dev/reference/dimethenamid_2018-2.png new file mode 100644 index 00000000..a81b2aaf Binary files /dev/null and b/docs/dev/reference/dimethenamid_2018-2.png differ diff --git a/docs/dev/reference/dimethenamid_2018.html b/docs/dev/reference/dimethenamid_2018.html index e255765e..160dcaa3 100644 --- a/docs/dev/reference/dimethenamid_2018.html +++ b/docs/dev/reference/dimethenamid_2018.html @@ -77,7 +77,7 @@ constrained by data protection regulations." /> mkin - 1.0.5 + 1.1.0 @@ -168,7 +168,7 @@ constrained by data protection regulations.

Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria (2018) Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour Rev. 2 - November 2017 -http://registerofquestions.efsa.europa.eu/roqFrontend/outputLoader?output=ON-5211

+https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716

Details

The R code used to create this data object is installed with this package @@ -295,8 +295,11 @@ specific pieces of information in the comments.

#> M31 ~ add(sigma_low_M31) + prop(rsd_high_M31) #> }) #> } -#> <environment: 0x555559c2bd78>
f_dmta_nlmixr_focei <- nlmixr(f_dmta_mkin_tc, est = "focei", - control = nlmixr::foceiControl(print = 500)) +#> <environment: 0x555559c00ce8>
# The focei fit takes about four minutes on my system +system.time( + f_dmta_nlmixr_focei <- nlmixr(f_dmta_mkin_tc, est = "focei", + control = nlmixr::foceiControl(print = 500)) +)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> [====|====|====|====|====|====|====|====|====|====] 0:00:02 #>
#> → calculate sensitivities
#> [====|====|====|====|====|====|====|====|====|====] 0:00:04 #>
#> → calculate ∂(f)/∂(η)
#> [====|====|====|====|====|====|====|====|====|====] 0:00:01 @@ -320,12 +323,13 @@ specific pieces of information in the comments.

#> |.....................| o5 | o6 | o7 | o8 | #> |.....................| o9 | o10 |...........|...........| #> calculating covariance matrix -#> done
#> Calculating residuals/tables
#> done
#> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
#> Warning: last objective function was not at minimum, possible problems in optimization
#> Warning: S matrix non-positive definite
#> Warning: using R matrix to calculate covariance
#> Warning: gradient problems with initial estimate and covariance; see $scaleInfo
summary(f_dmta_nlmixr_focei) +#> done
#> Calculating residuals/tables
#> done
#> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
#> Warning: last objective function was not at minimum, possible problems in optimization
#> Warning: S matrix non-positive definite
#> Warning: using R matrix to calculate covariance
#> Warning: gradient problems with initial estimate and covariance; see $scaleInfo
#> user system elapsed +#> 227.879 9.742 237.728
summary(f_dmta_nlmixr_focei)
#> nlmixr version used for fitting: 2.0.4 -#> mkin version used for pre-fitting: 1.0.5 +#> mkin version used for pre-fitting: 1.1.0 #> R version used for fitting: 4.1.0 -#> Date of fit: Thu Jun 17 14:04:58 2021 -#> Date of summary: Thu Jun 17 14:04:58 2021 +#> Date of fit: Tue Jul 27 16:02:33 2021 +#> Date of summary: Tue Jul 27 16:02:34 2021 #> #> Equations: #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -346,7 +350,7 @@ specific pieces of information in the comments.

#> #> Degradation model predictions using RxODE #> -#> Fitted in 242.937 s +#> Fitted in 237.547 s #> #> Variance model: Two-component variance function #> @@ -480,13 +484,194 @@ specific pieces of information in the comments.

#> M23 34.99 116.24 NA NA NA #> M27 53.05 176.23 NA NA NA #> M31 48.48 161.05 NA NA NA
plot(f_dmta_nlmixr_focei) -
# saem has a problem with this model/data combination, maybe because of the -# overparameterised error model, to be investigated -#f_dmta_nlmixr_saem <- nlmixr(f_dmta_mkin_tc, est = "saem", -# control = saemControl(print = 500)) -#summary(f_dmta_nlmixr_saem) -#plot(f_dmta_nlmixr_saem) -# } +
# Using saemix takes about 18 minutes +system.time( + f_dmta_saemix <- saem(f_dmta_mkin_tc, test_log_parms = TRUE) +) +
#> Running main SAEM algorithm +#> [1] "Tue Jul 27 16:02:34 2021" +#> .... +#> Minimisation finished +#> [1] "Tue Jul 27 16:21:39 2021"
#> user system elapsed +#> 1213.394 0.087 1213.578
+# nlmixr with est = "saem" is pretty fast with default iteration numbers, most +# of the time (about 2.5 minutes) is spent for calculating the log likelihood at the end +# The likelihood calculated for the nlmixr fit is much lower than that found by saemix +# Also, the trace plot and the plot of the individual predictions is not +# convincing for the parent. It seems we are fitting an overparameterised +# model, so the result we get strongly depends on starting parameters and control settings. +system.time( + f_dmta_nlmixr_saem <- nlmixr(f_dmta_mkin_tc, est = "saem", + control = nlmixr::saemControl(print = 500, logLik = TRUE, nmc = 9)) +) +
#> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> 1: 98.3427 -3.5148 -3.3187 -3.7728 -2.1163 -2.8457 0.9482 -2.8064 -2.7412 -2.8745 2.7912 0.6805 0.8213 0.8055 0.8578 1.4980 2.9309 0.2850 0.2854 0.2850 4.0990 0.3821 3.5349 0.6537 5.4143 0.0002 4.5093 0.1905 +#> 500: 97.8277 -4.3506 -4.0318 -4.1520 -3.0553 -3.5843 1.1326 -2.0873 -2.0421 -2.0751 0.2960 1.2515 0.2531 0.3807 0.7928 0.8863 6.5211 0.1433 0.1082 0.3353 0.8960 0.0470 0.7501 0.0475 0.9527 0.0281 0.7321 0.0594
#> Calculating covariance matrix
#>
#> Calculating -2LL by Gaussian quadrature (nnodes=3,nsd=1.6)
#>
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → compiling EBE model...
#>
#> ✔ done
#> Needed Covariates:
#> [1] "CMT"
#> Calculating residuals/tables
#> done
#> user system elapsed +#> 818.782 3.808 154.926
traceplot(f_dmta_nlmixr_saem$nm) +
#> Error in traceplot(f_dmta_nlmixr_saem$nm): could not find function "traceplot"
summary(f_dmta_nlmixr_saem) +
#> nlmixr version used for fitting: 2.0.4 +#> mkin version used for pre-fitting: 1.1.0 +#> R version used for fitting: 4.1.0 +#> Date of fit: Tue Jul 27 16:25:23 2021 +#> Date of summary: Tue Jul 27 16:25:23 2021 +#> +#> Equations: +#> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * +#> time)) / (g * exp(-k1 * time) + (1 - g) * exp(-k2 * time))) +#> * DMTA +#> d_M23/dt = + f_DMTA_to_M23 * ((k1 * g * exp(-k1 * time) + k2 * (1 - g) +#> * exp(-k2 * time)) / (g * exp(-k1 * time) + (1 - g) * +#> exp(-k2 * time))) * DMTA - k_M23 * M23 +#> d_M27/dt = + f_DMTA_to_M27 * ((k1 * g * exp(-k1 * time) + k2 * (1 - g) +#> * exp(-k2 * time)) / (g * exp(-k1 * time) + (1 - g) * +#> exp(-k2 * time))) * DMTA - k_M27 * M27 + k_M31 * M31 +#> d_M31/dt = + f_DMTA_to_M31 * ((k1 * g * exp(-k1 * time) + k2 * (1 - g) +#> * exp(-k2 * time)) / (g * exp(-k1 * time) + (1 - g) * +#> exp(-k2 * time))) * DMTA - k_M31 * M31 +#> +#> Data: +#> 568 observations of 4 variable(s) grouped in 6 datasets +#> +#> Degradation model predictions using RxODE +#> +#> Fitted in 154.632 s +#> +#> Variance model: Two-component variance function +#> +#> Mean of starting values for individual parameters: +#> DMTA_0 log_k_M23 log_k_M27 log_k_M31 f_DMTA_ilr_1 f_DMTA_ilr_2 +#> 98.7698 -3.9216 -4.3377 -4.2477 0.1380 0.1393 +#> f_DMTA_ilr_3 log_k1 log_k2 g_qlogis +#> -1.7571 -2.2341 -3.7763 0.4502 +#> +#> Mean of starting values for error model parameters: +#> sigma_low_DMTA rsd_high_DMTA sigma_low_M23 rsd_high_M23 sigma_low_M27 +#> 0.69793 0.02577 0.69793 0.02577 0.69793 +#> rsd_high_M27 sigma_low_M31 rsd_high_M31 +#> 0.02577 0.69793 0.02577 +#> +#> Fixed degradation parameter values: +#> None +#> +#> Results: +#> +#> Likelihood calculated by focei +#> AIC BIC logLik +#> 2036 2157 -989.8 +#> +#> Optimised parameters: +#> est. lower upper +#> DMTA_0 97.828 96.121 99.535 +#> log_k_M23 -4.351 -5.300 -3.401 +#> log_k_M27 -4.032 -4.470 -3.594 +#> log_k_M31 -4.152 -4.689 -3.615 +#> log_k1 -3.055 -3.785 -2.325 +#> log_k2 -3.584 -4.517 -2.651 +#> g_qlogis 1.133 -2.165 4.430 +#> f_DMTA_tffm0_1_qlogis -2.087 -2.407 -1.768 +#> f_DMTA_tffm0_2_qlogis -2.042 -2.336 -1.748 +#> f_DMTA_tffm0_3_qlogis -2.075 -2.557 -1.593 +#> +#> Correlation: +#> DMTA_0 l__M23 l__M27 l__M31 log_k1 log_k2 g_qlgs +#> log_k_M23 -0.031 +#> log_k_M27 -0.050 0.004 +#> log_k_M31 -0.032 0.003 0.078 +#> log_k1 0.014 -0.002 -0.002 -0.001 +#> log_k2 0.059 0.006 -0.001 0.002 -0.037 +#> g_qlogis -0.077 0.005 0.009 0.004 0.035 -0.201 +#> f_DMTA_tffm0_1_qlogis -0.104 0.066 0.009 0.006 0.000 -0.011 0.014 +#> f_DMTA_tffm0_2_qlogis -0.120 0.013 0.081 -0.033 -0.002 -0.013 0.017 +#> f_DMTA_tffm0_3_qlogis -0.086 0.010 0.060 0.078 -0.002 -0.005 0.010 +#> f_DMTA_0_1 f_DMTA_0_2 +#> log_k_M23 +#> log_k_M27 +#> log_k_M31 +#> log_k1 +#> log_k2 +#> g_qlogis +#> f_DMTA_tffm0_1_qlogis +#> f_DMTA_tffm0_2_qlogis 0.026 +#> f_DMTA_tffm0_3_qlogis 0.019 0.002 +#> +#> Random effects (omega): +#> eta.DMTA_0 eta.log_k_M23 eta.log_k_M27 eta.log_k_M31 +#> eta.DMTA_0 0.296 0.000 0.0000 0.0000 +#> eta.log_k_M23 0.000 1.252 0.0000 0.0000 +#> eta.log_k_M27 0.000 0.000 0.2531 0.0000 +#> eta.log_k_M31 0.000 0.000 0.0000 0.3807 +#> eta.log_k1 0.000 0.000 0.0000 0.0000 +#> eta.log_k2 0.000 0.000 0.0000 0.0000 +#> eta.g_qlogis 0.000 0.000 0.0000 0.0000 +#> eta.f_DMTA_tffm0_1_qlogis 0.000 0.000 0.0000 0.0000 +#> eta.f_DMTA_tffm0_2_qlogis 0.000 0.000 0.0000 0.0000 +#> eta.f_DMTA_tffm0_3_qlogis 0.000 0.000 0.0000 0.0000 +#> eta.log_k1 eta.log_k2 eta.g_qlogis +#> eta.DMTA_0 0.0000 0.0000 0.000 +#> eta.log_k_M23 0.0000 0.0000 0.000 +#> eta.log_k_M27 0.0000 0.0000 0.000 +#> eta.log_k_M31 0.0000 0.0000 0.000 +#> eta.log_k1 0.7928 0.0000 0.000 +#> eta.log_k2 0.0000 0.8863 0.000 +#> eta.g_qlogis 0.0000 0.0000 6.521 +#> eta.f_DMTA_tffm0_1_qlogis 0.0000 0.0000 0.000 +#> eta.f_DMTA_tffm0_2_qlogis 0.0000 0.0000 0.000 +#> eta.f_DMTA_tffm0_3_qlogis 0.0000 0.0000 0.000 +#> eta.f_DMTA_tffm0_1_qlogis eta.f_DMTA_tffm0_2_qlogis +#> eta.DMTA_0 0.0000 0.0000 +#> eta.log_k_M23 0.0000 0.0000 +#> eta.log_k_M27 0.0000 0.0000 +#> eta.log_k_M31 0.0000 0.0000 +#> eta.log_k1 0.0000 0.0000 +#> eta.log_k2 0.0000 0.0000 +#> eta.g_qlogis 0.0000 0.0000 +#> eta.f_DMTA_tffm0_1_qlogis 0.1433 0.0000 +#> eta.f_DMTA_tffm0_2_qlogis 0.0000 0.1082 +#> eta.f_DMTA_tffm0_3_qlogis 0.0000 0.0000 +#> eta.f_DMTA_tffm0_3_qlogis +#> eta.DMTA_0 0.0000 +#> eta.log_k_M23 0.0000 +#> eta.log_k_M27 0.0000 +#> eta.log_k_M31 0.0000 +#> eta.log_k1 0.0000 +#> eta.log_k2 0.0000 +#> eta.g_qlogis 0.0000 +#> eta.f_DMTA_tffm0_1_qlogis 0.0000 +#> eta.f_DMTA_tffm0_2_qlogis 0.0000 +#> eta.f_DMTA_tffm0_3_qlogis 0.3353 +#> +#> Variance model: +#> sigma_low_DMTA rsd_high_DMTA sigma_low_M23 rsd_high_M23 sigma_low_M27 +#> 0.89603 0.04704 0.75015 0.04753 0.95265 +#> rsd_high_M27 sigma_low_M31 rsd_high_M31 +#> 0.02810 0.73212 0.05942 +#> +#> Backtransformed parameters: +#> est. lower upper +#> DMTA_0 97.82774 96.120503 99.53498 +#> k_M23 0.01290 0.004991 0.03334 +#> k_M27 0.01774 0.011451 0.02749 +#> k_M31 0.01573 0.009195 0.02692 +#> f_DMTA_to_M23 0.11033 NA NA +#> f_DMTA_to_M27 0.10218 NA NA +#> f_DMTA_to_M31 0.08784 NA NA +#> k1 0.04711 0.022707 0.09773 +#> k2 0.02775 0.010918 0.07056 +#> g 0.75632 0.102960 0.98823 +#> +#> Resulting formation fractions: +#> ff +#> DMTA_M23 0.11033 +#> DMTA_M27 0.10218 +#> DMTA_M31 0.08784 +#> DMTA_sink 0.69965 +#> +#> Estimated disappearance times: +#> DT50 DT90 DT50back DT50_k1 DT50_k2 +#> DMTA 16.59 57.44 17.29 14.71 24.97 +#> M23 53.74 178.51 NA NA NA +#> M27 39.07 129.78 NA NA NA +#> M31 44.06 146.36 NA NA NA
plot(f_dmta_nlmixr_saem) +
# }
diff --git a/docs/dev/reference/index.html b/docs/dev/reference/index.html index bb030605..d5ec387a 100644 --- a/docs/dev/reference/index.html +++ b/docs/dev/reference/index.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/reference/mean_degparms.html b/docs/dev/reference/mean_degparms.html index f63dbc31..5981c625 100644 --- a/docs/dev/reference/mean_degparms.html +++ b/docs/dev/reference/mean_degparms.html @@ -72,7 +72,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/reference/mkinmod.html b/docs/dev/reference/mkinmod.html index 413f0ae1..e57e7062 100644 --- a/docs/dev/reference/mkinmod.html +++ b/docs/dev/reference/mkinmod.html @@ -44,9 +44,7 @@ variable, specifying the corresponding submodel as well as outgoing pathways (see examples). Print mkinmod objects in a way that the user finds his way to get to its -components. -This is a convenience function to set up the lists used as arguments for -mkinmod." /> +components." /> @@ -78,7 +76,7 @@ mkinmod." /> mkin - 1.0.3.9000 + 1.1.0 @@ -155,8 +153,6 @@ variable, specifying the corresponding submodel as well as outgoing pathways (see examples).

Print mkinmod objects in a way that the user finds his way to get to its components.

-

This is a convenience function to set up the lists used as arguments for -mkinmod.

mkinmod(
@@ -348,7 +344,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media

    parent = mkinsub("SFO", "m1", full_name = "Test compound"),
    m1 = mkinsub("SFO", full_name = "Metabolite M1"),
    name = "SFO_SFO", dll_dir = DLL_dir, unload = TRUE, overwrite = TRUE)
-
#> Copied DLL from /tmp/Rtmp92fCb2/file133ad522561845.so to /home/jranke/.local/share/mkin/SFO_SFO.so
# Now we can save the model and restore it in a new session
+
#> Copied DLL from /tmp/RtmpPWWdbW/fileccff46a6d9773.so to /home/jranke/.local/share/mkin/SFO_SFO.so
# Now we can save the model and restore it in a new session
 saveRDS(SFO_SFO.2, file = "~/SFO_SFO.rds")
 # Terminate the R session here if you would like to check, and then do
 library(mkin)
@@ -397,7 +393,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media

 #>     })
 #>     return(predicted)
 #> }
-#> <environment: 0x5555572517f8>

+#> <environment: 0x5555645abab8>

 # If we have several parallel metabolites
 # (compare tests/testthat/test_synthetic_data_for_UBA_2014.R)
 m_synth_DFOP_par <- mkinmod(
diff --git a/docs/dev/reference/nlme-1.png b/docs/dev/reference/nlme-1.png
index 365aaef0..f739089a 100644
Binary files a/docs/dev/reference/nlme-1.png and b/docs/dev/reference/nlme-1.png differ
diff --git a/docs/dev/reference/nlme-2.png b/docs/dev/reference/nlme-2.png
index 40841404..d3b29bb0 100644
Binary files a/docs/dev/reference/nlme-2.png and b/docs/dev/reference/nlme-2.png differ
diff --git a/docs/dev/reference/nlme.html b/docs/dev/reference/nlme.html
index 55a94443..184585df 100644
--- a/docs/dev/reference/nlme.html
+++ b/docs/dev/reference/nlme.html
@@ -75,7 +75,7 @@ datasets. They are used internally by the nlme.mmkin() method." />
       
       
         mkin
-        1.0.5
+        1.1.0
       
     

 
@@ -216,28 +216,28 @@ datasets. They are used internally by the nlme.m
 #>   Model: value ~ nlme_f(name, time, parent_0, log_k_parent_sink) 
 #>   Data: grouped_data 
 #>        AIC      BIC    logLik
-#>   300.6824 310.2426 -145.3412
+#>   278.1355 287.7946 -134.0677
 #> 
 #> Random effects:
 #>  Formula: list(parent_0 ~ 1, log_k_parent_sink ~ 1)
 #>  Level: ds
 #>  Structure: Diagonal
 #>         parent_0 log_k_parent_sink Residual
-#> StdDev: 1.697361         0.6801209 3.666073
+#> StdDev: 3.406042         0.6437579 2.620833
 #> 
 #> Fixed effects:  parent_0 + log_k_parent_sink ~ 1 
 #>                       Value Std.Error DF  t-value p-value
-#> parent_0          100.99378 1.3890416 46 72.70753       0
-#> log_k_parent_sink  -3.07521 0.4018589 46 -7.65246       0
+#> parent_0          101.50173  2.123709 47 47.79457       0
+#> log_k_parent_sink  -3.07597  0.379775 47 -8.09945       0
 #>  Correlation: 
 #>                   prnt_0
-#> log_k_parent_sink 0.027 
+#> log_k_parent_sink 0.01  
 #> 
 #> Standardized Within-Group Residuals:
-#>        Min         Q1        Med         Q3        Max 
-#> -1.9942823 -0.5622565  0.1791579  0.7165038  2.0704781 
+#>         Min          Q1         Med          Q3         Max 
+#> -2.06889303 -0.50100169 -0.06268253  0.62557544  2.19922001 
 #> 
-#> Number of Observations: 50
+#> Number of Observations: 51
 #> Number of Groups: 3 
plot(augPred(m_nlme, level = 0:1), layout = c(3, 1))
 
# augPred does not work on fits with more than one state
 # variable
diff --git a/docs/dev/reference/nlme.mmkin.html b/docs/dev/reference/nlme.mmkin.html
index 2bbf4f80..866091ca 100644
--- a/docs/dev/reference/nlme.mmkin.html
+++ b/docs/dev/reference/nlme.mmkin.html
@@ -74,7 +74,7 @@ have been obtained by fitting the same model to a list of datasets." />
       
       
         mkin
-        1.0.5
+        1.1.0
       
     

 
@@ -194,10 +194,9 @@ mmkin model are used as fixed parameters

     
     
       random
-      
If not specified, correlated random effects are set up
-for all optimised degradation model parameters using the log-Cholesky
-parameterization nlme::pdLogChol that is also the default of
-the generic nlme method.

+      
If not specified, no correlations between random effects are
+set up for the optimised degradation model parameters. This is
+achieved by using the nlme::pdDiag method.

     
     
       groups
diff --git a/docs/dev/reference/nlmixr.mmkin.html b/docs/dev/reference/nlmixr.mmkin.html
index d09f2ad4..328bad43 100644
--- a/docs/dev/reference/nlmixr.mmkin.html
+++ b/docs/dev/reference/nlmixr.mmkin.html
@@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." />
       
       
         mkin
-        1.0.5
+        1.1.0
       
     
 
@@ -4501,7 +4501,7 @@ obtained by fitting the same model to a list of datasets using k_A1=rx_expr_11;
 #> f_parent=1/(1+exp(-(ETA[4]+THETA[4])));
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 5.607 0.474 6.078
f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei")
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 5.548 0.415 5.961
f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
 #> rx_expr_6~ETA[1]+THETA[1];
@@ -4550,7 +4550,7 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8);
 #> f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.853 0.393 7.242
f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei")
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.895 0.416 7.309
f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
 #> rx_expr_6~ETA[1]+THETA[1];
@@ -4607,10 +4607,10 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> g=1/(rx_expr_20);
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 15.18 0.414 15.6

+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 15.03 0.478 15.51

 # Variance by variable is supported by 'saem' and 'focei'
 f_nlmixr_fomc_sfo_saem_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "saem")
-
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.22 0.089 1.31
f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei")
+
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.294 0.134 1.427
f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
 #> rx_expr_6~ETA[1]+THETA[1];
@@ -4659,8 +4659,8 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8);
 #> f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.784 0.418 7.2
f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem")
-
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.357 0.096 1.452
f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei")
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.584 0.393 6.976
f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem")
+
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.302 0.142 1.443
f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
 #> rx_expr_6~ETA[1]+THETA[1];
@@ -4717,7 +4717,7 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> g=1/(rx_expr_19);
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 15.17 0.353 15.52

+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 14.58 0.482 15.06

 # Identical two-component error for all variables is only possible with
 # est = 'focei' in nlmixr
 f_nlmixr_fomc_sfo_focei_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei")
@@ -4771,7 +4771,7 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8);
 #> f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.708 0.429 9.135
f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei")
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.484 0.401 8.883
f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
 #> rx_expr_6~ETA[1]+THETA[1];
@@ -4830,12 +4830,12 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> g=1/(rx_expr_21);
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 18.05 0.446 18.5

+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 18.44 0.438 18.87

 # Two-component error by variable is possible with both estimation methods
 # Variance by variable is supported by 'saem' and 'focei'
 f_nlmixr_fomc_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "saem",
   error_model = "obs_tc")
-
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.763 0.036 0.799
f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei",
+
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.784 0.028 0.812
f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei",
   error_model = "obs_tc")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
@@ -4887,9 +4887,9 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8);
 #> f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.196 0.388 8.584
f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem",
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.157 0.51 8.664
f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem",
   error_model = "obs_tc")
-
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.843 0.028 0.871
f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei",
+
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.81 0.045 0.854
f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei",
   error_model = "obs_tc")
 
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
 #> cmt(A1);
@@ -4949,7 +4949,7 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
 #> g=1/(rx_expr_19);
 #> tad=tad();
-#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 17.73 0.411 18.14

+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 17.34 0.397 17.73

 AIC(
   f_nlmixr_sfo_sfo_focei_const$nm,
   f_nlmixr_fomc_sfo_focei_const$nm,
diff --git a/docs/dev/reference/plot.mixed.mmkin-3.png b/docs/dev/reference/plot.mixed.mmkin-3.png
index a9b96726..7e2876b3 100644
Binary files a/docs/dev/reference/plot.mixed.mmkin-3.png and b/docs/dev/reference/plot.mixed.mmkin-3.png differ
diff --git a/docs/dev/reference/plot.mixed.mmkin-4.png b/docs/dev/reference/plot.mixed.mmkin-4.png
index 22219e5e..945c4d41 100644
Binary files a/docs/dev/reference/plot.mixed.mmkin-4.png and b/docs/dev/reference/plot.mixed.mmkin-4.png differ
diff --git a/docs/dev/reference/plot.mixed.mmkin.html b/docs/dev/reference/plot.mixed.mmkin.html
index a4222991..7f3faa90 100644
--- a/docs/dev/reference/plot.mixed.mmkin.html
+++ b/docs/dev/reference/plot.mixed.mmkin.html
@@ -72,7 +72,7 @@
       
       
         mkin
-        1.0.5
+        1.1.0
       
     

 
@@ -296,10 +296,10 @@ corresponding model prediction lines for the different datasets.

 

 f_saem <- saem(f, transformations = "saemix")
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:56:37 2021"
+#> [1] "Tue Jul 27 16:30:50 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:56:44 2021"
plot(f_saem)
+#> [1] "Tue Jul 27 16:30:58 2021"
plot(f_saem)
 

 f_obs <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE, error_model = "obs")
 f_nlmix <- nlmix(f_obs)
diff --git a/docs/dev/reference/reexports.html b/docs/dev/reference/reexports.html
index f5ace044..ac4fa4d9 100644
--- a/docs/dev/reference/reexports.html
+++ b/docs/dev/reference/reexports.html
@@ -81,7 +81,7 @@ below to see their documentation.
       
       
         mkin
-        1.0.5
+        1.1.0
       
     

 
diff --git a/docs/dev/reference/saem-5.png b/docs/dev/reference/saem-5.png
index 8212ec67..d22e7285 100644
Binary files a/docs/dev/reference/saem-5.png and b/docs/dev/reference/saem-5.png differ
diff --git a/docs/dev/reference/saem.html b/docs/dev/reference/saem.html
index 98faad6f..15271c8a 100644
--- a/docs/dev/reference/saem.html
+++ b/docs/dev/reference/saem.html
@@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." />
       
       
         mkin
-        1.0.5
+        1.1.0
       
     
 
@@ -158,7 +158,7 @@ Expectation Maximisation algorithm (SAEM).

   object,
   transformations = c("mkin", "saemix"),
   degparms_start = numeric(),
-  test_log_parms = FALSE,
+  test_log_parms = TRUE,
   conf.level = 0.6,
   solution_type = "auto",
   nbiter.saemix = c(300, 100),
@@ -288,27 +288,27 @@ using mmkin.

   state.ini = c(parent = 100), fixed_initials = "parent", quiet = TRUE)
 f_saem_p0_fixed <- saem(f_mmkin_parent_p0_fixed)
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:56:49 2021"
+#> [1] "Tue Jul 27 16:31:02 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:56:51 2021"

+#> [1] "Tue Jul 27 16:31:04 2021"

 f_mmkin_parent <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE)
 f_saem_sfo <- saem(f_mmkin_parent["SFO", ])
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:56:53 2021"
+#> [1] "Tue Jul 27 16:31:06 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:56:54 2021"
f_saem_fomc <- saem(f_mmkin_parent["FOMC", ])
+#> [1] "Tue Jul 27 16:31:07 2021"
f_saem_fomc <- saem(f_mmkin_parent["FOMC", ])
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:56:54 2021"
+#> [1] "Tue Jul 27 16:31:07 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:56:57 2021"
f_saem_dfop <- saem(f_mmkin_parent["DFOP", ])
+#> [1] "Tue Jul 27 16:31:09 2021"
f_saem_dfop <- saem(f_mmkin_parent["DFOP", ])
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:56:57 2021"
+#> [1] "Tue Jul 27 16:31:10 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:57:00 2021"

+#> [1] "Tue Jul 27 16:31:12 2021"

 # The returned saem.mmkin object contains an SaemixObject, therefore we can use
 # functions from saemix
 library(saemix)
@@ -357,10 +357,10 @@ using mmkin.

 f_mmkin_parent_tc <- update(f_mmkin_parent, error_model = "tc")
 f_saem_fomc_tc <- saem(f_mmkin_parent_tc["FOMC", ])
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:57:03 2021"
+#> [1] "Tue Jul 27 16:31:16 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:57:09 2021"
compare.saemix(f_saem_fomc$so, f_saem_fomc_tc$so)
+#> [1] "Tue Jul 27 16:31:20 2021"
compare.saemix(f_saem_fomc$so, f_saem_fomc_tc$so)
 
#> Likelihoods calculated by importance sampling
#>        AIC      BIC
 #> 1 467.7096 464.9757
 #> 2 469.6831 466.5586

@@ -381,15 +381,15 @@ using mmkin.

 # four minutes
 f_saem_sfo_sfo <- saem(f_mmkin["SFO-SFO", ])
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:57:12 2021"
+#> [1] "Tue Jul 27 16:31:24 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:57:17 2021"
f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ])
+#> [1] "Tue Jul 27 16:31:29 2021"
f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ])
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:57:17 2021"
+#> [1] "Tue Jul 27 16:31:30 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:57:26 2021"
# We can use print, plot and summary methods to check the results
+#> [1] "Tue Jul 27 16:31:38 2021"
# We can use print, plot and summary methods to check the results
 print(f_saem_dfop_sfo)
 
#> Kinetic nonlinear mixed-effects model fit by SAEM
 #> Structural model:
@@ -405,35 +405,35 @@ using mmkin.

 #> 
 #> Likelihood computed by importance sampling
 #>     AIC   BIC logLik
-#>   841.6 836.5 -407.8
+#>   839.6 834.6 -406.8
 #> 
 #> Fitted parameters:
 #>                     estimate    lower   upper
-#> parent_0            93.76647 91.15312 96.3798
-#> log_k_A1            -6.13235 -8.45788 -3.8068
-#> f_parent_qlogis     -0.97364 -1.36940 -0.5779
-#> log_k1              -2.53176 -3.80372 -1.2598
-#> log_k2              -3.58667 -5.29524 -1.8781
-#> g_qlogis             0.01238 -1.07968  1.1044
-#> Var.parent_0         7.61106 -3.34955 18.5717
-#> Var.log_k_A1         4.64679 -2.73133 12.0249
-#> Var.f_parent_qlogis  0.19693 -0.05498  0.4488
-#> Var.log_k1           2.01717 -0.51980  4.5542
-#> Var.log_k2           3.63412 -0.92964  8.1979
-#> Var.g_qlogis         0.20045 -0.97425  1.3751
-#> a.1                  1.88335  1.66636  2.1004
-#> SD.parent_0          2.75881  0.77234  4.7453
-#> SD.log_k_A1          2.15564  0.44429  3.8670
-#> SD.f_parent_qlogis   0.44377  0.15994  0.7276
-#> SD.log_k1            1.42027  0.52714  2.3134
-#> SD.log_k2            1.90634  0.70934  3.1033
-#> SD.g_qlogis          0.44771 -0.86417  1.7596
plot(f_saem_dfop_sfo)
+#> parent_0            93.80521 91.22487 96.3856
+#> log_k_A1            -6.06244 -8.26517 -3.8597
+#> f_parent_qlogis     -0.97319 -1.37024 -0.5761
+#> log_k1              -2.55394 -4.00815 -1.0997
+#> log_k2              -3.47160 -5.18763 -1.7556
+#> g_qlogis            -0.09324 -1.42737  1.2409
+#> Var.parent_0         7.42157 -3.25683 18.1000
+#> Var.log_k_A1         4.22850 -2.46339 10.9204
+#> Var.f_parent_qlogis  0.19803 -0.05541  0.4515
+#> Var.log_k1           2.28644 -0.86079  5.4337
+#> Var.log_k2           3.35626 -1.14639  7.8589
+#> Var.g_qlogis         0.20084 -1.32516  1.7268
+#> a.1                  1.88399  1.66794  2.1000
+#> SD.parent_0          2.72425  0.76438  4.6841
+#> SD.log_k_A1          2.05633  0.42919  3.6835
+#> SD.f_parent_qlogis   0.44501  0.16025  0.7298
+#> SD.log_k1            1.51210  0.47142  2.5528
+#> SD.log_k2            1.83201  0.60313  3.0609
+#> SD.g_qlogis          0.44816 -1.25437  2.1507
plot(f_saem_dfop_sfo)
 
summary(f_saem_dfop_sfo, data = TRUE)
 
#> saemix version used for fitting:      3.1.9000 
-#> mkin version used for pre-fitting:  1.0.5 
+#> mkin version used for pre-fitting:  1.1.0 
 #> R version used for fitting:         4.1.0 
-#> Date of fit:     Fri Jun 11 10:57:27 2021 
-#> Date of summary: Fri Jun 11 10:57:27 2021 
+#> Date of fit:     Tue Jul 27 16:31:39 2021 
+#> Date of summary: Tue Jul 27 16:31:39 2021 
 #> 
 #> Equations:
 #> d_parent/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 *
@@ -448,13 +448,13 @@ using mmkin.

 #> 
 #> Model predictions using solution type analytical 
 #> 
-#> Fitted in 9.712 s using 300, 100 iterations
+#> Fitted in 9.479 s using 300, 100 iterations
 #> 
 #> Variance model: Constant variance 
 #> 
 #> Mean of starting values for individual parameters:
 #>        parent_0        log_k_A1 f_parent_qlogis          log_k1          log_k2 
-#>         93.8102         -9.7647         -0.9711         -1.8799         -4.2708 
+#>         93.8102         -5.3734         -0.9711         -1.8799         -4.2708 
 #>        g_qlogis 
 #>          0.1356 
 #> 
@@ -465,46 +465,46 @@ using mmkin.

 #> 
 #> Likelihood computed by importance sampling
 #>     AIC   BIC logLik
-#>   841.6 836.5 -407.8
+#>   839.6 834.6 -406.8
 #> 
 #> Optimised parameters:
 #>                     est.  lower   upper
-#> parent_0        93.76647 91.153 96.3798
-#> log_k_A1        -6.13235 -8.458 -3.8068
-#> f_parent_qlogis -0.97364 -1.369 -0.5779
-#> log_k1          -2.53176 -3.804 -1.2598
-#> log_k2          -3.58667 -5.295 -1.8781
-#> g_qlogis         0.01238 -1.080  1.1044
+#> parent_0        93.80521 91.225 96.3856
+#> log_k_A1        -6.06244 -8.265 -3.8597
+#> f_parent_qlogis -0.97319 -1.370 -0.5761
+#> log_k1          -2.55394 -4.008 -1.0997
+#> log_k2          -3.47160 -5.188 -1.7556
+#> g_qlogis        -0.09324 -1.427  1.2409
 #> 
 #> Correlation: 
 #>                 prnt_0 lg__A1 f_prn_ log_k1 log_k2
-#> log_k_A1        -0.013                            
-#> f_parent_qlogis -0.025  0.050                     
-#> log_k1           0.030  0.000 -0.005              
-#> log_k2           0.010  0.005 -0.003  0.032       
-#> g_qlogis        -0.063 -0.015  0.010 -0.167 -0.177
+#> log_k_A1        -0.014                            
+#> f_parent_qlogis -0.025  0.054                     
+#> log_k1           0.027 -0.003 -0.005              
+#> log_k2           0.011  0.005 -0.002 -0.070       
+#> g_qlogis        -0.067 -0.009  0.011 -0.189 -0.171
 #> 
 #> Random effects:
 #>                      est.   lower  upper
-#> SD.parent_0        2.7588  0.7723 4.7453
-#> SD.log_k_A1        2.1556  0.4443 3.8670
-#> SD.f_parent_qlogis 0.4438  0.1599 0.7276
-#> SD.log_k1          1.4203  0.5271 2.3134
-#> SD.log_k2          1.9063  0.7093 3.1033
-#> SD.g_qlogis        0.4477 -0.8642 1.7596
+#> SD.parent_0        2.7243  0.7644 4.6841
+#> SD.log_k_A1        2.0563  0.4292 3.6835
+#> SD.f_parent_qlogis 0.4450  0.1602 0.7298
+#> SD.log_k1          1.5121  0.4714 2.5528
+#> SD.log_k2          1.8320  0.6031 3.0609
+#> SD.g_qlogis        0.4482 -1.2544 2.1507
 #> 
 #> Variance model:
 #>      est. lower upper
-#> a.1 1.883 1.666   2.1
+#> a.1 1.884 1.668   2.1
 #> 
 #> Backtransformed parameters:
 #>                     est.     lower    upper
-#> parent_0       93.766473 9.115e+01 96.37983
-#> k_A1            0.002171 2.122e-04  0.02222
-#> f_parent_to_A1  0.274156 2.027e-01  0.35942
-#> k1              0.079519 2.229e-02  0.28371
-#> k2              0.027691 5.015e-03  0.15288
-#> g               0.503095 2.536e-01  0.75109
+#> parent_0       93.805214 9.122e+01 96.38556
+#> k_A1            0.002329 2.573e-04  0.02107
+#> f_parent_to_A1  0.274245 2.026e-01  0.35982
+#> k1              0.077775 1.817e-02  0.33296
+#> k2              0.031067 5.585e-03  0.17281
+#> g               0.476707 1.935e-01  0.77572
 #> 
 #> Resulting formation fractions:
 #>                 ff
@@ -512,182 +512,182 @@ using mmkin.

 #> parent_sink 0.7258
 #> 
 #> Estimated disappearance times:
-#>          DT50    DT90 DT50back DT50_k1 DT50_k2
-#> parent  14.11   59.53    17.92   8.717   25.03
-#> A1     319.21 1060.38       NA      NA      NA
+#>          DT50  DT90 DT50back DT50_k1 DT50_k2
+#> parent  13.96  55.4    16.68   8.912   22.31
+#> A1     297.65 988.8       NA      NA      NA
 #> 
 #> Data:
-#>          ds   name time observed predicted residual   std standardized
-#>   Dataset 6 parent    0     97.2  95.79523  1.40477 1.883     0.745888
-#>   Dataset 6 parent    0     96.4  95.79523  0.60477 1.883     0.321114
-#>   Dataset 6 parent    3     71.1  71.32042 -0.22042 1.883    -0.117035
-#>   Dataset 6 parent    3     69.2  71.32042 -2.12042 1.883    -1.125873
-#>   Dataset 6 parent    6     58.1  56.45256  1.64744 1.883     0.874739
-#>   Dataset 6 parent    6     56.6  56.45256  0.14744 1.883     0.078288
-#>   Dataset 6 parent   10     44.4  44.48523 -0.08523 1.883    -0.045257
-#>   Dataset 6 parent   10     43.4  44.48523 -1.08523 1.883    -0.576224
-#>   Dataset 6 parent   20     33.3  29.75774  3.54226 1.883     1.880826
-#>   Dataset 6 parent   20     29.2  29.75774 -0.55774 1.883    -0.296141
-#>   Dataset 6 parent   34     17.6  19.35710 -1.75710 1.883    -0.932966
-#>   Dataset 6 parent   34     18.0  19.35710 -1.35710 1.883    -0.720579
-#>   Dataset 6 parent   55     10.5  10.48443  0.01557 1.883     0.008266
-#>   Dataset 6 parent   55      9.3  10.48443 -1.18443 1.883    -0.628895
-#>   Dataset 6 parent   90      4.5   3.78622  0.71378 1.883     0.378995
-#>   Dataset 6 parent   90      4.7   3.78622  0.91378 1.883     0.485188
-#>   Dataset 6 parent  112      3.0   1.99608  1.00392 1.883     0.533048
-#>   Dataset 6 parent  112      3.4   1.99608  1.40392 1.883     0.745435
-#>   Dataset 6 parent  132      2.3   1.11539  1.18461 1.883     0.628990
-#>   Dataset 6 parent  132      2.7   1.11539  1.58461 1.883     0.841377
-#>   Dataset 6     A1    3      4.3   4.66132 -0.36132 1.883    -0.191849
-#>   Dataset 6     A1    3      4.6   4.66132 -0.06132 1.883    -0.032559
-#>   Dataset 6     A1    6      7.0   7.41087 -0.41087 1.883    -0.218157
-#>   Dataset 6     A1    6      7.2   7.41087 -0.21087 1.883    -0.111964
-#>   Dataset 6     A1   10      8.2   9.50878 -1.30878 1.883    -0.694921
-#>   Dataset 6     A1   10      8.0   9.50878 -1.50878 1.883    -0.801114
-#>   Dataset 6     A1   20     11.0  11.69902 -0.69902 1.883    -0.371157
-#>   Dataset 6     A1   20     13.7  11.69902  2.00098 1.883     1.062455
-#>   Dataset 6     A1   34     11.5  12.67784 -1.17784 1.883    -0.625396
-#>   Dataset 6     A1   34     12.7  12.67784  0.02216 1.883     0.011765
-#>   Dataset 6     A1   55     14.9  12.78556  2.11444 1.883     1.122701
-#>   Dataset 6     A1   55     14.5  12.78556  1.71444 1.883     0.910314
-#>   Dataset 6     A1   90     12.1  11.52954  0.57046 1.883     0.302898
-#>   Dataset 6     A1   90     12.3  11.52954  0.77046 1.883     0.409092
-#>   Dataset 6     A1  112      9.9  10.43825 -0.53825 1.883    -0.285793
-#>   Dataset 6     A1  112     10.2  10.43825 -0.23825 1.883    -0.126503
-#>   Dataset 6     A1  132      8.8   9.42830 -0.62830 1.883    -0.333609
-#>   Dataset 6     A1  132      7.8   9.42830 -1.62830 1.883    -0.864577
-#>   Dataset 7 parent    0     93.6  90.91477  2.68523 1.883     1.425772
-#>   Dataset 7 parent    0     92.3  90.91477  1.38523 1.883     0.735514
-#>   Dataset 7 parent    3     87.0  84.76874  2.23126 1.883     1.184726
-#>   Dataset 7 parent    3     82.2  84.76874 -2.56874 1.883    -1.363919
-#>   Dataset 7 parent    7     74.0  77.62735 -3.62735 1.883    -1.926003
-#>   Dataset 7 parent    7     73.9  77.62735 -3.72735 1.883    -1.979100
-#>   Dataset 7 parent   14     64.2  67.52266 -3.32266 1.883    -1.764224
-#>   Dataset 7 parent   14     69.5  67.52266  1.97734 1.883     1.049904
-#>   Dataset 7 parent   30     54.0  52.41949  1.58051 1.883     0.839202
-#>   Dataset 7 parent   30     54.6  52.41949  2.18051 1.883     1.157783
-#>   Dataset 7 parent   60     41.1  39.36582  1.73418 1.883     0.920794
-#>   Dataset 7 parent   60     38.4  39.36582 -0.96582 1.883    -0.512818
-#>   Dataset 7 parent   90     32.5  33.75388 -1.25388 1.883    -0.665771
-#>   Dataset 7 parent   90     35.5  33.75388  1.74612 1.883     0.927132
-#>   Dataset 7 parent  120     28.1  30.41716 -2.31716 1.883    -1.230335
-#>   Dataset 7 parent  120     29.0  30.41716 -1.41716 1.883    -0.752464
-#>   Dataset 7 parent  180     26.5  25.66046  0.83954 1.883     0.445767
-#>   Dataset 7 parent  180     27.6  25.66046  1.93954 1.883     1.029832
-#>   Dataset 7     A1    3      3.9   2.69355  1.20645 1.883     0.640585
-#>   Dataset 7     A1    3      3.1   2.69355  0.40645 1.883     0.215811
-#>   Dataset 7     A1    7      6.9   5.81807  1.08193 1.883     0.574470
-#>   Dataset 7     A1    7      6.6   5.81807  0.78193 1.883     0.415180
-#>   Dataset 7     A1   14     10.4  10.22529  0.17471 1.883     0.092767
-#>   Dataset 7     A1   14      8.3  10.22529 -1.92529 1.883    -1.022265
-#>   Dataset 7     A1   30     14.4  16.75484 -2.35484 1.883    -1.250345
-#>   Dataset 7     A1   30     13.7  16.75484 -3.05484 1.883    -1.622022
-#>   Dataset 7     A1   60     22.1  22.22540 -0.12540 1.883    -0.066583
-#>   Dataset 7     A1   60     22.3  22.22540  0.07460 1.883     0.039610
-#>   Dataset 7     A1   90     27.5  24.38799  3.11201 1.883     1.652376
-#>   Dataset 7     A1   90     25.4  24.38799  1.01201 1.883     0.537344
-#>   Dataset 7     A1  120     28.0  25.53294  2.46706 1.883     1.309927
-#>   Dataset 7     A1  120     26.6  25.53294  1.06706 1.883     0.566572
-#>   Dataset 7     A1  180     25.8  26.94943 -1.14943 1.883    -0.610309
-#>   Dataset 7     A1  180     25.3  26.94943 -1.64943 1.883    -0.875793
-#>   Dataset 8 parent    0     91.9  91.53246  0.36754 1.883     0.195151
-#>   Dataset 8 parent    0     90.8  91.53246 -0.73246 1.883    -0.388914
-#>   Dataset 8 parent    1     64.9  67.73197 -2.83197 1.883    -1.503686
-#>   Dataset 8 parent    1     66.2  67.73197 -1.53197 1.883    -0.813428
-#>   Dataset 8 parent    3     43.5  41.58448  1.91552 1.883     1.017081
-#>   Dataset 8 parent    3     44.1  41.58448  2.51552 1.883     1.335662
-#>   Dataset 8 parent    8     18.3  19.62286 -1.32286 1.883    -0.702395
-#>   Dataset 8 parent    8     18.1  19.62286 -1.52286 1.883    -0.808588
-#>   Dataset 8 parent   14     10.2  10.77819 -0.57819 1.883    -0.306999
-#>   Dataset 8 parent   14     10.8  10.77819  0.02181 1.883     0.011582
-#>   Dataset 8 parent   27      4.9   3.26977  1.63023 1.883     0.865599
-#>   Dataset 8 parent   27      3.3   3.26977  0.03023 1.883     0.016051
-#>   Dataset 8 parent   48      1.6   0.48024  1.11976 1.883     0.594557
-#>   Dataset 8 parent   48      1.5   0.48024  1.01976 1.883     0.541460
-#>   Dataset 8 parent   70      1.1   0.06438  1.03562 1.883     0.549881
-#>   Dataset 8 parent   70      0.9   0.06438  0.83562 1.883     0.443688
-#>   Dataset 8     A1    1      9.6   7.61539  1.98461 1.883     1.053761
-#>   Dataset 8     A1    1      7.7   7.61539  0.08461 1.883     0.044923
-#>   Dataset 8     A1    3     15.0  15.47954 -0.47954 1.883    -0.254622
-#>   Dataset 8     A1    3     15.1  15.47954 -0.37954 1.883    -0.201525
-#>   Dataset 8     A1    8     21.2  20.22616  0.97384 1.883     0.517075
-#>   Dataset 8     A1    8     21.1  20.22616  0.87384 1.883     0.463979
-#>   Dataset 8     A1   14     19.7  20.00067 -0.30067 1.883    -0.159645
-#>   Dataset 8     A1   14     18.9  20.00067 -1.10067 1.883    -0.584419
-#>   Dataset 8     A1   27     17.5  16.38142  1.11858 1.883     0.593928
-#>   Dataset 8     A1   27     15.9  16.38142 -0.48142 1.883    -0.255620
-#>   Dataset 8     A1   48      9.5  10.25357 -0.75357 1.883    -0.400124
-#>   Dataset 8     A1   48      9.8  10.25357 -0.45357 1.883    -0.240833
-#>   Dataset 8     A1   70      6.2   5.95728  0.24272 1.883     0.128878
-#>   Dataset 8     A1   70      6.1   5.95728  0.14272 1.883     0.075781
-#>   Dataset 9 parent    0     99.8  97.47274  2.32726 1.883     1.235697
-#>   Dataset 9 parent    0     98.3  97.47274  0.82726 1.883     0.439246
-#>   Dataset 9 parent    1     77.1  79.72257 -2.62257 1.883    -1.392500
-#>   Dataset 9 parent    1     77.2  79.72257 -2.52257 1.883    -1.339404
-#>   Dataset 9 parent    3     59.0  56.26497  2.73503 1.883     1.452212
-#>   Dataset 9 parent    3     58.1  56.26497  1.83503 1.883     0.974342
-#>   Dataset 9 parent    8     27.4  31.66985 -4.26985 1.883    -2.267151
-#>   Dataset 9 parent    8     29.2  31.66985 -2.46985 1.883    -1.311410
-#>   Dataset 9 parent   14     19.1  22.39789 -3.29789 1.883    -1.751071
-#>   Dataset 9 parent   14     29.6  22.39789  7.20211 1.883     3.824090
-#>   Dataset 9 parent   27     10.1  14.21758 -4.11758 1.883    -2.186301
-#>   Dataset 9 parent   27     18.2  14.21758  3.98242 1.883     2.114537
-#>   Dataset 9 parent   48      4.5   7.27921 -2.77921 1.883    -1.475671
-#>   Dataset 9 parent   48      9.1   7.27921  1.82079 1.883     0.966780
-#>   Dataset 9 parent   70      2.3   3.61470 -1.31470 1.883    -0.698065
-#>   Dataset 9 parent   70      2.9   3.61470 -0.71470 1.883    -0.379485
-#>   Dataset 9 parent   91      2.0   1.85303  0.14697 1.883     0.078038
-#>   Dataset 9 parent   91      1.8   1.85303 -0.05303 1.883    -0.028155
-#>   Dataset 9 parent  120      2.0   0.73645  1.26355 1.883     0.670906
-#>   Dataset 9 parent  120      2.2   0.73645  1.46355 1.883     0.777099
-#>   Dataset 9     A1    1      4.2   3.87843  0.32157 1.883     0.170743
-#>   Dataset 9     A1    1      3.9   3.87843  0.02157 1.883     0.011453
-#>   Dataset 9     A1    3      7.4   8.90535 -1.50535 1.883    -0.799291
-#>   Dataset 9     A1    3      7.9   8.90535 -1.00535 1.883    -0.533807
-#>   Dataset 9     A1    8     14.5  13.75172  0.74828 1.883     0.397312
-#>   Dataset 9     A1    8     13.7  13.75172 -0.05172 1.883    -0.027462
-#>   Dataset 9     A1   14     14.2  14.97541 -0.77541 1.883    -0.411715
-#>   Dataset 9     A1   14     12.2  14.97541 -2.77541 1.883    -1.473650
-#>   Dataset 9     A1   27     13.7  14.94728 -1.24728 1.883    -0.662266
-#>   Dataset 9     A1   27     13.2  14.94728 -1.74728 1.883    -0.927750
-#>   Dataset 9     A1   48     13.6  13.66078 -0.06078 1.883    -0.032272
-#>   Dataset 9     A1   48     15.4  13.66078  1.73922 1.883     0.923470
-#>   Dataset 9     A1   70     10.4  11.84899 -1.44899 1.883    -0.769365
-#>   Dataset 9     A1   70     11.6  11.84899 -0.24899 1.883    -0.132204
-#>   Dataset 9     A1   91     10.0  10.09177 -0.09177 1.883    -0.048727
-#>   Dataset 9     A1   91      9.5  10.09177 -0.59177 1.883    -0.314211
-#>   Dataset 9     A1  120      9.1   7.91379  1.18621 1.883     0.629841
-#>   Dataset 9     A1  120      9.0   7.91379  1.08621 1.883     0.576744
-#>  Dataset 10 parent    0     96.1  93.65257  2.44743 1.883     1.299505
-#>  Dataset 10 parent    0     94.3  93.65257  0.64743 1.883     0.343763
-#>  Dataset 10 parent    8     73.9  77.85906 -3.95906 1.883    -2.102132
-#>  Dataset 10 parent    8     73.9  77.85906 -3.95906 1.883    -2.102132
-#>  Dataset 10 parent   14     69.4  70.17143 -0.77143 1.883    -0.409606
-#>  Dataset 10 parent   14     73.1  70.17143  2.92857 1.883     1.554974
-#>  Dataset 10 parent   21     65.6  63.99188  1.60812 1.883     0.853862
-#>  Dataset 10 parent   21     65.3  63.99188  1.30812 1.883     0.694572
-#>  Dataset 10 parent   41     55.9  54.64292  1.25708 1.883     0.667467
-#>  Dataset 10 parent   41     54.4  54.64292 -0.24292 1.883    -0.128985
-#>  Dataset 10 parent   63     47.0  49.61303 -2.61303 1.883    -1.387433
-#>  Dataset 10 parent   63     49.3  49.61303 -0.31303 1.883    -0.166207
-#>  Dataset 10 parent   91     44.7  45.17807 -0.47807 1.883    -0.253839
-#>  Dataset 10 parent   91     46.7  45.17807  1.52193 1.883     0.808096
-#>  Dataset 10 parent  120     42.1  41.27970  0.82030 1.883     0.435552
-#>  Dataset 10 parent  120     41.3  41.27970  0.02030 1.883     0.010778
-#>  Dataset 10     A1    8      3.3   3.99294 -0.69294 1.883    -0.367929
-#>  Dataset 10     A1    8      3.4   3.99294 -0.59294 1.883    -0.314832
-#>  Dataset 10     A1   14      3.9   5.92756 -2.02756 1.883    -1.076570
-#>  Dataset 10     A1   14      2.9   5.92756 -3.02756 1.883    -1.607538
-#>  Dataset 10     A1   21      6.4   7.47313 -1.07313 1.883    -0.569799
-#>  Dataset 10     A1   21      7.2   7.47313 -0.27313 1.883    -0.145025
-#>  Dataset 10     A1   41      9.1   9.76819 -0.66819 1.883    -0.354786
-#>  Dataset 10     A1   41      8.5   9.76819 -1.26819 1.883    -0.673367
-#>  Dataset 10     A1   63     11.7  10.94733  0.75267 1.883     0.399643
-#>  Dataset 10     A1   63     12.0  10.94733  1.05267 1.883     0.558933
-#>  Dataset 10     A1   91     13.3  11.93773  1.36227 1.883     0.723321
-#>  Dataset 10     A1   91     13.2  11.93773  1.26227 1.883     0.670224
-#>  Dataset 10     A1  120     14.3  12.77666  1.52334 1.883     0.808847
-#>  Dataset 10     A1  120     12.1  12.77666 -0.67666 1.883    -0.359282

+#>          ds   name time observed predicted  residual   std standardized
+#>   Dataset 6 parent    0     97.2  95.75408  1.445920 1.884     0.767479
+#>   Dataset 6 parent    0     96.4  95.75408  0.645920 1.884     0.342847
+#>   Dataset 6 parent    3     71.1  71.22466 -0.124662 1.884    -0.066169
+#>   Dataset 6 parent    3     69.2  71.22466 -2.024662 1.884    -1.074669
+#>   Dataset 6 parent    6     58.1  56.42290  1.677100 1.884     0.890187
+#>   Dataset 6 parent    6     56.6  56.42290  0.177100 1.884     0.094003
+#>   Dataset 6 parent   10     44.4  44.55255 -0.152554 1.884    -0.080974
+#>   Dataset 6 parent   10     43.4  44.55255 -1.152554 1.884    -0.611763
+#>   Dataset 6 parent   20     33.3  29.88846  3.411537 1.884     1.810807
+#>   Dataset 6 parent   20     29.2  29.88846 -0.688463 1.884    -0.365429
+#>   Dataset 6 parent   34     17.6  19.40826 -1.808260 1.884    -0.959805
+#>   Dataset 6 parent   34     18.0  19.40826 -1.408260 1.884    -0.747489
+#>   Dataset 6 parent   55     10.5  10.45560  0.044398 1.884     0.023566
+#>   Dataset 6 parent   55      9.3  10.45560 -1.155602 1.884    -0.613381
+#>   Dataset 6 parent   90      4.5   3.74026  0.759744 1.884     0.403264
+#>   Dataset 6 parent   90      4.7   3.74026  0.959744 1.884     0.509421
+#>   Dataset 6 parent  112      3.0   1.96015  1.039853 1.884     0.551943
+#>   Dataset 6 parent  112      3.4   1.96015  1.439853 1.884     0.764258
+#>   Dataset 6 parent  132      2.3   1.08940  1.210603 1.884     0.642575
+#>   Dataset 6 parent  132      2.7   1.08940  1.610603 1.884     0.854890
+#>   Dataset 6     A1    3      4.3   4.75601 -0.456009 1.884    -0.242045
+#>   Dataset 6     A1    3      4.6   4.75601 -0.156009 1.884    -0.082808
+#>   Dataset 6     A1    6      7.0   7.53839 -0.538391 1.884    -0.285772
+#>   Dataset 6     A1    6      7.2   7.53839 -0.338391 1.884    -0.179614
+#>   Dataset 6     A1   10      8.2   9.64728 -1.447276 1.884    -0.768198
+#>   Dataset 6     A1   10      8.0   9.64728 -1.647276 1.884    -0.874356
+#>   Dataset 6     A1   20     11.0  11.83954 -0.839545 1.884    -0.445621
+#>   Dataset 6     A1   20     13.7  11.83954  1.860455 1.884     0.987509
+#>   Dataset 6     A1   34     11.5  12.81233 -1.312327 1.884    -0.696569
+#>   Dataset 6     A1   34     12.7  12.81233 -0.112327 1.884    -0.059622
+#>   Dataset 6     A1   55     14.9  12.87919  2.020809 1.884     1.072624
+#>   Dataset 6     A1   55     14.5  12.87919  1.620809 1.884     0.860308
+#>   Dataset 6     A1   90     12.1  11.52464  0.575364 1.884     0.305397
+#>   Dataset 6     A1   90     12.3  11.52464  0.775364 1.884     0.411555
+#>   Dataset 6     A1  112      9.9  10.37694 -0.476938 1.884    -0.253153
+#>   Dataset 6     A1  112     10.2  10.37694 -0.176938 1.884    -0.093917
+#>   Dataset 6     A1  132      8.8   9.32474 -0.524742 1.884    -0.278528
+#>   Dataset 6     A1  132      7.8   9.32474 -1.524742 1.884    -0.809317
+#>   Dataset 7 parent    0     93.6  90.16918  3.430816 1.884     1.821040
+#>   Dataset 7 parent    0     92.3  90.16918  2.130816 1.884     1.131014
+#>   Dataset 7 parent    3     87.0  84.05442  2.945583 1.884     1.563483
+#>   Dataset 7 parent    3     82.2  84.05442 -1.854417 1.884    -0.984304
+#>   Dataset 7 parent    7     74.0  77.00960 -3.009596 1.884    -1.597461
+#>   Dataset 7 parent    7     73.9  77.00960 -3.109596 1.884    -1.650540
+#>   Dataset 7 parent   14     64.2  67.15684 -2.956840 1.884    -1.569459
+#>   Dataset 7 parent   14     69.5  67.15684  2.343160 1.884     1.243724
+#>   Dataset 7 parent   30     54.0  52.66290  1.337101 1.884     0.709719
+#>   Dataset 7 parent   30     54.6  52.66290  1.937101 1.884     1.028192
+#>   Dataset 7 parent   60     41.1  40.04995  1.050050 1.884     0.557355
+#>   Dataset 7 parent   60     38.4  40.04995 -1.649950 1.884    -0.875775
+#>   Dataset 7 parent   90     32.5  34.09675 -1.596746 1.884    -0.847535
+#>   Dataset 7 parent   90     35.5  34.09675  1.403254 1.884     0.744832
+#>   Dataset 7 parent  120     28.1  30.12281 -2.022814 1.884    -1.073688
+#>   Dataset 7 parent  120     29.0  30.12281 -1.122814 1.884    -0.595977
+#>   Dataset 7 parent  180     26.5  24.10888  2.391123 1.884     1.269182
+#>   Dataset 7 parent  180     27.6  24.10888  3.491123 1.884     1.853050
+#>   Dataset 7     A1    3      3.9   2.77684  1.123161 1.884     0.596161
+#>   Dataset 7     A1    3      3.1   2.77684  0.323161 1.884     0.171530
+#>   Dataset 7     A1    7      6.9   5.96705  0.932950 1.884     0.495200
+#>   Dataset 7     A1    7      6.6   5.96705  0.632950 1.884     0.335963
+#>   Dataset 7     A1   14     10.4  10.40535 -0.005348 1.884    -0.002839
+#>   Dataset 7     A1   14      8.3  10.40535 -2.105348 1.884    -1.117496
+#>   Dataset 7     A1   30     14.4  16.83722 -2.437216 1.884    -1.293648
+#>   Dataset 7     A1   30     13.7  16.83722 -3.137216 1.884    -1.665200
+#>   Dataset 7     A1   60     22.1  22.15018 -0.050179 1.884    -0.026635
+#>   Dataset 7     A1   60     22.3  22.15018  0.149821 1.884     0.079523
+#>   Dataset 7     A1   90     27.5  24.36286  3.137143 1.884     1.665161
+#>   Dataset 7     A1   90     25.4  24.36286  1.037143 1.884     0.550504
+#>   Dataset 7     A1  120     28.0  25.64064  2.359361 1.884     1.252323
+#>   Dataset 7     A1  120     26.6  25.64064  0.959361 1.884     0.509218
+#>   Dataset 7     A1  180     25.8  27.25486 -1.454858 1.884    -0.772223
+#>   Dataset 7     A1  180     25.3  27.25486 -1.954858 1.884    -1.037617
+#>   Dataset 8 parent    0     91.9  91.72652  0.173479 1.884     0.092081
+#>   Dataset 8 parent    0     90.8  91.72652 -0.926521 1.884    -0.491787
+#>   Dataset 8 parent    1     64.9  67.22810 -2.328104 1.884    -1.235732
+#>   Dataset 8 parent    1     66.2  67.22810 -1.028104 1.884    -0.545706
+#>   Dataset 8 parent    3     43.5  41.46375  2.036251 1.884     1.080820
+#>   Dataset 8 parent    3     44.1  41.46375  2.636251 1.884     1.399293
+#>   Dataset 8 parent    8     18.3  19.83597 -1.535968 1.884    -0.815275
+#>   Dataset 8 parent    8     18.1  19.83597 -1.735968 1.884    -0.921433
+#>   Dataset 8 parent   14     10.2  10.34793 -0.147927 1.884    -0.078518
+#>   Dataset 8 parent   14     10.8  10.34793  0.452073 1.884     0.239956
+#>   Dataset 8 parent   27      4.9   2.67641  2.223595 1.884     1.180260
+#>   Dataset 8 parent   27      3.3   2.67641  0.623595 1.884     0.330997
+#>   Dataset 8 parent   48      1.6   0.30218  1.297822 1.884     0.688870
+#>   Dataset 8 parent   48      1.5   0.30218  1.197822 1.884     0.635791
+#>   Dataset 8 parent   70      1.1   0.03075  1.069248 1.884     0.567545
+#>   Dataset 8 parent   70      0.9   0.03075  0.869248 1.884     0.461388
+#>   Dataset 8     A1    1      9.6   7.74066  1.859342 1.884     0.986918
+#>   Dataset 8     A1    1      7.7   7.74066 -0.040658 1.884    -0.021581
+#>   Dataset 8     A1    3     15.0  15.37549 -0.375495 1.884    -0.199309
+#>   Dataset 8     A1    3     15.1  15.37549 -0.275495 1.884    -0.146230
+#>   Dataset 8     A1    8     21.2  19.95900  1.241003 1.884     0.658711
+#>   Dataset 8     A1    8     21.1  19.95900  1.141003 1.884     0.605632
+#>   Dataset 8     A1   14     19.7  19.92898 -0.228978 1.884    -0.121539
+#>   Dataset 8     A1   14     18.9  19.92898 -1.028978 1.884    -0.546170
+#>   Dataset 8     A1   27     17.5  16.34046  1.159536 1.884     0.615469
+#>   Dataset 8     A1   27     15.9  16.34046 -0.440464 1.884    -0.233793
+#>   Dataset 8     A1   48      9.5  10.12131 -0.621313 1.884    -0.329786
+#>   Dataset 8     A1   48      9.8  10.12131 -0.321313 1.884    -0.170550
+#>   Dataset 8     A1   70      6.2   5.84753  0.352469 1.884     0.187087
+#>   Dataset 8     A1   70      6.1   5.84753  0.252469 1.884     0.134008
+#>   Dataset 9 parent    0     99.8  98.23600  1.564002 1.884     0.830155
+#>   Dataset 9 parent    0     98.3  98.23600  0.064002 1.884     0.033972
+#>   Dataset 9 parent    1     77.1  79.68007 -2.580074 1.884    -1.369475
+#>   Dataset 9 parent    1     77.2  79.68007 -2.480074 1.884    -1.316396
+#>   Dataset 9 parent    3     59.0  55.81142  3.188584 1.884     1.692465
+#>   Dataset 9 parent    3     58.1  55.81142  2.288584 1.884     1.214755
+#>   Dataset 9 parent    8     27.4  31.81995 -4.419948 1.884    -2.346060
+#>   Dataset 9 parent    8     29.2  31.81995 -2.619948 1.884    -1.390640
+#>   Dataset 9 parent   14     19.1  22.78328 -3.683282 1.884    -1.955046
+#>   Dataset 9 parent   14     29.6  22.78328  6.816718 1.884     3.618240
+#>   Dataset 9 parent   27     10.1  14.15172 -4.051720 1.884    -2.150609
+#>   Dataset 9 parent   27     18.2  14.15172  4.048280 1.884     2.148783
+#>   Dataset 9 parent   48      4.5   6.86094 -2.360941 1.884    -1.253162
+#>   Dataset 9 parent   48      9.1   6.86094  2.239059 1.884     1.188468
+#>   Dataset 9 parent   70      2.3   3.21580 -0.915798 1.884    -0.486096
+#>   Dataset 9 parent   70      2.9   3.21580 -0.315798 1.884    -0.167622
+#>   Dataset 9 parent   91      2.0   1.56010  0.439897 1.884     0.233492
+#>   Dataset 9 parent   91      1.8   1.56010  0.239897 1.884     0.127335
+#>   Dataset 9 parent  120      2.0   0.57458  1.425424 1.884     0.756600
+#>   Dataset 9 parent  120      2.2   0.57458  1.625424 1.884     0.862757
+#>   Dataset 9     A1    1      4.2   4.01796  0.182037 1.884     0.096623
+#>   Dataset 9     A1    1      3.9   4.01796 -0.117963 1.884    -0.062613
+#>   Dataset 9     A1    3      7.4   9.08527 -1.685270 1.884    -0.894523
+#>   Dataset 9     A1    3      7.9   9.08527 -1.185270 1.884    -0.629129
+#>   Dataset 9     A1    8     14.5  13.75054  0.749457 1.884     0.397804
+#>   Dataset 9     A1    8     13.7  13.75054 -0.050543 1.884    -0.026827
+#>   Dataset 9     A1   14     14.2  14.91180 -0.711804 1.884    -0.377818
+#>   Dataset 9     A1   14     12.2  14.91180 -2.711804 1.884    -1.439396
+#>   Dataset 9     A1   27     13.7  14.97813 -1.278129 1.884    -0.678417
+#>   Dataset 9     A1   27     13.2  14.97813 -1.778129 1.884    -0.943812
+#>   Dataset 9     A1   48     13.6  13.75574 -0.155745 1.884    -0.082668
+#>   Dataset 9     A1   48     15.4  13.75574  1.644255 1.884     0.872753
+#>   Dataset 9     A1   70     10.4  11.92861 -1.528608 1.884    -0.811369
+#>   Dataset 9     A1   70     11.6  11.92861 -0.328608 1.884    -0.174422
+#>   Dataset 9     A1   91     10.0  10.14395 -0.143947 1.884    -0.076405
+#>   Dataset 9     A1   91      9.5  10.14395 -0.643947 1.884    -0.341800
+#>   Dataset 9     A1  120      9.1   7.93869  1.161307 1.884     0.616409
+#>   Dataset 9     A1  120      9.0   7.93869  1.061307 1.884     0.563330
+#>  Dataset 10 parent    0     96.1  93.65914  2.440862 1.884     1.295583
+#>  Dataset 10 parent    0     94.3  93.65914  0.640862 1.884     0.340163
+#>  Dataset 10 parent    8     73.9  77.83065 -3.930647 1.884    -2.086344
+#>  Dataset 10 parent    8     73.9  77.83065 -3.930647 1.884    -2.086344
+#>  Dataset 10 parent   14     69.4  70.15862 -0.758619 1.884    -0.402667
+#>  Dataset 10 parent   14     73.1  70.15862  2.941381 1.884     1.561253
+#>  Dataset 10 parent   21     65.6  64.00840  1.591600 1.884     0.844804
+#>  Dataset 10 parent   21     65.3  64.00840  1.291600 1.884     0.685567
+#>  Dataset 10 parent   41     55.9  54.71192  1.188076 1.884     0.630618
+#>  Dataset 10 parent   41     54.4  54.71192 -0.311924 1.884    -0.165566
+#>  Dataset 10 parent   63     47.0  49.66775 -2.667747 1.884    -1.416011
+#>  Dataset 10 parent   63     49.3  49.66775 -0.367747 1.884    -0.195196
+#>  Dataset 10 parent   91     44.7  45.17119 -0.471186 1.884    -0.250101
+#>  Dataset 10 parent   91     46.7  45.17119  1.528814 1.884     0.811478
+#>  Dataset 10 parent  120     42.1  41.20430  0.895699 1.884     0.475427
+#>  Dataset 10 parent  120     41.3  41.20430  0.095699 1.884     0.050796
+#>  Dataset 10     A1    8      3.3   4.00920 -0.709204 1.884    -0.376438
+#>  Dataset 10     A1    8      3.4   4.00920 -0.609204 1.884    -0.323359
+#>  Dataset 10     A1   14      3.9   5.94267 -2.042668 1.884    -1.084226
+#>  Dataset 10     A1   14      2.9   5.94267 -3.042668 1.884    -1.615015
+#>  Dataset 10     A1   21      6.4   7.48222 -1.082219 1.884    -0.574430
+#>  Dataset 10     A1   21      7.2   7.48222 -0.282219 1.884    -0.149799
+#>  Dataset 10     A1   41      9.1   9.76246 -0.662460 1.884    -0.351626
+#>  Dataset 10     A1   41      8.5   9.76246 -1.262460 1.884    -0.670100
+#>  Dataset 10     A1   63     11.7  10.93972  0.760278 1.884     0.403547
+#>  Dataset 10     A1   63     12.0  10.93972  1.060278 1.884     0.562784
+#>  Dataset 10     A1   91     13.3  11.93666  1.363337 1.884     0.723645
+#>  Dataset 10     A1   91     13.2  11.93666  1.263337 1.884     0.670566
+#>  Dataset 10     A1  120     14.3  12.78218  1.517817 1.884     0.805641
+#>  Dataset 10     A1  120     12.1  12.78218 -0.682183 1.884    -0.362095

 # The following takes about 6 minutes
 #f_saem_dfop_sfo_deSolve <- saem(f_mmkin["DFOP-SFO", ], solution_type = "deSolve",
 #  control = list(nbiter.saemix = c(200, 80), nbdisplay = 10))
diff --git a/docs/dev/reference/summary.nlmixr.mmkin.html b/docs/dev/reference/summary.nlmixr.mmkin.html
index 0fead0df..373ce75f 100644
--- a/docs/dev/reference/summary.nlmixr.mmkin.html
+++ b/docs/dev/reference/summary.nlmixr.mmkin.html
@@ -76,7 +76,7 @@ endpoints such as formation fractions and DT50 values. Optionally
       
       
         mkin
-        1.0.5
+        1.1.0
       
     

 
@@ -258,737 +258,73 @@ nlmixr authors for the parts inherited from nlmixr.

   quiet = TRUE, error_model = "tc", cores = 5)
 f_saemix_dfop_sfo <- mkin::saem(f_mmkin_dfop_sfo)
 
#> Running main SAEM algorithm
-#> [1] "Fri Jun 11 10:57:31 2021"
+#> [1] "Tue Jul 27 16:31:43 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Fri Jun 11 10:57:43 2021"
f_nlme_dfop_sfo <- mkin::nlme(f_mmkin_dfop_sfo)
+#> [1] "Tue Jul 27 16:31:55 2021"
f_nlme_dfop_sfo <- mkin::nlme(f_mmkin_dfop_sfo)
 
#> Warning: Iteration 4, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)
#> Warning: Iteration 6, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)
f_nlmixr_dfop_sfo_saem <- nlmixr(f_mmkin_dfop_sfo, est = "saem")
-
#> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> → generate SAEM model
#> ✔ done
#> 1:    1.0127e+02  -3.8515e+00  -2.0719e+00  -3.7271e+00  -1.9335e+00   4.0311e-01   6.9594e+00   1.5021e-01   5.3947e-01   1.9686e-01   3.7429e-01   5.4209e-01   8.4121e+00   7.3391e-02   7.1185e+00   2.5869e-01
-#> 2:    1.0136e+02  -3.8005e+00  -2.3424e+00  -4.0759e+00  -1.6475e+00   1.1598e-01   6.6115e+00   1.4406e-01   5.1249e-01   1.8701e-01   3.5786e-01   5.1499e-01   4.9102e+00   6.2829e-02   4.7230e+00   7.8901e-02
-#> 3:    1.0126e+02  -4.0285e+00  -2.3629e+00  -4.1271e+00  -1.1733e+00   1.7634e-02   6.2809e+00   1.6892e-01   4.8687e-01   1.7766e-01   3.3997e-01   4.8924e-01   3.2256e+00   6.6693e-02   3.3261e+00   8.7190e-02
-#> 4:    1.0105e+02  -4.0894e+00  -2.5516e+00  -4.1037e+00  -1.0816e+00   4.5377e-02   5.9668e+00   1.6048e-01   4.6252e-01   1.6878e-01   3.2297e-01   4.6478e-01   2.4343e+00   7.0557e-02   2.2610e+00   9.2498e-02
-#> 5:    1.0101e+02  -4.1364e+00  -2.4605e+00  -4.0737e+00  -1.0920e+00  -4.7953e-03   5.9593e+00   1.5245e-01   4.3940e-01   1.8078e-01   3.0682e-01   5.4688e-01   1.7424e+00   7.4776e-02   1.5144e+00   1.0787e-01
-#> 6:    1.0042e+02  -4.0933e+00  -2.4472e+00  -4.1090e+00  -9.7996e-01  -9.0472e-02   6.0175e+00   1.4483e-01   4.1743e-01   1.8824e-01   2.9148e-01   5.3033e-01   1.5545e+00   6.8588e-02   1.3401e+00   9.8865e-02
-#> 7:    1.0078e+02  -4.0911e+00  -2.4335e+00  -4.0758e+00  -9.9422e-01  -7.8849e-02   6.6318e+00   1.3759e-01   3.9656e-01   1.7882e-01   2.7691e-01   5.0381e-01   1.3780e+00   6.9978e-02   1.1346e+00   9.6162e-02
-#> 8:    1.0077e+02  -4.0196e+00  -2.4345e+00  -4.0444e+00  -9.3483e-01  -1.1032e-01   6.3002e+00   1.3071e-01   3.7673e-01   1.6988e-01   2.6306e-01   4.8191e-01   1.1774e+00   7.4232e-02   1.0270e+00   9.5616e-02
-#> 9:    1.0118e+02  -4.0436e+00  -2.4649e+00  -4.0207e+00  -8.9829e-01  -1.7784e-01   5.9852e+00   1.2417e-01   3.5789e-01   1.6139e-01   2.4991e-01   5.5466e-01   1.1040e+00   7.1515e-02   1.0342e+00   9.3972e-02
-#> 10:    1.0143e+02  -4.0523e+00  -2.3737e+00  -4.0184e+00  -9.1167e-01  -2.3828e-01   5.8520e+00   1.1797e-01   3.4196e-01   1.5332e-01   2.3741e-01   5.2849e-01   1.0510e+00   7.5719e-02   1.0638e+00   9.3973e-02
-#> 11:    1.0119e+02  -4.0699e+00  -2.3680e+00  -4.0191e+00  -9.4858e-01  -1.7310e-01   6.9958e+00   1.1207e-01   3.6891e-01   1.4565e-01   2.2554e-01   5.0206e-01   1.0247e+00   7.5497e-02   1.0292e+00   9.3707e-02
-#> 12:    1.0121e+02  -4.0189e+00  -2.4198e+00  -4.0139e+00  -9.1693e-01  -2.0613e-01   6.6460e+00   1.0646e-01   3.5046e-01   1.3837e-01   2.1427e-01   5.7696e-01   1.1046e+00   7.6090e-02   9.3689e-01   9.4115e-02
-#> 13:    1.0083e+02  -4.0451e+00  -2.4395e+00  -4.0235e+00  -9.4535e-01  -1.4723e-01   6.3137e+00   1.0114e-01   3.3294e-01   1.3145e-01   2.0355e-01   5.4811e-01   1.0360e+00   7.3381e-02   9.7078e-01   9.1659e-02
-#> 14:    1.0056e+02  -4.0401e+00  -2.4045e+00  -4.0054e+00  -9.4191e-01  -1.3928e-01   5.9980e+00   9.6084e-02   3.4934e-01   1.2488e-01   1.9338e-01   5.2071e-01   1.0303e+00   7.7118e-02   8.8372e-01   9.0469e-02
-#> 15:    1.0070e+02  -4.0388e+00  -2.4210e+00  -4.0113e+00  -9.1136e-01  -1.2702e-01   5.6981e+00   9.1279e-02   3.3187e-01   1.1864e-01   1.8371e-01   4.9467e-01   1.0486e+00   7.2427e-02   7.8179e-01   9.1572e-02
-#> 16:    1.0078e+02  -4.0175e+00  -2.4766e+00  -4.0191e+00  -9.0733e-01  -1.1952e-01   5.4132e+00   8.6716e-02   3.1528e-01   1.1270e-01   1.7452e-01   4.8928e-01   9.7799e-01   8.1464e-02   8.2935e-01   8.6520e-02
-#> 17:    1.0069e+02  -4.0533e+00  -2.5110e+00  -4.0294e+00  -9.1841e-01  -6.8363e-03   5.1426e+00   8.2380e-02   2.9952e-01   1.0707e-01   1.6580e-01   4.6482e-01   9.1609e-01   8.1008e-02   8.1783e-01   8.8818e-02
-#> 18:    99.9647   -4.0672   -2.5327   -4.0416   -0.9273    0.0097    4.8854    0.0783    0.2970    0.1280    0.1941    0.5053    0.9306    0.0764    0.8097    0.0881
-#> 19:    1.0027e+02  -4.0667e+00  -2.4653e+00  -4.0579e+00  -9.2776e-01   3.0417e-02   4.6412e+00   7.4348e-02   3.3694e-01   1.2164e-01   1.8435e-01   5.1797e-01   9.7386e-01   7.4954e-02   7.9297e-01   8.9915e-02
-#> 20:    1.0006e+02  -4.0935e+00  -2.4804e+00  -4.0721e+00  -9.3737e-01   1.9496e-02   4.4091e+00   7.0630e-02   3.3728e-01   1.2544e-01   1.7513e-01   6.0925e-01   1.0232e+00   7.4618e-02   7.9988e-01   8.9642e-02
-#> 21:    1.0043e+02  -4.0542e+00  -2.5168e+00  -4.0623e+00  -9.1553e-01   3.9474e-02   4.1887e+00   6.7099e-02   3.4553e-01   1.1917e-01   1.6638e-01   6.0827e-01   1.0155e+00   8.0771e-02   7.8424e-01   8.6213e-02
-#> 22:    1.0049e+02  -4.0449e+00  -2.5082e+00  -4.0849e+00  -9.2553e-01   4.5424e-02   3.9792e+00   6.3744e-02   3.2825e-01   1.2365e-01   1.5806e-01   5.8922e-01   8.2860e-01   8.3384e-02   8.2525e-01   8.9218e-02
-#> 23:    1.0067e+02  -4.0411e+00  -2.5460e+00  -4.0736e+00  -9.2578e-01   5.2422e-02   3.7803e+00   6.0557e-02   3.1661e-01   1.2306e-01   1.5016e-01   5.8274e-01   9.3412e-01   8.0508e-02   8.1829e-01   8.6377e-02
-#> 24:    1.0091e+02  -4.0314e+00  -2.5298e+00  -4.0566e+00  -8.9743e-01   3.7634e-02   3.5913e+00   5.7529e-02   3.5267e-01   1.2194e-01   1.4265e-01   5.5360e-01   9.6271e-01   7.6960e-02   8.8466e-01   8.5693e-02
-#> 25:    1.0100e+02  -4.0442e+00  -2.5399e+00  -4.0568e+00  -8.9494e-01   1.7415e-02   3.4117e+00   5.4652e-02   3.3504e-01   1.2781e-01   1.3552e-01   5.2592e-01   9.6040e-01   7.7299e-02   8.9561e-01   8.6893e-02
-#> 26:    1.0111e+02  -4.0354e+00  -2.5182e+00  -4.0899e+00  -9.0799e-01   7.6464e-02   4.8614e+00   5.1920e-02   3.1829e-01   1.2142e-01   1.3110e-01   4.9963e-01   9.6997e-01   7.4932e-02   8.2521e-01   9.3659e-02
-#> 27:    1.0159e+02  -4.0653e+00  -2.4934e+00  -4.0803e+00  -9.5632e-01   2.8659e-03   4.6184e+00   4.9324e-02   3.0237e-01   1.1535e-01   1.4743e-01   4.7465e-01   9.4314e-01   7.7860e-02   8.9820e-01   8.8210e-02
-#> 28:    1.0154e+02  -4.0487e+00  -2.4844e+00  -4.0511e+00  -9.6473e-01  -4.7382e-02   4.3874e+00   4.6858e-02   3.2049e-01   1.0958e-01   1.5243e-01   4.5091e-01   9.8808e-01   7.4786e-02   8.6833e-01   8.8720e-02
-#> 29:    1.0144e+02  -4.0414e+00  -2.4105e+00  -4.0504e+00  -9.4039e-01  -3.6753e-02   4.1681e+00   4.4515e-02   3.2754e-01   1.0410e-01   1.4940e-01   4.2837e-01   9.5520e-01   7.8507e-02   8.2408e-01   8.5998e-02
-#> 30:    1.0137e+02  -4.0292e+00  -2.4174e+00  -4.0382e+00  -9.3180e-01  -7.1482e-02   5.4636e+00   4.2289e-02   3.2074e-01   9.8896e-02   1.6877e-01   4.0695e-01   8.8153e-01   7.5106e-02   8.5239e-01   8.8266e-02
-#> 31:    1.0105e+02  -4.0387e+00  -2.4368e+00  -4.0346e+00  -9.1098e-01  -5.4730e-02   5.1904e+00   4.0175e-02   3.0470e-01   9.3951e-02   1.6034e-01   3.8660e-01   8.7853e-01   8.0278e-02   8.7981e-01   8.6404e-02
-#> 32:    1.0147e+02  -4.0435e+00  -2.4530e+00  -4.0365e+00  -9.1241e-01  -7.1281e-02   4.9309e+00   3.8166e-02   2.8947e-01   9.4694e-02   1.7475e-01   3.6727e-01   8.7005e-01   8.1398e-02   8.7784e-01   8.8976e-02
-#> 33:    1.0144e+02  -4.0092e+00  -2.4279e+00  -4.0090e+00  -8.8656e-01  -1.4017e-01   5.2945e+00   3.6258e-02   2.9770e-01   1.0169e-01   1.6601e-01   3.4891e-01   9.2202e-01   7.8841e-02   8.7551e-01   8.4011e-02
-#> 34:    1.0157e+02  -3.9839e+00  -2.4469e+00  -4.0180e+00  -8.3877e-01  -1.4664e-01   6.3506e+00   3.4445e-02   2.8282e-01   1.0831e-01   1.6850e-01   3.3146e-01   8.4403e-01   7.9056e-02   8.4620e-01   8.6363e-02
-#> 35:    1.0149e+02  -3.9928e+00  -2.4771e+00  -4.0106e+00  -8.6974e-01  -1.4219e-01   6.2039e+00   3.2722e-02   2.8123e-01   1.1283e-01   1.6008e-01   3.1489e-01   9.1308e-01   7.8685e-02   7.8939e-01   8.7289e-02
-#> 36:    1.0162e+02  -4.0099e+00  -2.4822e+00  -3.9880e+00  -8.7959e-01  -1.3237e-01   5.8937e+00   3.1086e-02   3.2200e-01   1.0719e-01   1.6077e-01   2.9914e-01   9.0821e-01   8.4066e-02   7.5559e-01   8.4838e-02
-#> 37:    1.0102e+02  -3.9962e+00  -2.4852e+00  -3.9954e+00  -8.8307e-01  -9.2070e-02   5.5991e+00   2.9532e-02   3.3713e-01   1.0183e-01   1.5333e-01   2.8419e-01   8.3918e-01   8.5231e-02   7.6007e-01   8.9541e-02
-#> 38:    1.0102e+02  -3.9987e+00  -2.5129e+00  -3.9833e+00  -8.7454e-01  -1.6469e-01   5.3191e+00   2.8055e-02   3.2027e-01   1.0792e-01   1.4707e-01   2.6998e-01   9.1490e-01   8.4715e-02   7.6778e-01   8.9241e-02
-#> 39:    1.0054e+02  -3.9875e+00  -2.4301e+00  -3.9797e+00  -8.7222e-01  -1.9597e-01   7.3800e+00   2.6653e-02   3.0426e-01   1.0801e-01   1.4393e-01   2.5648e-01   9.5901e-01   7.8320e-02   8.1559e-01   9.2429e-02
-#> 40:    1.0077e+02  -4.0057e+00  -2.4630e+00  -3.9849e+00  -8.6788e-01  -1.9606e-01   7.0110e+00   2.5320e-02   3.0385e-01   1.3164e-01   1.4567e-01   3.0284e-01   9.7123e-01   7.6328e-02   8.3681e-01   8.9349e-02
-#> 41:    1.0069e+02  -4.0143e+00  -2.3805e+00  -3.9962e+00  -8.7503e-01  -1.8532e-01   6.6604e+00   2.4054e-02   3.0707e-01   1.4668e-01   1.5021e-01   3.0404e-01   1.0072e+00   7.3629e-02   9.4494e-01   8.4745e-02
-#> 42:    1.0073e+02  -3.9861e+00  -2.4464e+00  -3.9919e+00  -8.7912e-01  -1.8435e-01   6.3274e+00   2.2851e-02   2.9171e-01   1.3935e-01   1.5080e-01   2.8883e-01   9.6502e-01   7.7470e-02   9.4221e-01   8.2459e-02
-#> 43:    1.0104e+02  -3.9881e+00  -2.4156e+00  -3.9688e+00  -8.9448e-01  -2.3739e-01   6.0110e+00   2.1709e-02   2.7713e-01   1.3238e-01   1.5603e-01   2.7439e-01   9.7714e-01   7.1720e-02   8.5890e-01   8.6635e-02
-#> 44:    1.0084e+02  -4.0117e+00  -2.4455e+00  -3.9753e+00  -8.8716e-01  -2.0112e-01   5.7105e+00   2.0623e-02   2.6327e-01   1.2741e-01   1.5200e-01   2.6067e-01   9.3289e-01   8.0543e-02   8.5055e-01   8.2921e-02
-#> 45:    1.0071e+02  -3.9996e+00  -2.4359e+00  -3.9764e+00  -9.1082e-01  -2.4578e-01   5.4250e+00   1.9592e-02   2.5011e-01   1.3254e-01   1.6132e-01   2.8273e-01   9.5805e-01   7.7734e-02   7.8171e-01   8.4571e-02
-#> 46:    1.0018e+02  -4.0077e+00  -2.4835e+00  -3.9739e+00  -8.6079e-01  -1.6592e-01   5.1537e+00   1.8613e-02   2.3760e-01   1.3830e-01   1.5392e-01   3.0295e-01   1.0931e+00   7.3274e-02   8.9544e-01   8.8388e-02
-#> 47:    99.9834   -3.9991   -2.5292   -3.9863   -0.8820   -0.0796    4.8960    0.0177    0.2348    0.1376    0.1639    0.2878    0.9864    0.0837    0.9094    0.0832
-#> 48:    99.9155   -4.0224   -2.5422   -3.9854   -0.8719   -0.0750    4.6512    0.0184    0.2251    0.1307    0.1596    0.2734    0.9841    0.0835    0.8696    0.0843
-#> 49:    99.6136   -4.0397   -2.5172   -4.0115   -0.8774   -0.0922    5.2402    0.0175    0.2558    0.1242    0.1551    0.2597    0.9060    0.0816    0.8365    0.0869
-#> 50:    99.4747   -4.0542   -2.4192   -3.9834   -0.9041   -0.1798    4.9782    0.0219    0.2695    0.1234    0.1474    0.2468    0.9269    0.0783    0.8593    0.0854
-#> 51:    99.3401   -4.0386   -2.3951   -3.9661   -0.9181   -0.1887    4.7574    0.0213    0.2746    0.1522    0.1400    0.2344    0.9901    0.0781    0.8863    0.0928
-#> 52:    99.7109   -4.0509   -2.4227   -3.9770   -0.9247   -0.1431    4.9004    0.0203    0.2688    0.1446    0.1330    0.2227    0.8999    0.0791    1.0265    0.0890
-#> 53:    99.6496   -4.0397   -2.4398   -3.9752   -0.9193   -0.2119    5.1106    0.0193    0.2795    0.1527    0.1325    0.2116    0.8949    0.0788    0.9447    0.0872
-#> 54:    99.9071   -4.0211   -2.3887   -3.9812   -0.9233   -0.1946    5.0887    0.0183    0.2763    0.1450    0.1365    0.2010    0.8793    0.0875    0.8643    0.0903
-#> 55:    1.0012e+02  -4.0401e+00  -2.4203e+00  -3.9511e+00  -9.0712e-01  -2.5566e-01   5.7301e+00   1.7375e-02   2.7324e-01   1.3780e-01   1.6204e-01   1.9094e-01   9.7803e-01   7.6146e-02   9.0756e-01   8.7636e-02
-#> 56:    1.0032e+02  -4.0207e+00  -2.4263e+00  -3.9533e+00  -8.7574e-01  -2.3076e-01   6.5321e+00   1.6507e-02   3.0821e-01   1.3091e-01   1.5394e-01   1.8139e-01   8.8520e-01   7.6350e-02   9.2796e-01   8.5283e-02
-#> 57:    1.0028e+02  -4.0037e+00  -2.4301e+00  -3.9655e+00  -8.8472e-01  -1.8969e-01   9.8969e+00   1.5681e-02   2.9280e-01   1.2436e-01   1.4624e-01   1.7232e-01   9.2902e-01   7.4974e-02   8.9204e-01   8.4563e-02
-#> 58:    1.0048e+02  -3.9928e+00  -2.4961e+00  -3.9709e+00  -9.0263e-01  -1.4516e-01   9.4021e+00   1.6151e-02   2.7816e-01   1.1814e-01   1.4165e-01   1.6370e-01   9.5145e-01   8.0233e-02   8.2896e-01   8.3498e-02
-#> 59:    1.0060e+02  -4.0181e+00  -2.4963e+00  -3.9751e+00  -9.0684e-01  -1.1186e-01   8.9320e+00   1.9914e-02   3.0097e-01   1.1224e-01   1.4109e-01   1.5552e-01   9.9121e-01   7.3120e-02   8.6454e-01   8.2239e-02
-#> 60:    1.0047e+02  -3.9976e+00  -2.4797e+00  -3.9780e+00  -8.9328e-01  -1.0814e-01   8.4854e+00   1.8918e-02   3.2275e-01   1.1591e-01   1.3404e-01   1.4774e-01   9.6968e-01   7.4984e-02   8.9831e-01   8.1655e-02
-#> 61:    1.0040e+02  -4.0068e+00  -2.5217e+00  -3.9844e+00  -8.6447e-01  -1.0567e-01   8.0611e+00   1.7972e-02   3.1372e-01   1.1011e-01   1.2973e-01   1.4036e-01   9.1698e-01   7.8118e-02   9.1811e-01   8.4420e-02
-#> 62:    1.0076e+02  -4.0080e+00  -2.4931e+00  -3.9623e+00  -8.9789e-01  -8.3896e-02   7.6580e+00   1.7073e-02   3.0460e-01   1.1254e-01   1.2324e-01   1.3334e-01   9.9032e-01   7.7618e-02   8.3808e-01   8.5031e-02
-#> 63:    1.0064e+02  -4.0129e+00  -2.4731e+00  -3.9561e+00  -8.9103e-01  -8.8987e-02   7.2751e+00   1.6220e-02   2.8944e-01   1.1647e-01   1.4845e-01   1.2667e-01   1.0745e+00   7.6375e-02   8.4316e-01   8.6681e-02
-#> 64:    1.0098e+02  -4.0094e+00  -2.4541e+00  -3.9604e+00  -9.1524e-01  -9.3413e-02   6.9114e+00   1.5409e-02   2.7497e-01   1.2065e-01   1.7095e-01   1.2034e-01   1.0963e+00   7.8304e-02   8.7104e-01   8.5727e-02
-#> 65:    1.0070e+02  -4.0433e+00  -2.4793e+00  -3.9722e+00  -9.3012e-01  -6.5917e-02   6.5658e+00   1.4638e-02   2.7040e-01   1.1462e-01   1.9067e-01   1.1432e-01   9.7444e-01   8.4510e-02   8.7028e-01   8.6292e-02
-#> 66:    1.0049e+02  -4.0656e+00  -2.4659e+00  -3.9898e+00  -9.4278e-01  -7.5929e-02   6.2375e+00   1.3906e-02   2.9347e-01   1.1997e-01   1.8114e-01   1.0860e-01   9.9830e-01   8.0902e-02   9.3551e-01   8.5261e-02
-#> 67:    1.0046e+02  -4.0477e+00  -2.4685e+00  -3.9907e+00  -9.1503e-01  -9.8019e-02   5.9256e+00   1.3211e-02   3.2166e-01   1.1506e-01   1.7208e-01   1.0317e-01   8.6453e-01   9.0533e-02   8.3598e-01   8.6343e-02
-#> 68:    1.0077e+02  -4.0575e+00  -2.4709e+00  -3.9523e+00  -9.2903e-01  -8.1099e-02   5.6294e+00   1.2818e-02   3.1005e-01   1.3665e-01   1.6347e-01   9.8015e-02   9.0181e-01   8.7058e-02   8.4937e-01   8.3248e-02
-#> 69:    1.0086e+02  -4.0626e+00  -2.3922e+00  -3.9557e+00  -9.6741e-01  -3.5986e-02   5.3479e+00   1.2844e-02   3.3024e-01   1.2982e-01   1.5530e-01   9.3115e-02   9.8180e-01   8.3132e-02   8.6549e-01   8.8939e-02
-#> 70:    1.0082e+02  -4.0640e+00  -2.4449e+00  -3.9787e+00  -9.5159e-01  -3.2904e-02   5.0805e+00   1.4346e-02   3.1373e-01   1.2333e-01   1.4754e-01   8.8459e-02   1.0129e+00   7.4856e-02   8.6688e-01   8.4769e-02
-#> 71:    1.0072e+02  -4.0642e+00  -2.5069e+00  -3.9493e+00  -9.3453e-01  -4.4116e-02   4.8265e+00   1.3628e-02   3.0428e-01   1.2122e-01   1.4091e-01   8.4036e-02   1.0454e+00   7.7023e-02   8.9566e-01   8.1639e-02
-#> 72:    1.0049e+02  -4.0609e+00  -2.4472e+00  -3.9669e+00  -9.3972e-01  -7.7498e-02   4.5852e+00   1.4441e-02   3.2552e-01   1.3911e-01   1.4144e-01   8.1899e-02   1.0114e+00   7.7019e-02   8.2312e-01   8.2494e-02
-#> 73:    1.0022e+02  -4.0598e+00  -2.4410e+00  -3.9952e+00  -9.2810e-01  -1.1309e-01   4.3559e+00   1.3719e-02   3.3556e-01   1.3303e-01   1.4990e-01   1.1303e-01   9.6726e-01   7.6776e-02   8.6331e-01   8.3048e-02
-#> 74:    1.0024e+02  -4.0628e+00  -2.4358e+00  -3.9977e+00  -9.1347e-01  -9.1966e-02   4.1381e+00   1.3033e-02   3.4332e-01   1.3418e-01   1.8099e-01   1.0738e-01   1.0158e+00   7.4697e-02   8.6366e-01   8.4370e-02
-#> 75:    99.7847   -4.0500   -2.4401   -4.0018   -0.9252   -0.1013    4.4651    0.0124    0.3365    0.1399    0.1817    0.1020    1.0278    0.0779    0.9008    0.0841
-#> 76:    99.9526   -4.0482   -2.4819   -3.9947   -0.9049   -0.0557    4.2419    0.0126    0.3248    0.1494    0.1726    0.1135    1.0493    0.0778    0.9341    0.0804
-#> 77:    99.9982   -4.0184   -2.4951   -4.0043   -0.8927   -0.0688    5.2538    0.0120    0.3696    0.1419    0.1817    0.1078    1.0402    0.0839    0.9605    0.0848
-#> 78:    1.0007e+02  -4.0210e+00  -2.4725e+00  -4.0040e+00  -8.9827e-01   2.3164e-03   6.4464e+00   1.1395e-02   3.7410e-01   1.3481e-01   2.0294e-01   1.0879e-01   9.7822e-01   8.7445e-02   9.9990e-01   8.2845e-02
-#> 79:    99.3513   -4.0171   -2.5065   -4.0078   -0.8962   -0.0029    7.7527    0.0108    0.3554    0.1281    0.1928    0.1069    1.0455    0.0866    0.9982    0.0870
-#> 80:    98.9945   -4.0172   -2.5412   -4.0341   -0.8891   -0.0187    9.8218    0.0103    0.3376    0.1217    0.1831    0.1457    0.9733    0.0894    1.0164    0.0832
-#> 81:    99.0936   -4.0275   -2.5134   -4.0127   -0.8552   -0.0614   12.1567    0.0098    0.3494    0.1156    0.1740    0.1384    0.9509    0.0843    1.0171    0.0855
-#> 82:    99.2481   -3.9996   -2.4945   -4.0011   -0.8914   -0.0492   11.5489    0.0128    0.3792    0.1098    0.1653    0.1315    0.9915    0.0818    1.0405    0.0928
-#> 83:    99.6941   -3.9998   -2.4851   -3.9845   -0.8802   -0.0560   10.9714    0.0146    0.3602    0.1043    0.1570    0.1249    0.9934    0.0852    0.9707    0.0866
-#> 84:    99.2185   -3.9920   -2.4843   -4.0051   -0.8546   -0.0642   10.4228    0.0153    0.3422    0.0991    0.1492    0.1187    0.9923    0.0833    0.9799    0.0873
-#> 85:    98.8470   -3.9956   -2.4652   -4.0201   -0.8483   -0.0414    9.9017    0.0146    0.3251    0.0941    0.1417    0.1128    0.9732    0.0901    0.9035    0.0858
-#> 86:    98.5012   -3.9841   -2.5148   -4.0250   -0.8408   -0.0551    9.4066    0.0148    0.3088    0.0962    0.1346    0.1071    0.8570    0.0932    0.8532    0.0896
-#> 87:    99.0868   -4.0055   -2.5058   -4.0249   -0.8522   -0.0311   10.3528    0.0175    0.2934    0.1013    0.1411    0.1018    0.8802    0.0838    0.8849    0.0862
-#> 88:    99.5158   -4.0031   -2.4437   -3.9866   -0.8894   -0.0963    9.9832    0.0167    0.3049    0.1030    0.1447    0.0967    0.9955    0.0834    0.8861    0.0893
-#> 89:    99.5538   -4.0347   -2.4494   -4.0213   -0.8695   -0.0494    9.4841    0.0158    0.2897    0.0978    0.1543    0.0918    0.8597    0.0904    0.8959    0.0880
-#> 90:    99.4422   -4.0453   -2.4398   -4.0114   -0.9279   -0.0745    9.8221    0.0150    0.2842    0.0929    0.1466    0.0944    0.9009    0.0871    0.8696    0.0924
-#> 91:    98.8721   -4.0328   -2.4996   -4.0041   -0.8832   -0.0689    9.3310    0.0143    0.2700    0.0896    0.1444    0.1137    0.9567    0.0904    0.8680    0.0891
-#> 92:    99.8390   -4.0418   -2.4914   -4.0182   -0.9279   -0.0460   10.9801    0.0136    0.2585    0.0949    0.1461    0.1210    1.0043    0.0908    0.8310    0.0939
-#> 93:    1.0029e+02  -4.0313e+00  -2.4620e+00  -4.0187e+00  -8.9083e-01  -1.0908e-01   1.0431e+01   1.2890e-02   2.4559e-01   9.5757e-02   1.3878e-01   1.1565e-01   9.9174e-01   9.0056e-02   8.9538e-01   8.8925e-02
-#> 94:    99.3285   -4.0295   -2.4523   -4.0235   -0.8828   -0.1190   10.9003    0.0137    0.2333    0.0915    0.1318    0.1212    1.0729    0.0779    0.9543    0.0907
-#> 95:    99.4117   -4.0422   -2.3807   -4.0870   -0.8960   -0.0889   10.3553    0.0130    0.2216    0.0870    0.1253    0.1366    0.9127    0.0864    0.8901    0.0911
-#> 96:    99.3348   -4.0401   -2.4009   -4.0698   -0.8730   -0.0622    9.8375    0.0123    0.2106    0.0826    0.1241    0.1297    0.8504    0.0836    0.9140    0.0881
-#> 97:    99.4898   -4.0419   -2.4310   -4.0589   -0.8932   -0.0634    9.3456    0.0132    0.2000    0.0785    0.1224    0.1233    0.8770    0.0836    0.8715    0.0837
-#> 98:    99.3750   -4.0704   -2.4353   -4.0616   -0.9333   -0.0846    8.8783    0.0136    0.1900    0.0746    0.1245    0.1171    0.8907    0.0838    0.9066    0.0832
-#> 99:    99.6234   -4.0366   -2.3740   -4.0657   -0.9242   -0.0675    8.4344    0.0129    0.1805    0.0708    0.1182    0.1112    0.8814    0.0808    0.9511    0.0863
-#> 100:    1.0025e+02  -4.0420e+00  -2.3557e+00  -4.0579e+00  -9.5051e-01  -6.3418e-02   8.0319e+00   1.2286e-02   1.7150e-01   6.7291e-02   1.1232e-01   1.0568e-01   8.5851e-01   8.7881e-02   8.9363e-01   8.5897e-02
-#> 101:    1.0041e+02  -4.0461e+00  -2.3840e+00  -4.0384e+00  -9.3752e-01  -7.7594e-02   9.5649e+00   1.1672e-02   1.7509e-01   6.3926e-02   1.2760e-01   1.0039e-01   8.6733e-01   8.2748e-02   9.6277e-01   8.4274e-02
-#> 102:    1.0095e+02  -4.0372e+00  -2.3633e+00  -4.0286e+00  -9.1961e-01  -6.5350e-02   1.1428e+01   1.1088e-02   1.8557e-01   6.0730e-02   1.3211e-01   9.5374e-02   9.3928e-01   8.0161e-02   9.7913e-01   8.4081e-02
-#> 103:    1.0019e+02  -4.0236e+00  -2.4105e+00  -4.0337e+00  -9.1362e-01  -7.3859e-02   1.0856e+01   1.0534e-02   1.7629e-01   5.7693e-02   1.2695e-01   9.1362e-02   9.8491e-01   8.1430e-02   9.7682e-01   8.2250e-02
-#> 104:    99.7755   -4.0280   -2.4452   -4.0197   -0.9112   -0.0810   11.0317    0.0100    0.1796    0.0548    0.1301    0.0868    0.9418    0.0816    0.9170    0.0806
-#> 105:    1.0010e+02  -4.0418e+00  -2.4294e+00  -4.0225e+00  -9.1111e-01  -8.9920e-02   1.0480e+01   9.5070e-03   1.7060e-01   5.2068e-02   1.3987e-01   8.2454e-02   9.1944e-01   7.8110e-02   8.9266e-01   8.7228e-02
-#> 106:    1.0025e+02  -4.0507e+00  -2.4134e+00  -4.0343e+00  -9.0244e-01  -8.4683e-02   1.3506e+01   9.0316e-03   1.6207e-01   4.9465e-02   1.5337e-01   7.8331e-02   9.9609e-01   8.4473e-02   8.7046e-01   8.5479e-02
-#> 107:    1.0014e+02  -4.0468e+00  -2.3972e+00  -4.0196e+00  -9.3650e-01  -2.4087e-02   1.2830e+01   8.5801e-03   1.6027e-01   4.6992e-02   1.5429e-01   8.2493e-02   9.8959e-01   8.2626e-02   8.3427e-01   8.8197e-02
-#> 108:    1.0114e+02  -4.0338e+00  -2.4307e+00  -4.0724e+00  -9.1363e-01   1.1952e-02   1.2189e+01   8.1511e-03   1.5563e-01   4.4854e-02   1.7315e-01   7.8368e-02   9.8589e-01   7.8130e-02   9.0460e-01   8.2870e-02
-#> 109:    1.0066e+02  -4.0550e+00  -2.4094e+00  -4.0641e+00  -9.0945e-01  -1.5401e-03   1.3149e+01   7.7435e-03   1.4785e-01   4.2612e-02   1.7232e-01   7.4450e-02   1.0942e+00   7.4816e-02   9.1706e-01   8.5333e-02
-#> 110:    1.0111e+02  -4.0266e+00  -2.4047e+00  -4.0646e+00  -9.0541e-01  -1.7212e-02   1.2492e+01   7.3563e-03   1.4046e-01   4.0481e-02   1.8132e-01   7.0727e-02   1.0508e+00   7.9457e-02   9.8990e-01   8.2975e-02
-#> 111:    1.0155e+02  -4.0274e+00  -2.3645e+00  -4.0663e+00  -9.4902e-01  -1.8882e-02   1.1867e+01   8.7757e-03   1.4436e-01   3.8457e-02   1.7225e-01   6.7191e-02   1.0217e+00   7.7437e-02   9.9196e-01   8.1580e-02
-#> 112:    1.0209e+02  -4.0230e+00  -2.3938e+00  -4.0375e+00  -9.5447e-01  -5.0888e-02   1.4321e+01   8.3370e-03   1.4863e-01   3.6534e-02   1.6778e-01   8.2186e-02   9.3085e-01   8.3291e-02   9.8775e-01   7.9492e-02
-#> 113:    1.0188e+02  -4.0173e+00  -2.3804e+00  -4.0403e+00  -9.6152e-01  -7.7453e-02   1.3605e+01   7.9201e-03   1.5060e-01   3.4708e-02   1.7341e-01   8.4506e-02   9.0783e-01   8.7383e-02   9.4854e-01   8.2648e-02
-#> 114:    1.0239e+02  -4.0081e+00  -2.3724e+00  -4.0332e+00  -9.4315e-01  -7.4933e-02   1.2925e+01   7.5241e-03   1.4307e-01   3.2972e-02   1.6695e-01   8.0281e-02   9.2775e-01   8.4314e-02   9.6195e-01   7.9448e-02
-#> 115:    1.0199e+02  -4.0127e+00  -2.3773e+00  -4.0472e+00  -9.5157e-01  -2.0947e-02   1.2279e+01   7.4483e-03   1.3592e-01   3.1324e-02   1.6705e-01   7.6267e-02   9.4956e-01   7.6989e-02   1.0340e+00   8.5564e-02
-#> 116:    1.0122e+02  -4.0264e+00  -2.4014e+00  -4.0509e+00  -9.1462e-01  -2.3511e-02   1.1665e+01   7.0759e-03   1.2912e-01   2.9757e-02   1.5870e-01   7.2453e-02   9.3580e-01   8.2952e-02   9.3341e-01   8.3302e-02
-#> 117:    1.0112e+02  -4.0326e+00  -2.4093e+00  -4.0559e+00  -8.9743e-01  -2.0572e-02   1.1082e+01   6.7221e-03   1.2266e-01   2.8269e-02   1.5339e-01   6.8831e-02   9.0879e-01   8.4441e-02   9.1432e-01   8.0538e-02
-#> 118:    1.0123e+02  -4.0411e+00  -2.4077e+00  -4.0556e+00  -9.2971e-01  -2.1885e-02   1.0528e+01   6.3860e-03   1.1653e-01   3.3123e-02   1.6947e-01   6.5389e-02   9.7140e-01   8.6671e-02   8.9874e-01   8.1670e-02
-#> 119:    1.0098e+02  -4.0538e+00  -2.3515e+00  -4.0607e+00  -9.5433e-01  -7.5743e-02   1.0001e+01   6.0667e-03   1.1070e-01   3.1467e-02   1.8338e-01   6.2120e-02   9.1537e-01   8.4827e-02   9.2420e-01   8.2769e-02
-#> 120:    1.0076e+02  -4.0573e+00  -2.3627e+00  -4.0329e+00  -9.3251e-01  -6.7669e-02   9.5011e+00   5.7634e-03   1.0517e-01   3.2868e-02   1.7422e-01   6.6096e-02   9.5247e-01   8.5343e-02   9.4678e-01   8.5335e-02
-#> 121:    1.0085e+02  -4.0450e+00  -2.3478e+00  -4.0692e+00  -9.2333e-01  -9.8005e-03   9.0261e+00   5.4752e-03   9.9911e-02   3.1225e-02   1.6550e-01   7.1593e-02   8.5572e-01   8.8654e-02   1.0248e+00   8.0646e-02
-#> 122:    1.0164e+02  -4.0325e+00  -2.3562e+00  -4.0680e+00  -9.4287e-01  -1.2103e-02   8.5748e+00   5.3493e-03   9.4915e-02   2.9663e-02   1.6347e-01   6.8014e-02   8.4872e-01   8.6803e-02   1.0282e+00   8.0381e-02
-#> 123:    1.0184e+02  -4.0521e+00  -2.3504e+00  -4.0714e+00  -9.5966e-01  -9.1996e-05   8.1460e+00   5.0818e-03   9.8247e-02   3.0007e-02   1.7746e-01   6.4613e-02   9.7181e-01   8.0986e-02   9.8860e-01   8.0317e-02
-#> 124:    1.0235e+02  -4.0674e+00  -2.3315e+00  -4.0874e+00  -9.9802e-01   3.8818e-02   7.7387e+00   4.8277e-03   9.3335e-02   2.8506e-02   1.7611e-01   6.8940e-02   9.7376e-01   7.6658e-02   9.9156e-01   8.4407e-02
-#> 125:    1.0257e+02  -4.0718e+00  -2.3604e+00  -4.0627e+00  -1.0591e+00   2.4685e-02   7.3518e+00   4.5863e-03   8.8668e-02   3.0650e-02   1.8671e-01   6.5493e-02   1.0275e+00   8.2278e-02   1.0896e+00   8.0976e-02
-#> 126:    1.0287e+02  -4.0691e+00  -2.3103e+00  -4.0552e+00  -1.0174e+00   2.1863e-02   7.5644e+00   4.3570e-03   1.0937e-01   2.9117e-02   1.7738e-01   6.2218e-02   9.2668e-01   7.9560e-02   9.5409e-01   8.4671e-02
-#> 127:    1.0327e+02  -4.0528e+00  -2.3141e+00  -4.0522e+00  -1.0108e+00   4.4779e-03   7.1862e+00   4.1392e-03   1.2239e-01   2.7661e-02   1.6925e-01   5.9107e-02   9.1372e-01   7.9536e-02   9.9164e-01   8.2999e-02
-#> 128:    1.0352e+02  -4.0496e+00  -2.2880e+00  -4.0496e+00  -1.0063e+00  -1.3248e-02   7.6721e+00   3.9613e-03   1.1627e-01   2.6278e-02   1.7517e-01   8.0231e-02   8.4407e-01   8.5078e-02   9.4382e-01   8.7530e-02
-#> 129:    1.0345e+02  -4.0715e+00  -2.3090e+00  -4.0400e+00  -1.0276e+00  -1.8301e-02   8.2197e+00   3.7633e-03   1.1046e-01   2.7141e-02   1.9366e-01   7.6220e-02   9.3357e-01   8.2674e-02   9.7064e-01   8.6011e-02
-#> 130:    1.0245e+02  -4.0787e+00  -2.3263e+00  -4.0106e+00  -1.0200e+00  -8.5976e-02   7.8087e+00   4.0830e-03   1.3607e-01   2.6631e-02   2.2700e-01   7.2409e-02   9.8233e-01   7.9348e-02   9.6780e-01   8.2658e-02
-#> 131:    1.0217e+02  -4.0760e+00  -2.2525e+00  -4.0082e+00  -1.0099e+00  -1.6111e-01   7.4183e+00   3.8789e-03   1.3972e-01   2.5299e-02   2.2508e-01   6.8788e-02   1.0066e+00   7.8692e-02   9.4684e-01   8.4349e-02
-#> 132:    1.0185e+02  -4.0792e+00  -2.2309e+00  -3.9996e+00  -9.8302e-01  -2.2504e-01   7.0474e+00   4.0356e-03   1.3743e-01   2.4034e-02   2.1383e-01   7.7346e-02   9.4225e-01   7.9110e-02   9.5160e-01   8.4398e-02
-#> 133:    1.0135e+02  -4.0818e+00  -2.2219e+00  -4.0054e+00  -9.7264e-01  -1.8912e-01   7.1932e+00   3.8338e-03   1.3056e-01   2.2833e-02   2.0314e-01   7.6769e-02   1.0031e+00   8.5400e-02   1.0034e+00   8.4805e-02
-#> 134:    1.0148e+02  -4.0782e+00  -2.2492e+00  -3.9886e+00  -9.5184e-01  -1.5049e-01   6.8336e+00   3.6422e-03   1.2403e-01   2.3398e-02   1.9298e-01   7.2931e-02   9.3696e-01   8.3566e-02   9.4742e-01   8.9137e-02
-#> 135:    1.0145e+02  -4.0852e+00  -2.3062e+00  -4.0011e+00  -9.4444e-01  -1.6803e-01   6.4919e+00   3.4600e-03   1.1783e-01   2.2228e-02   1.8333e-01   6.9284e-02   9.4846e-01   8.3087e-02   9.7774e-01   8.2610e-02
-#> 136:    1.0177e+02  -4.0861e+00  -2.2785e+00  -3.9890e+00  -9.9625e-01  -1.8938e-01   6.1673e+00   3.2870e-03   1.1752e-01   2.1116e-02   1.8815e-01   6.5820e-02   9.3634e-01   8.5255e-02   1.1001e+00   8.5332e-02
-#> 137:    1.0200e+02  -4.0928e+00  -2.1946e+00  -3.9974e+00  -1.0098e+00  -1.8810e-01   5.8589e+00   3.1227e-03   1.2394e-01   2.1203e-02   1.7874e-01   7.2232e-02   1.0048e+00   7.3422e-02   1.0222e+00   8.3484e-02
-#> 138:    1.0214e+02  -4.0820e+00  -2.2052e+00  -3.9737e+00  -1.0420e+00  -2.0594e-01   5.5660e+00   3.8937e-03   1.9164e-01   2.0143e-02   1.6980e-01   6.8621e-02   1.0126e+00   7.6106e-02   1.0780e+00   8.2960e-02
-#> 139:    1.0249e+02  -4.0785e+00  -2.1649e+00  -3.9567e+00  -1.0095e+00  -2.8807e-01   5.2877e+00   3.6990e-03   1.8647e-01   1.9135e-02   1.6131e-01   6.5190e-02   1.0030e+00   7.9858e-02   1.0611e+00   8.4109e-02
-#> 140:    1.0184e+02  -4.0847e+00  -2.1800e+00  -3.9565e+00  -9.9415e-01  -2.8869e-01   5.0233e+00   4.0857e-03   1.9502e-01   1.8179e-02   1.6676e-01   6.2879e-02   9.5962e-01   7.8117e-02   9.9649e-01   8.4914e-02
-#> 141:    1.0195e+02  -4.1012e+00  -2.1831e+00  -3.9488e+00  -9.9515e-01  -3.1864e-01   4.7721e+00   3.8814e-03   1.8527e-01   1.7270e-02   1.6797e-01   6.1084e-02   9.0969e-01   8.2722e-02   1.0122e+00   8.2518e-02
-#> 142:    1.0233e+02  -4.1139e+00  -2.1692e+00  -3.9542e+00  -1.0023e+00  -3.3242e-01   4.5335e+00   3.6873e-03   2.0662e-01   1.6406e-02   1.5957e-01   5.8030e-02   9.4761e-01   8.4629e-02   1.0342e+00   8.3954e-02
-#> 143:    1.0217e+02  -4.1103e+00  -2.1380e+00  -3.9511e+00  -1.0300e+00  -2.5992e-01   5.2035e+00   4.7053e-03   1.9629e-01   1.5586e-02   1.5979e-01   5.5128e-02   8.9255e-01   7.9042e-02   1.0461e+00   8.6952e-02
-#> 144:    1.0185e+02  -4.1335e+00  -2.1911e+00  -3.9650e+00  -1.0440e+00  -2.4451e-01   5.0998e+00   4.4700e-03   1.8648e-01   1.9590e-02   1.5534e-01   5.2372e-02   9.7863e-01   8.3932e-02   1.0197e+00   8.7673e-02
-#> 145:    1.0242e+02  -4.1445e+00  -2.1203e+00  -3.9616e+00  -1.0426e+00  -2.7120e-01   4.8448e+00   4.2465e-03   1.7715e-01   1.8611e-02   1.4757e-01   4.9753e-02   1.0024e+00   8.4131e-02   1.0768e+00   8.5388e-02
-#> 146:    1.0236e+02  -4.1519e+00  -2.1958e+00  -3.9779e+00  -9.8615e-01  -2.5863e-01   4.6026e+00   4.0718e-03   1.6829e-01   1.7680e-02   1.6407e-01   4.7266e-02   1.0740e+00   8.2413e-02   1.0706e+00   8.3410e-02
-#> 147:    1.0251e+02  -4.1465e+00  -2.2042e+00  -3.9775e+00  -1.0317e+00  -2.2757e-01   4.3725e+00   3.8682e-03   1.5988e-01   1.6796e-02   1.7016e-01   4.4902e-02   9.7748e-01   8.3376e-02   1.0880e+00   8.1968e-02
-#> 148:    1.0244e+02  -4.1432e+00  -2.1786e+00  -3.9792e+00  -1.0442e+00  -2.2002e-01   4.9671e+00   3.6748e-03   1.5189e-01   1.5956e-02   2.2196e-01   4.2657e-02   1.0412e+00   7.8051e-02   1.1051e+00   8.1618e-02
-#> 149:    1.0219e+02  -4.1384e+00  -2.2318e+00  -3.9757e+00  -1.0438e+00  -2.4124e-01   4.7187e+00   3.4910e-03   1.4429e-01   1.6061e-02   2.1086e-01   4.0524e-02   1.0082e+00   8.0377e-02   1.1455e+00   8.0545e-02
-#> 150:    1.0264e+02  -4.1498e+00  -2.2352e+00  -3.9915e+00  -1.0669e+00  -2.1255e-01   4.4828e+00   3.3165e-03   1.3708e-01   1.7218e-02   2.0032e-01   3.8498e-02   9.5031e-01   8.7248e-02   9.8770e-01   8.3250e-02
-#> 151:    1.0250e+02  -4.1365e+00  -2.1876e+00  -3.9939e+00  -1.0568e+00  -1.8159e-01   4.2587e+00   3.1507e-03   1.3022e-01   1.7383e-02   1.9030e-01   3.6573e-02   9.6938e-01   8.0203e-02   1.0578e+00   8.3430e-02
-#> 152:    1.0256e+02  -4.1370e+00  -2.2238e+00  -4.0047e+00  -1.0406e+00  -1.8764e-01   1.9609e+00   1.4191e-03   1.1882e-01   1.7924e-02   1.6889e-01   4.1216e-02   9.1972e-01   7.8573e-02   1.0717e+00   8.0882e-02
-#> 153:    1.0219e+02  -4.1299e+00  -2.2139e+00  -3.9917e+00  -9.9964e-01  -2.0505e-01   1.8258e+00   1.0432e-03   8.4660e-02   2.1446e-02   1.7634e-01   3.5573e-02   9.3702e-01   8.4860e-02   1.0145e+00   8.3329e-02
-#> 154:    1.0199e+02  -4.1354e+00  -2.2231e+00  -3.9779e+00  -1.0155e+00  -2.2573e-01   2.6463e+00   5.8153e-04   8.8101e-02   2.3167e-02   1.6103e-01   3.3874e-02   9.5360e-01   8.6215e-02   9.5723e-01   8.4603e-02
-#> 155:    1.0234e+02  -4.1239e+00  -2.2137e+00  -3.9802e+00  -1.0070e+00  -2.3158e-01   2.9697e+00   6.6709e-04   1.1190e-01   2.0949e-02   1.8298e-01   3.1557e-02   9.2910e-01   8.2509e-02   9.8680e-01   8.5206e-02
-#> 156:    1.0253e+02  -4.1269e+00  -2.2370e+00  -3.9682e+00  -1.0420e+00  -2.1219e-01   2.7267e+00   6.8451e-04   8.9651e-02   2.4380e-02   1.6613e-01   3.4846e-02   9.3608e-01   8.7506e-02   9.0446e-01   8.1755e-02
-#> 157:    1.0265e+02  -4.1241e+00  -2.2179e+00  -3.9676e+00  -1.0308e+00  -2.2480e-01   2.1278e+00   4.9811e-04   6.7161e-02   1.9758e-02   1.5607e-01   4.4198e-02   9.4162e-01   8.7311e-02   9.9147e-01   7.9857e-02
-#> 158:    1.0239e+02  -4.1219e+00  -2.1615e+00  -3.9781e+00  -1.0384e+00  -2.6750e-01   2.5310e+00   4.8270e-04   6.5662e-02   1.8085e-02   1.7665e-01   4.4020e-02   8.8632e-01   8.6004e-02   1.0425e+00   8.2894e-02
-#> 159:    1.0270e+02  -4.1204e+00  -2.1837e+00  -3.9530e+00  -1.0587e+00  -2.5809e-01   3.4348e+00   5.6788e-04   6.5500e-02   1.9540e-02   1.8629e-01   4.0730e-02   9.5079e-01   8.2399e-02   9.9316e-01   8.3381e-02
-#> 160:    1.0282e+02  -4.1223e+00  -2.1325e+00  -3.9734e+00  -1.0068e+00  -2.8751e-01   3.9652e+00   7.6565e-04   8.5246e-02   1.7068e-02   1.7587e-01   3.0778e-02   9.1802e-01   8.0158e-02   9.9642e-01   8.1564e-02
-#> 161:    1.0330e+02  -4.1180e+00  -2.1879e+00  -3.9743e+00  -1.0268e+00  -2.8812e-01   4.9153e+00   5.8033e-04   8.0457e-02   1.8555e-02   1.7312e-01   3.3941e-02   8.6920e-01   8.2509e-02   9.5632e-01   8.1798e-02
-#> 162:    1.0335e+02  -4.1182e+00  -2.2089e+00  -3.9566e+00  -1.0409e+00  -2.7390e-01   3.6169e+00   2.8392e-04   1.0776e-01   1.9589e-02   1.6479e-01   2.8481e-02   8.8603e-01   8.7799e-02   9.5197e-01   7.9563e-02
-#> 163:    1.0294e+02  -4.1181e+00  -2.2025e+00  -3.9462e+00  -9.9783e-01  -3.0753e-01   3.7234e+00   1.6293e-04   9.6922e-02   2.4842e-02   1.9367e-01   3.1473e-02   9.0380e-01   9.1697e-02   9.4394e-01   8.2786e-02
-#> 164:    1.0246e+02  -4.1155e+00  -2.2157e+00  -3.9736e+00  -9.9866e-01  -2.9356e-01   3.9439e+00   1.9405e-04   1.0404e-01   2.8435e-02   1.9043e-01   3.1239e-02   8.9853e-01   8.9427e-02   9.2586e-01   8.3170e-02
-#> 165:    1.0204e+02  -4.1117e+00  -2.2133e+00  -3.9674e+00  -1.0079e+00  -2.6996e-01   3.0774e+00   1.6591e-04   7.0005e-02   2.8285e-02   2.0813e-01   2.4574e-02   8.9719e-01   9.1629e-02   9.8242e-01   8.3692e-02
-#> 166:    1.0207e+02  -4.1164e+00  -2.2192e+00  -3.9893e+00  -1.0354e+00  -2.7396e-01   1.8145e+00   8.4168e-05   9.0739e-02   2.7410e-02   2.1403e-01   2.4311e-02   8.9386e-01   9.2727e-02   9.4636e-01   8.4238e-02
-#> 167:    1.0187e+02  -4.1149e+00  -2.2185e+00  -3.9708e+00  -1.0036e+00  -2.5751e-01   1.5355e+00   4.0974e-05   9.9346e-02   2.2030e-02   2.1916e-01   2.6726e-02   9.1055e-01   8.1030e-02   1.0098e+00   7.9180e-02
-#> 168:    1.0172e+02  -4.1167e+00  -2.2673e+00  -3.9702e+00  -9.8388e-01  -2.1404e-01   1.4836e+00   2.7779e-05   7.7509e-02   2.9513e-02   1.9543e-01   3.4526e-02   1.0152e+00   8.1248e-02   9.7482e-01   8.0746e-02
-#> 169:    1.0175e+02  -4.1171e+00  -2.2634e+00  -3.9701e+00  -9.5962e-01  -2.4130e-01   1.4263e+00   4.7370e-05   5.0986e-02   2.8211e-02   2.2554e-01   3.9909e-02   9.8519e-01   7.8842e-02   1.0023e+00   8.5684e-02
-#> 170:    1.0177e+02  -4.1189e+00  -2.2417e+00  -3.9834e+00  -1.0059e+00  -2.6551e-01   9.9010e-01   3.7247e-05   4.2517e-02   2.9791e-02   1.8705e-01   4.2435e-02   9.6604e-01   8.8427e-02   9.6699e-01   8.3986e-02
-#> 171:    1.0182e+02  -4.1187e+00  -2.2464e+00  -3.9953e+00  -9.8154e-01  -2.5146e-01   7.4179e-01   3.2420e-05   5.0690e-02   3.0483e-02   1.7888e-01   6.3177e-02   9.2784e-01   8.4814e-02   1.0018e+00   8.4070e-02
-#> 172:    1.0184e+02  -4.1178e+00  -2.2483e+00  -4.0009e+00  -1.0096e+00  -2.2636e-01   9.6710e-01   2.6981e-05   3.1321e-02   2.7772e-02   1.9767e-01   7.4969e-02   9.9720e-01   8.1434e-02   9.5483e-01   8.3419e-02
-#> 173:    1.0160e+02  -4.1183e+00  -2.2513e+00  -3.9920e+00  -9.8456e-01  -2.0144e-01   4.9964e-01   2.1222e-05   4.1909e-02   2.8101e-02   2.1163e-01   1.2811e-01   9.6384e-01   8.0352e-02   9.2496e-01   8.2328e-02
-#> 174:    1.0159e+02  -4.1179e+00  -2.2334e+00  -4.0068e+00  -1.0316e+00  -2.0656e-01   4.6608e-01   1.8044e-05   4.4647e-02   2.8273e-02   2.0083e-01   1.2780e-01   9.4612e-01   8.3630e-02   8.9385e-01   8.3930e-02
-#> 175:    1.0159e+02  -4.1182e+00  -2.2567e+00  -3.9972e+00  -1.0299e+00  -1.6534e-01   4.5228e-01   2.0060e-05   8.5751e-02   2.5343e-02   1.7864e-01   8.6977e-02   9.5795e-01   7.8867e-02   8.9213e-01   8.4362e-02
-#> 176:    1.0159e+02  -4.1183e+00  -2.2109e+00  -3.9983e+00  -1.0210e+00  -2.0879e-01   5.3694e-01   2.0264e-05   1.2835e-01   2.5563e-02   1.9469e-01   6.0808e-02   9.1537e-01   7.8520e-02   9.3355e-01   8.3608e-02
-#> 177:    1.0155e+02  -4.1193e+00  -2.2587e+00  -3.9825e+00  -1.0180e+00  -1.6859e-01   4.4935e-01   3.0321e-05   1.3509e-01   2.4979e-02   2.0113e-01   6.3617e-02   9.7277e-01   7.8515e-02   9.2667e-01   8.5309e-02
-#> 178:    1.0158e+02  -4.1196e+00  -2.2679e+00  -4.0231e+00  -1.0143e+00  -1.6084e-01   6.7629e-01   3.2855e-05   6.8816e-02   2.7808e-02   1.8944e-01   8.1814e-02   8.8319e-01   8.0114e-02   9.5183e-01   8.2195e-02
-#> 179:    1.0166e+02  -4.1190e+00  -2.2764e+00  -3.9875e+00  -1.0061e+00  -1.8260e-01   7.1129e-01   3.8250e-05   7.5489e-02   2.4148e-02   1.8082e-01   7.1172e-02   9.1387e-01   8.0813e-02   9.6660e-01   8.2457e-02
-#> 180:    1.0179e+02  -4.1202e+00  -2.2848e+00  -3.9974e+00  -9.9825e-01  -2.0277e-01   5.5755e-01   2.8041e-05   8.6779e-02   2.7193e-02   1.8826e-01   6.5133e-02   8.8812e-01   8.2655e-02   9.2100e-01   7.9919e-02
-#> 181:    1.0176e+02  -4.1200e+00  -2.2704e+00  -3.9954e+00  -1.0194e+00  -1.6896e-01   4.3842e-01   2.2428e-05   7.4093e-02   3.0526e-02   2.3473e-01   1.0537e-01   9.2303e-01   8.2141e-02   9.2941e-01   8.4699e-02
-#> 182:    1.0182e+02  -4.1211e+00  -2.3159e+00  -4.0259e+00  -1.0162e+00  -1.2876e-01   3.4993e-01   1.5716e-05   5.9887e-02   2.6422e-02   2.1757e-01   1.0488e-01   9.1725e-01   9.4143e-02   9.7674e-01   8.8668e-02
-#> 183:    1.0184e+02  -4.1216e+00  -2.2985e+00  -4.0278e+00  -1.0136e+00  -1.3154e-01   2.6456e-01   1.2552e-05   5.7149e-02   3.2712e-02   2.0632e-01   1.5501e-01   9.2464e-01   8.5394e-02   8.8699e-01   8.4279e-02
-#> 184:    1.0172e+02  -4.1212e+00  -2.2726e+00  -4.0189e+00  -1.0280e+00  -1.2967e-01   3.0582e-01   7.5239e-06   8.2812e-02   2.9556e-02   1.9725e-01   1.3753e-01   9.0862e-01   8.1319e-02   9.0031e-01   8.3491e-02
-#> 185:    1.0178e+02  -4.1208e+00  -2.2858e+00  -4.0272e+00  -1.0063e+00  -1.6155e-01   3.0856e-01   4.5894e-06   8.8870e-02   2.5817e-02   1.9251e-01   1.0670e-01   9.1157e-01   7.7834e-02   9.6258e-01   7.8990e-02
-#> 186:    1.0198e+02  -4.1208e+00  -2.2682e+00  -4.0401e+00  -9.8523e-01  -1.1556e-01   2.4761e-01   3.2640e-06   7.5614e-02   2.1067e-02   1.9085e-01   9.0045e-02   8.5090e-01   8.6621e-02   1.0145e+00   8.1864e-02
-#> 187:    1.0197e+02  -4.1208e+00  -2.2788e+00  -4.0281e+00  -1.0066e+00  -1.0149e-01   2.0460e-01   4.5073e-06   7.8797e-02   2.3861e-02   2.0725e-01   7.9771e-02   9.6253e-01   8.2363e-02   9.3855e-01   8.3939e-02
-#> 188:    1.0196e+02  -4.1207e+00  -2.3105e+00  -4.0149e+00  -1.0217e+00  -9.0603e-02   2.2178e-01   3.6903e-06   8.9793e-02   2.1775e-02   1.9248e-01   8.2415e-02   9.4078e-01   8.1247e-02   9.1756e-01   8.2786e-02
-#> 189:    1.0202e+02  -4.1204e+00  -2.2702e+00  -4.0430e+00  -1.0032e+00  -1.1308e-01   2.2944e-01   3.5141e-06   7.8575e-02   2.4885e-02   2.0968e-01   8.2380e-02   9.5115e-01   8.1619e-02   9.2134e-01   8.9958e-02
-#> 190:    1.0195e+02  -4.1207e+00  -2.3126e+00  -4.0312e+00  -1.0154e+00  -6.3842e-02   2.5129e-01   2.6517e-06   4.2267e-02   2.2084e-02   1.9361e-01   7.0492e-02   9.3985e-01   8.5817e-02   9.3893e-01   8.7011e-02
-#> 191:    1.0203e+02  -4.1206e+00  -2.2758e+00  -4.0290e+00  -1.0102e+00  -3.1042e-02   1.7935e-01   3.4489e-06   5.7444e-02   2.3544e-02   1.9651e-01   7.9509e-02   9.5213e-01   8.2030e-02   1.0054e+00   8.7523e-02
-#> 192:    1.0199e+02  -4.1205e+00  -2.2969e+00  -4.0329e+00  -1.0364e+00  -8.3705e-02   1.5785e-01   3.5081e-06   7.4305e-02   2.2992e-02   1.9662e-01   7.7684e-02   9.2601e-01   8.3027e-02   9.8642e-01   8.3428e-02
-#> 193:    1.0196e+02  -4.1205e+00  -2.2661e+00  -4.0513e+00  -9.9271e-01  -4.6516e-02   1.2084e-01   2.6911e-06   6.8360e-02   3.5444e-02   1.9649e-01   7.5188e-02   9.1949e-01   7.9194e-02   1.0046e+00   8.5964e-02
-#> 194:    1.0198e+02  -4.1207e+00  -2.2817e+00  -4.0520e+00  -9.9852e-01  -8.4466e-02   1.3596e-01   1.5511e-06   6.5142e-02   4.1562e-02   1.9137e-01   9.6992e-02   9.6709e-01   7.6757e-02   9.7566e-01   8.3784e-02
-#> 195:    1.0200e+02  -4.1207e+00  -2.3076e+00  -4.0637e+00  -1.0028e+00  -7.2489e-02   1.0942e-01   1.6451e-06   6.1364e-02   4.6242e-02   1.9470e-01   9.3546e-02   9.9614e-01   8.1292e-02   9.7814e-01   8.1909e-02
-#> 196:    1.0194e+02  -4.1205e+00  -2.2970e+00  -4.0482e+00  -9.8816e-01  -6.8493e-02   1.1918e-01   1.2629e-06   4.2775e-02   3.6925e-02   2.3565e-01   7.7784e-02   8.9524e-01   9.2250e-02   9.8003e-01   8.2408e-02
-#> 197:    1.0199e+02  -4.1205e+00  -2.3075e+00  -4.0418e+00  -1.0196e+00  -6.8458e-02   1.7674e-01   7.5205e-07   5.2125e-02   2.9288e-02   2.1892e-01   8.4416e-02   8.9857e-01   9.1154e-02   1.0377e+00   8.3604e-02
-#> 198:    1.0197e+02  -4.1206e+00  -2.3051e+00  -4.0367e+00  -1.0252e+00  -6.9200e-02   9.1625e-02   6.6068e-07   4.7665e-02   2.8907e-02   1.8679e-01   7.5787e-02   9.0272e-01   8.8077e-02   9.2929e-01   8.0385e-02
-#> 199:    1.0192e+02  -4.1204e+00  -2.3163e+00  -4.0506e+00  -1.0152e+00  -5.3872e-02   6.8196e-02   5.5789e-07   6.0471e-02   3.1730e-02   2.0053e-01   6.8557e-02   9.0478e-01   8.5910e-02   9.3814e-01   8.2211e-02
-#> 200:    1.0195e+02  -4.1205e+00  -2.3141e+00  -4.0728e+00  -1.0010e+00  -2.5675e-03   6.5235e-02   6.9762e-07   5.8458e-02   2.8504e-02   2.0377e-01   4.9513e-02   8.5640e-01   8.6640e-02   9.5731e-01   8.4390e-02
-#> 201:    1.0195e+02  -4.1205e+00  -2.3106e+00  -4.0774e+00  -9.9012e-01   5.1724e-03   5.1225e-02   5.4222e-07   6.0577e-02   3.3554e-02   2.0505e-01   4.4738e-02   8.8073e-01   8.5488e-02   9.6928e-01   8.4895e-02
-#> 202:    1.0194e+02  -4.1205e+00  -2.3078e+00  -4.0767e+00  -9.9283e-01   3.9328e-03   4.5461e-02   4.8520e-07   6.7405e-02   3.4599e-02   2.1312e-01   4.6664e-02   9.0528e-01   8.4189e-02   9.8043e-01   8.5266e-02
-#> 203:    1.0193e+02  -4.1205e+00  -2.3029e+00  -4.0790e+00  -9.8990e-01  -9.1380e-03   4.7128e-02   5.0468e-07   6.8524e-02   3.6050e-02   2.1378e-01   5.1774e-02   9.0923e-01   8.4899e-02   9.8928e-01   8.4613e-02
-#> 204:    1.0192e+02  -4.1205e+00  -2.3080e+00  -4.0760e+00  -9.8833e-01  -1.2434e-02   4.8184e-02   4.9472e-07   6.4152e-02   3.5604e-02   2.0954e-01   5.1354e-02   9.1294e-01   8.5219e-02   9.8301e-01   8.4374e-02
-#> 205:    1.0192e+02  -4.1205e+00  -2.3100e+00  -4.0712e+00  -9.9253e-01  -2.3365e-02   4.5888e-02   5.0564e-07   5.9894e-02   3.5053e-02   2.0322e-01   5.4423e-02   9.0925e-01   8.5899e-02   9.8418e-01   8.3421e-02
-#> 206:    1.0192e+02  -4.1205e+00  -2.3095e+00  -4.0715e+00  -9.9721e-01  -2.6262e-02   4.3985e-02   5.1954e-07   5.8681e-02   3.4539e-02   2.0202e-01   5.8248e-02   9.1301e-01   8.5459e-02   9.8621e-01   8.3465e-02
-#> 207:    1.0192e+02  -4.1205e+00  -2.3179e+00  -4.0731e+00  -9.9906e-01  -2.3191e-02   4.3649e-02   5.3824e-07   5.7537e-02   3.4790e-02   2.0220e-01   6.0242e-02   9.1783e-01   8.5307e-02   9.8436e-01   8.3111e-02
-#> 208:    1.0191e+02  -4.1205e+00  -2.3238e+00  -4.0734e+00  -9.9920e-01  -1.9434e-02   4.3223e-02   5.3831e-07   5.7908e-02   3.4909e-02   2.0126e-01   6.0353e-02   9.2010e-01   8.5244e-02   9.8002e-01   8.2975e-02
-#> 209:    1.0191e+02  -4.1205e+00  -2.3279e+00  -4.0726e+00  -1.0053e+00  -1.5390e-02   4.1064e-02   5.3171e-07   5.8749e-02   3.4510e-02   1.9942e-01   6.3063e-02   9.3192e-01   8.4436e-02   9.8298e-01   8.3187e-02
-#> 210:    1.0191e+02  -4.1205e+00  -2.3310e+00  -4.0705e+00  -1.0061e+00  -1.3507e-02   3.8265e-02   5.2762e-07   5.9344e-02   3.3374e-02   1.9612e-01   6.7006e-02   9.3199e-01   8.4573e-02   9.8382e-01   8.3227e-02
-#> 211:    1.0191e+02  -4.1205e+00  -2.3383e+00  -4.0683e+00  -1.0043e+00  -1.3973e-02   3.6076e-02   5.2584e-07   6.1568e-02   3.2369e-02   1.9504e-01   6.9982e-02   9.4179e-01   8.4625e-02   9.9145e-01   8.3067e-02
-#> 212:    1.0192e+02  -4.1204e+00  -2.3396e+00  -4.0662e+00  -1.0055e+00  -1.8011e-02   3.4746e-02   5.4375e-07   6.2747e-02   3.1588e-02   1.9405e-01   7.2360e-02   9.4525e-01   8.4466e-02   9.9581e-01   8.2952e-02
-#> 213:    1.0192e+02  -4.1204e+00  -2.3407e+00  -4.0649e+00  -1.0066e+00  -2.1077e-02   3.4708e-02   5.5843e-07   6.1940e-02   3.0715e-02   1.9382e-01   7.4602e-02   9.4611e-01   8.4322e-02   9.9397e-01   8.2717e-02
-#> 214:    1.0192e+02  -4.1204e+00  -2.3392e+00  -4.0648e+00  -1.0076e+00  -2.3417e-02   3.4282e-02   5.8157e-07   6.1893e-02   3.0158e-02   1.9322e-01   7.8942e-02   9.5250e-01   8.3922e-02   9.9723e-01   8.2793e-02
-#> 215:    1.0192e+02  -4.1204e+00  -2.3410e+00  -4.0645e+00  -1.0087e+00  -2.1950e-02   3.5820e-02   6.0691e-07   6.2032e-02   2.9890e-02   1.9172e-01   8.3774e-02   9.5617e-01   8.3280e-02   1.0003e+00   8.2881e-02
-#> 216:    1.0192e+02  -4.1203e+00  -2.3425e+00  -4.0628e+00  -1.0069e+00  -2.4268e-02   3.7597e-02   6.4187e-07   6.1733e-02   2.9353e-02   1.9092e-01   8.8150e-02   9.5834e-01   8.3091e-02   1.0027e+00   8.2753e-02
-#> 217:    1.0192e+02  -4.1203e+00  -2.3439e+00  -4.0613e+00  -1.0064e+00  -2.4197e-02   3.9291e-02   6.5775e-07   6.2318e-02   2.8903e-02   1.8958e-01   9.0470e-02   9.5766e-01   8.3234e-02   1.0020e+00   8.2707e-02
-#> 218:    1.0191e+02  -4.1203e+00  -2.3441e+00  -4.0619e+00  -1.0065e+00  -2.2460e-02   4.0043e-02   6.4921e-07   6.2280e-02   2.8349e-02   1.8800e-01   9.4476e-02   9.5499e-01   8.3416e-02   1.0036e+00   8.2628e-02
-#> 219:    1.0191e+02  -4.1203e+00  -2.3437e+00  -4.0624e+00  -1.0066e+00  -1.9698e-02   3.9735e-02   6.3365e-07   6.2264e-02   2.7720e-02   1.8768e-01   9.7275e-02   9.4994e-01   8.3350e-02   1.0047e+00   8.2572e-02
-#> 220:    1.0191e+02  -4.1203e+00  -2.3447e+00  -4.0630e+00  -1.0070e+00  -1.5871e-02   4.0198e-02   6.3507e-07   6.1981e-02   2.7259e-02   1.8786e-01   9.9168e-02   9.4781e-01   8.3355e-02   1.0046e+00   8.2752e-02
-#> 221:    1.0191e+02  -4.1203e+00  -2.3459e+00  -4.0638e+00  -1.0069e+00  -1.4298e-02   4.0161e-02   6.2865e-07   6.2113e-02   2.7201e-02   1.8810e-01   1.0163e-01   9.4863e-01   8.3154e-02   1.0042e+00   8.2670e-02
-#> 222:    1.0191e+02  -4.1203e+00  -2.3472e+00  -4.0646e+00  -1.0064e+00  -1.0921e-02   4.0310e-02   6.2450e-07   6.2436e-02   2.6979e-02   1.8736e-01   1.0306e-01   9.4914e-01   8.3081e-02   1.0050e+00   8.2757e-02
-#> 223:    1.0191e+02  -4.1203e+00  -2.3478e+00  -4.0650e+00  -1.0063e+00  -1.1053e-02   3.9741e-02   6.1973e-07   6.2918e-02   2.6636e-02   1.8806e-01   1.0506e-01   9.4996e-01   8.2927e-02   1.0054e+00   8.2579e-02
-#> 224:    1.0191e+02  -4.1203e+00  -2.3478e+00  -4.0653e+00  -1.0061e+00  -1.0324e-02   3.9480e-02   6.1421e-07   6.4180e-02   2.6403e-02   1.8833e-01   1.0733e-01   9.4750e-01   8.2697e-02   1.0033e+00   8.2517e-02
-#> 225:    1.0191e+02  -4.1203e+00  -2.3479e+00  -4.0654e+00  -1.0060e+00  -1.0650e-02   3.9188e-02   6.0959e-07   6.3862e-02   2.6122e-02   1.8815e-01   1.0786e-01   9.4504e-01   8.2833e-02   1.0002e+00   8.2398e-02
-#> 226:    1.0192e+02  -4.1204e+00  -2.3469e+00  -4.0657e+00  -1.0052e+00  -1.0205e-02   3.9129e-02   6.0577e-07   6.4045e-02   2.5875e-02   1.8762e-01   1.0921e-01   9.4663e-01   8.2599e-02   9.9857e-01   8.2472e-02
-#> 227:    1.0192e+02  -4.1203e+00  -2.3467e+00  -4.0658e+00  -1.0053e+00  -1.0189e-02   3.8797e-02   6.0837e-07   6.5125e-02   2.5679e-02   1.8721e-01   1.1060e-01   9.4729e-01   8.2470e-02   9.9802e-01   8.2753e-02
-#> 228:    1.0192e+02  -4.1204e+00  -2.3469e+00  -4.0657e+00  -1.0054e+00  -1.0575e-02   3.8741e-02   6.0738e-07   6.5467e-02   2.5448e-02   1.8548e-01   1.1134e-01   9.4840e-01   8.2580e-02   9.9829e-01   8.2888e-02
-#> 229:    1.0192e+02  -4.1204e+00  -2.3479e+00  -4.0650e+00  -1.0056e+00  -1.1215e-02   3.9360e-02   6.0182e-07   6.4817e-02   2.5237e-02   1.8448e-01   1.1090e-01   9.5039e-01   8.2625e-02   9.9900e-01   8.2896e-02
-#> 230:    1.0192e+02  -4.1204e+00  -2.3482e+00  -4.0652e+00  -1.0060e+00  -9.9775e-03   3.9501e-02   5.9385e-07   6.4132e-02   2.5093e-02   1.8510e-01   1.1122e-01   9.4938e-01   8.2763e-02   9.9961e-01   8.2886e-02
-#> 231:    1.0192e+02  -4.1204e+00  -2.3479e+00  -4.0654e+00  -1.0070e+00  -8.9509e-03   3.9907e-02   5.9290e-07   6.3744e-02   2.4829e-02   1.8560e-01   1.1062e-01   9.4790e-01   8.2872e-02   1.0022e+00   8.2955e-02
-#> 232:    1.0192e+02  -4.1204e+00  -2.3484e+00  -4.0657e+00  -1.0081e+00  -6.9066e-03   4.0738e-02   5.7862e-07   6.3242e-02   2.4729e-02   1.8626e-01   1.0975e-01   9.4866e-01   8.2846e-02   1.0036e+00   8.3065e-02
-#> 233:    1.0191e+02  -4.1204e+00  -2.3487e+00  -4.0660e+00  -1.0080e+00  -5.1163e-03   4.0708e-02   5.7326e-07   6.2392e-02   2.4475e-02   1.8701e-01   1.0932e-01   9.4816e-01   8.2933e-02   1.0059e+00   8.3155e-02
-#> 234:    1.0191e+02  -4.1204e+00  -2.3500e+00  -4.0660e+00  -1.0077e+00  -4.0637e-03   4.1065e-02   5.6885e-07   6.1938e-02   2.4418e-02   1.8673e-01   1.0923e-01   9.5001e-01   8.3005e-02   1.0080e+00   8.3207e-02
-#> 235:    1.0191e+02  -4.1204e+00  -2.3526e+00  -4.0653e+00  -1.0074e+00  -3.6541e-03   4.1151e-02   5.6498e-07   6.2228e-02   2.4447e-02   1.8667e-01   1.0995e-01   9.5059e-01   8.3101e-02   1.0055e+00   8.3101e-02
-#> 236:    1.0191e+02  -4.1204e+00  -2.3540e+00  -4.0648e+00  -1.0078e+00  -4.0127e-03   4.0966e-02   5.7047e-07   6.1779e-02   2.4457e-02   1.8777e-01   1.0971e-01   9.4919e-01   8.3203e-02   1.0044e+00   8.3078e-02
-#> 237:    1.0191e+02  -4.1204e+00  -2.3528e+00  -4.0645e+00  -1.0078e+00  -4.4251e-03   4.0491e-02   5.6811e-07   6.1507e-02   2.4421e-02   1.8827e-01   1.1047e-01   9.4870e-01   8.3149e-02   1.0031e+00   8.3008e-02
-#> 238:    1.0190e+02  -4.1204e+00  -2.3517e+00  -4.0647e+00  -1.0076e+00  -5.2540e-03   3.9988e-02   5.6832e-07   6.1612e-02   2.4262e-02   1.8801e-01   1.1019e-01   9.4737e-01   8.3172e-02   1.0037e+00   8.2959e-02
-#> 239:    1.0190e+02  -4.1204e+00  -2.3509e+00  -4.0650e+00  -1.0089e+00  -5.1598e-03   3.9373e-02   5.6396e-07   6.1635e-02   2.4040e-02   1.8812e-01   1.1055e-01   9.4885e-01   8.3140e-02   1.0053e+00   8.2956e-02
-#> 240:    1.0190e+02  -4.1204e+00  -2.3515e+00  -4.0643e+00  -1.0095e+00  -4.5817e-03   3.9031e-02   5.5929e-07   6.2233e-02   2.3840e-02   1.8766e-01   1.1014e-01   9.5018e-01   8.3172e-02   1.0066e+00   8.2937e-02
-#> 241:    1.0190e+02  -4.1204e+00  -2.3524e+00  -4.0642e+00  -1.0097e+00  -3.9061e-03   3.8686e-02   5.5496e-07   6.3349e-02   2.3663e-02   1.8759e-01   1.1046e-01   9.4922e-01   8.3162e-02   1.0064e+00   8.2940e-02
-#> 242:    1.0190e+02  -4.1204e+00  -2.3535e+00  -4.0642e+00  -1.0092e+00  -2.9411e-03   3.8674e-02   5.5359e-07   6.3930e-02   2.3604e-02   1.8742e-01   1.1027e-01   9.4748e-01   8.3177e-02   1.0052e+00   8.2955e-02
-#> 243:    1.0190e+02  -4.1204e+00  -2.3551e+00  -4.0642e+00  -1.0089e+00  -1.6071e-03   3.8635e-02   5.4669e-07   6.4141e-02   2.3570e-02   1.8666e-01   1.1022e-01   9.4770e-01   8.3208e-02   1.0048e+00   8.2962e-02
-#> 244:    1.0190e+02  -4.1204e+00  -2.3566e+00  -4.0645e+00  -1.0093e+00  -7.0474e-04   3.8502e-02   5.4194e-07   6.4399e-02   2.3591e-02   1.8627e-01   1.0938e-01   9.4615e-01   8.3402e-02   1.0043e+00   8.2891e-02
-#> 245:    1.0189e+02  -4.1204e+00  -2.3575e+00  -4.0649e+00  -1.0093e+00   1.3351e-03   3.8372e-02   5.4266e-07   6.4935e-02   2.3511e-02   1.8609e-01   1.0840e-01   9.4586e-01   8.3393e-02   1.0041e+00   8.2835e-02
-#> 246:    1.0189e+02  -4.1204e+00  -2.3595e+00  -4.0655e+00  -1.0085e+00   4.2316e-03   3.8487e-02   5.4393e-07   6.5284e-02   2.3457e-02   1.8581e-01   1.0811e-01   9.4656e-01   8.3372e-02   1.0036e+00   8.2746e-02
-#> 247:    1.0189e+02  -4.1204e+00  -2.3608e+00  -4.0659e+00  -1.0081e+00   6.1314e-03   3.8249e-02   5.4752e-07   6.5440e-02   2.3455e-02   1.8584e-01   1.0706e-01   9.4795e-01   8.3330e-02   1.0025e+00   8.2710e-02
-#> 248:    1.0189e+02  -4.1204e+00  -2.3617e+00  -4.0662e+00  -1.0084e+00   8.1978e-03   3.8017e-02   5.4713e-07   6.5853e-02   2.3439e-02   1.8637e-01   1.0634e-01   9.4748e-01   8.3377e-02   1.0016e+00   8.2677e-02
-#> 249:    1.0189e+02  -4.1204e+00  -2.3633e+00  -4.0667e+00  -1.0085e+00   9.8011e-03   3.7934e-02   5.5069e-07   6.6442e-02   2.3533e-02   1.8652e-01   1.0606e-01   9.4761e-01   8.3449e-02   1.0009e+00   8.2712e-02
-#> 250:    1.0189e+02  -4.1204e+00  -2.3644e+00  -4.0668e+00  -1.0087e+00   1.0992e-02   3.8199e-02   5.5486e-07   6.6746e-02   2.3638e-02   1.8739e-01   1.0611e-01   9.4838e-01   8.3442e-02   9.9958e-01   8.2692e-02
-#> 251:    1.0189e+02  -4.1204e+00  -2.3644e+00  -4.0671e+00  -1.0097e+00   1.2215e-02   3.8648e-02   5.5448e-07   6.6916e-02   2.3592e-02   1.8753e-01   1.0607e-01   9.4773e-01   8.3511e-02   9.9919e-01   8.2701e-02
-#> 252:    1.0189e+02  -4.1204e+00  -2.3645e+00  -4.0671e+00  -1.0100e+00   1.2881e-02   3.8792e-02   5.5615e-07   6.7323e-02   2.3559e-02   1.8811e-01   1.0641e-01   9.4665e-01   8.3575e-02   9.9809e-01   8.2743e-02
-#> 253:    1.0189e+02  -4.1204e+00  -2.3646e+00  -4.0675e+00  -1.0100e+00   1.3605e-02   3.9013e-02   5.5568e-07   6.7625e-02   2.3432e-02   1.8825e-01   1.0688e-01   9.4424e-01   8.3598e-02   9.9825e-01   8.2702e-02
-#> 254:    1.0189e+02  -4.1204e+00  -2.3642e+00  -4.0677e+00  -1.0101e+00   1.3119e-02   3.8838e-02   5.5231e-07   6.7802e-02   2.3429e-02   1.8849e-01   1.0680e-01   9.4281e-01   8.3706e-02   9.9829e-01   8.2631e-02
-#> 255:    1.0189e+02  -4.1204e+00  -2.3627e+00  -4.0679e+00  -1.0104e+00   1.2490e-02   3.8574e-02   5.4955e-07   6.8395e-02   2.3368e-02   1.8890e-01   1.0661e-01   9.4101e-01   8.3756e-02   9.9798e-01   8.2674e-02
-#> 256:    1.0189e+02  -4.1204e+00  -2.3615e+00  -4.0677e+00  -1.0102e+00   1.1525e-02   3.8502e-02   5.4764e-07   6.8824e-02   2.3405e-02   1.8912e-01   1.0649e-01   9.4109e-01   8.3709e-02   9.9811e-01   8.2698e-02
-#> 257:    1.0189e+02  -4.1204e+00  -2.3604e+00  -4.0673e+00  -1.0104e+00   1.0381e-02   3.8286e-02   5.4694e-07   6.9020e-02   2.3338e-02   1.8925e-01   1.0614e-01   9.4075e-01   8.3695e-02   9.9738e-01   8.2689e-02
-#> 258:    1.0189e+02  -4.1204e+00  -2.3591e+00  -4.0670e+00  -1.0103e+00   8.9559e-03   3.7972e-02   5.4665e-07   6.9077e-02   2.3267e-02   1.8919e-01   1.0590e-01   9.4089e-01   8.3618e-02   9.9742e-01   8.2681e-02
-#> 259:    1.0189e+02  -4.1204e+00  -2.3585e+00  -4.0669e+00  -1.0099e+00   8.6011e-03   3.7874e-02   5.4788e-07   6.9455e-02   2.3264e-02   1.8885e-01   1.0519e-01   9.3952e-01   8.3583e-02   9.9610e-01   8.2650e-02
-#> 260:    1.0189e+02  -4.1204e+00  -2.3584e+00  -4.0666e+00  -1.0098e+00   8.0471e-03   3.7771e-02   5.5294e-07   7.0269e-02   2.3292e-02   1.8877e-01   1.0442e-01   9.3898e-01   8.3519e-02   9.9504e-01   8.2641e-02
-#> 261:    1.0189e+02  -4.1204e+00  -2.3583e+00  -4.0664e+00  -1.0100e+00   7.9344e-03   3.7597e-02   5.5650e-07   7.1087e-02   2.3370e-02   1.8867e-01   1.0399e-01   9.3810e-01   8.3488e-02   9.9419e-01   8.2673e-02
-#> 262:    1.0189e+02  -4.1204e+00  -2.3575e+00  -4.0662e+00  -1.0106e+00   7.2123e-03   3.7203e-02   5.5375e-07   7.1794e-02   2.3393e-02   1.8855e-01   1.0356e-01   9.3773e-01   8.3458e-02   9.9406e-01   8.2739e-02
-#> 263:    1.0189e+02  -4.1204e+00  -2.3564e+00  -4.0659e+00  -1.0112e+00   6.6044e-03   3.6977e-02   5.5306e-07   7.2290e-02   2.3475e-02   1.8847e-01   1.0316e-01   9.3744e-01   8.3383e-02   9.9341e-01   8.2818e-02
-#> 264:    1.0189e+02  -4.1204e+00  -2.3549e+00  -4.0657e+00  -1.0118e+00   6.0119e-03   3.6749e-02   5.5152e-07   7.2896e-02   2.3530e-02   1.8849e-01   1.0277e-01   9.3658e-01   8.3443e-02   9.9248e-01   8.2877e-02
-#> 265:    1.0189e+02  -4.1204e+00  -2.3545e+00  -4.0655e+00  -1.0121e+00   5.6547e-03   3.6562e-02   5.4816e-07   7.3238e-02   2.3560e-02   1.8863e-01   1.0269e-01   9.3597e-01   8.3434e-02   9.9139e-01   8.2879e-02
-#> 266:    1.0189e+02  -4.1204e+00  -2.3545e+00  -4.0651e+00  -1.0121e+00   5.0995e-03   3.6357e-02   5.4458e-07   7.3522e-02   2.3561e-02   1.8883e-01   1.0270e-01   9.3607e-01   8.3407e-02   9.9133e-01   8.2857e-02
-#> 267:    1.0189e+02  -4.1204e+00  -2.3541e+00  -4.0648e+00  -1.0122e+00   4.0105e-03   3.6306e-02   5.4160e-07   7.3833e-02   2.3499e-02   1.8889e-01   1.0317e-01   9.3624e-01   8.3359e-02   9.9151e-01   8.2865e-02
-#> 268:    1.0189e+02  -4.1204e+00  -2.3530e+00  -4.0646e+00  -1.0122e+00   3.0925e-03   3.6248e-02   5.3845e-07   7.4663e-02   2.3413e-02   1.8895e-01   1.0371e-01   9.3624e-01   8.3277e-02   9.9210e-01   8.2909e-02
-#> 269:    1.0189e+02  -4.1204e+00  -2.3518e+00  -4.0643e+00  -1.0123e+00   2.0507e-03   3.6181e-02   5.3602e-07   7.5442e-02   2.3291e-02   1.8886e-01   1.0397e-01   9.3581e-01   8.3260e-02   9.9238e-01   8.2898e-02
-#> 270:    1.0189e+02  -4.1204e+00  -2.3513e+00  -4.0640e+00  -1.0127e+00   1.3309e-03   3.5900e-02   5.3234e-07   7.6677e-02   2.3220e-02   1.8860e-01   1.0367e-01   9.3573e-01   8.3250e-02   9.9169e-01   8.2904e-02
-#> 271:    1.0189e+02  -4.1204e+00  -2.3514e+00  -4.0637e+00  -1.0129e+00   1.1237e-03   3.5608e-02   5.3092e-07   7.7065e-02   2.3102e-02   1.8826e-01   1.0384e-01   9.3645e-01   8.3228e-02   9.9173e-01   8.2896e-02
-#> 272:    1.0189e+02  -4.1204e+00  -2.3510e+00  -4.0639e+00  -1.0134e+00   9.7855e-04   3.5328e-02   5.3100e-07   7.7173e-02   2.3014e-02   1.8817e-01   1.0367e-01   9.3538e-01   8.3266e-02   9.9139e-01   8.2943e-02
-#> 273:    1.0189e+02  -4.1204e+00  -2.3501e+00  -4.0643e+00  -1.0133e+00   1.1275e-03   3.5187e-02   5.3298e-07   7.7467e-02   2.2923e-02   1.8793e-01   1.0344e-01   9.3474e-01   8.3194e-02   9.9249e-01   8.2973e-02
-#> 274:    1.0189e+02  -4.1204e+00  -2.3498e+00  -4.0643e+00  -1.0134e+00   1.4524e-03   3.4996e-02   5.3407e-07   7.7929e-02   2.2819e-02   1.8837e-01   1.0316e-01   9.3399e-01   8.3168e-02   9.9307e-01   8.2981e-02
-#> 275:    1.0189e+02  -4.1204e+00  -2.3500e+00  -4.0641e+00  -1.0136e+00   1.3605e-03   3.4786e-02   5.3269e-07   7.8177e-02   2.2747e-02   1.8855e-01   1.0305e-01   9.3319e-01   8.3205e-02   9.9277e-01   8.2938e-02
-#> 276:    1.0189e+02  -4.1204e+00  -2.3504e+00  -4.0641e+00  -1.0136e+00   1.5273e-03   3.4581e-02   5.3172e-07   7.8495e-02   2.2764e-02   1.8824e-01   1.0297e-01   9.3267e-01   8.3223e-02   9.9204e-01   8.2884e-02
-#> 277:    1.0189e+02  -4.1204e+00  -2.3506e+00  -4.0643e+00  -1.0133e+00   1.2961e-03   3.4373e-02   5.2917e-07   7.8721e-02   2.2791e-02   1.8801e-01   1.0288e-01   9.3253e-01   8.3185e-02   9.9192e-01   8.2854e-02
-#> 278:    1.0189e+02  -4.1204e+00  -2.3508e+00  -4.0643e+00  -1.0129e+00   1.1750e-03   3.4396e-02   5.2693e-07   7.8999e-02   2.2787e-02   1.8793e-01   1.0278e-01   9.3279e-01   8.3113e-02   9.9144e-01   8.2856e-02
-#> 279:    1.0189e+02  -4.1204e+00  -2.3507e+00  -4.0642e+00  -1.0126e+00   1.2755e-03   3.4381e-02   5.2405e-07   7.9351e-02   2.2804e-02   1.8779e-01   1.0255e-01   9.3319e-01   8.3049e-02   9.9099e-01   8.2875e-02
-#> 280:    1.0189e+02  -4.1204e+00  -2.3507e+00  -4.0641e+00  -1.0127e+00   6.3408e-04   3.4519e-02   5.2180e-07   7.9825e-02   2.2801e-02   1.8775e-01   1.0292e-01   9.3349e-01   8.2970e-02   9.9076e-01   8.2918e-02
-#> 281:    1.0189e+02  -4.1204e+00  -2.3508e+00  -4.0639e+00  -1.0124e+00   6.2438e-04   3.4782e-02   5.1859e-07   8.0328e-02   2.2816e-02   1.8757e-01   1.0299e-01   9.3299e-01   8.3025e-02   9.9050e-01   8.2897e-02
-#> 282:    1.0189e+02  -4.1205e+00  -2.3511e+00  -4.0641e+00  -1.0122e+00   1.1770e-03   3.4754e-02   5.1798e-07   8.0649e-02   2.2836e-02   1.8766e-01   1.0297e-01   9.3351e-01   8.2989e-02   9.9171e-01   8.2893e-02
-#> 283:    1.0189e+02  -4.1205e+00  -2.3519e+00  -4.0644e+00  -1.0120e+00   2.1716e-03   3.4711e-02   5.1567e-07   8.0910e-02   2.2836e-02   1.8774e-01   1.0270e-01   9.3288e-01   8.3029e-02   9.9246e-01   8.2853e-02
-#> 284:    1.0189e+02  -4.1205e+00  -2.3524e+00  -4.0647e+00  -1.0115e+00   2.6623e-03   3.4646e-02   5.1350e-07   8.1153e-02   2.2950e-02   1.8775e-01   1.0277e-01   9.3238e-01   8.2990e-02   9.9212e-01   8.2836e-02
-#> 285:    1.0189e+02  -4.1205e+00  -2.3531e+00  -4.0649e+00  -1.0116e+00   3.7830e-03   3.4626e-02   5.1216e-07   8.1058e-02   2.3007e-02   1.8782e-01   1.0270e-01   9.3232e-01   8.3017e-02   9.9094e-01   8.2829e-02
-#> 286:    1.0189e+02  -4.1205e+00  -2.3539e+00  -4.0651e+00  -1.0111e+00   5.1752e-03   3.4599e-02   5.0989e-07   8.0970e-02   2.3004e-02   1.8757e-01   1.0254e-01   9.3280e-01   8.3006e-02   9.9130e-01   8.2818e-02
-#> 287:    1.0189e+02  -4.1205e+00  -2.3541e+00  -4.0654e+00  -1.0112e+00   6.3747e-03   3.4592e-02   5.0930e-07   8.1117e-02   2.2959e-02   1.8756e-01   1.0222e-01   9.3212e-01   8.3146e-02   9.9183e-01   8.2863e-02
-#> 288:    1.0189e+02  -4.1205e+00  -2.3540e+00  -4.0656e+00  -1.0115e+00   6.5668e-03   3.4598e-02   5.0976e-07   8.1125e-02   2.2895e-02   1.8782e-01   1.0183e-01   9.3310e-01   8.3169e-02   9.9404e-01   8.2836e-02
-#> 289:    1.0189e+02  -4.1205e+00  -2.3539e+00  -4.0658e+00  -1.0119e+00   7.3521e-03   3.4525e-02   5.1097e-07   8.1097e-02   2.2869e-02   1.8753e-01   1.0126e-01   9.3336e-01   8.3244e-02   9.9435e-01   8.2833e-02
-#> 290:    1.0189e+02  -4.1205e+00  -2.3539e+00  -4.0659e+00  -1.0122e+00   7.5226e-03   3.4377e-02   5.0846e-07   8.1212e-02   2.2831e-02   1.8724e-01   1.0073e-01   9.3292e-01   8.3261e-02   9.9415e-01   8.2837e-02
-#> 291:    1.0189e+02  -4.1205e+00  -2.3536e+00  -4.0659e+00  -1.0122e+00   7.2889e-03   3.4263e-02   5.0823e-07   8.1182e-02   2.2801e-02   1.8711e-01   1.0056e-01   9.3309e-01   8.3300e-02   9.9427e-01   8.2805e-02
-#> 292:    1.0189e+02  -4.1205e+00  -2.3531e+00  -4.0659e+00  -1.0123e+00   7.1827e-03   3.4146e-02   5.0825e-07   8.1696e-02   2.2760e-02   1.8703e-01   1.0039e-01   9.3324e-01   8.3306e-02   9.9379e-01   8.2784e-02
-#> 293:    1.0189e+02  -4.1205e+00  -2.3528e+00  -4.0660e+00  -1.0125e+00   7.7142e-03   3.4126e-02   5.0971e-07   8.2026e-02   2.2705e-02   1.8721e-01   1.0036e-01   9.3316e-01   8.3316e-02   9.9357e-01   8.2756e-02
-#> 294:    1.0188e+02  -4.1204e+00  -2.3529e+00  -4.0663e+00  -1.0126e+00   8.5146e-03   3.4314e-02   5.0823e-07   8.2197e-02   2.2608e-02   1.8743e-01   1.0009e-01   9.3356e-01   8.3308e-02   9.9367e-01   8.2719e-02
-#> 295:    1.0188e+02  -4.1204e+00  -2.3532e+00  -4.0666e+00  -1.0123e+00   9.2199e-03   3.4472e-02   5.0839e-07   8.2550e-02   2.2529e-02   1.8745e-01   9.9731e-02   9.3393e-01   8.3255e-02   9.9373e-01   8.2686e-02
-#> 296:    1.0188e+02  -4.1204e+00  -2.3537e+00  -4.0667e+00  -1.0121e+00   9.7869e-03   3.4678e-02   5.0983e-07   8.3059e-02   2.2497e-02   1.8729e-01   9.9260e-02   9.3395e-01   8.3198e-02   9.9300e-01   8.2681e-02
-#> 297:    1.0188e+02  -4.1204e+00  -2.3540e+00  -4.0670e+00  -1.0118e+00   1.0166e-02   3.4957e-02   5.1049e-07   8.3080e-02   2.2448e-02   1.8710e-01   9.8969e-02   9.3321e-01   8.3178e-02   9.9255e-01   8.2663e-02
-#> 298:    1.0188e+02  -4.1204e+00  -2.3544e+00  -4.0673e+00  -1.0117e+00   1.0649e-02   3.5259e-02   5.1103e-07   8.3179e-02   2.2383e-02   1.8704e-01   9.8442e-02   9.3227e-01   8.3199e-02   9.9266e-01   8.2646e-02
-#> 299:    1.0188e+02  -4.1204e+00  -2.3542e+00  -4.0676e+00  -1.0117e+00   1.0927e-02   3.5438e-02   5.1128e-07   8.3068e-02   2.2378e-02   1.8699e-01   9.8203e-02   9.3263e-01   8.3138e-02   9.9353e-01   8.2671e-02
-#> 300:    1.0188e+02  -4.1204e+00  -2.3544e+00  -4.0678e+00  -1.0116e+00   1.1083e-02   3.5694e-02   5.1107e-07   8.2896e-02   2.2344e-02   1.8733e-01   9.7775e-02   9.3179e-01   8.3124e-02   9.9379e-01   8.2657e-02
-#> 301:    1.0188e+02  -4.1204e+00  -2.3542e+00  -4.0680e+00  -1.0115e+00   1.0992e-02   3.5896e-02   5.1262e-07   8.2816e-02   2.2349e-02   1.8753e-01   9.7431e-02   9.3209e-01   8.3086e-02   9.9388e-01   8.2674e-02
-#> 302:    1.0188e+02  -4.1204e+00  -2.3540e+00  -4.0681e+00  -1.0113e+00   1.0410e-02   3.6050e-02   5.1256e-07   8.2817e-02   2.2308e-02   1.8734e-01   9.7153e-02   9.3221e-01   8.3073e-02   9.9402e-01   8.2670e-02
-#> 303:    1.0188e+02  -4.1204e+00  -2.3540e+00  -4.0681e+00  -1.0112e+00   1.0301e-02   3.6150e-02   5.1127e-07   8.2826e-02   2.2325e-02   1.8730e-01   9.6656e-02   9.3192e-01   8.3040e-02   9.9393e-01   8.2665e-02
-#> 304:    1.0188e+02  -4.1204e+00  -2.3536e+00  -4.0681e+00  -1.0113e+00   1.0235e-02   3.6393e-02   5.1176e-07   8.2606e-02   2.2353e-02   1.8724e-01   9.6171e-02   9.3161e-01   8.3068e-02   9.9361e-01   8.2698e-02
-#> 305:    1.0188e+02  -4.1204e+00  -2.3533e+00  -4.0683e+00  -1.0112e+00   9.9655e-03   3.6369e-02   5.1442e-07   8.2520e-02   2.2378e-02   1.8707e-01   9.5656e-02   9.3113e-01   8.3109e-02   9.9338e-01   8.2731e-02
-#> 306:    1.0188e+02  -4.1204e+00  -2.3531e+00  -4.0684e+00  -1.0110e+00   9.9701e-03   3.6346e-02   5.1546e-07   8.2789e-02   2.2360e-02   1.8702e-01   9.5116e-02   9.3102e-01   8.3065e-02   9.9405e-01   8.2761e-02
-#> 307:    1.0188e+02  -4.1204e+00  -2.3530e+00  -4.0684e+00  -1.0112e+00   1.0194e-02   3.6300e-02   5.1196e-07   8.3035e-02   2.2381e-02   1.8704e-01   9.4760e-02   9.3082e-01   8.3003e-02   9.9410e-01   8.2779e-02
-#> 308:    1.0189e+02  -4.1204e+00  -2.3530e+00  -4.0685e+00  -1.0109e+00   9.9531e-03   3.6400e-02   5.1140e-07   8.3511e-02   2.2334e-02   1.8726e-01   9.4494e-02   9.3151e-01   8.2910e-02   9.9484e-01   8.2760e-02
-#> 309:    1.0188e+02  -4.1204e+00  -2.3530e+00  -4.0685e+00  -1.0107e+00   1.0089e-02   3.6382e-02   5.1081e-07   8.3917e-02   2.2276e-02   1.8728e-01   9.4285e-02   9.3133e-01   8.2875e-02   9.9545e-01   8.2757e-02
-#> 310:    1.0188e+02  -4.1204e+00  -2.3533e+00  -4.0685e+00  -1.0105e+00   1.0805e-02   3.6375e-02   5.1041e-07   8.4245e-02   2.2246e-02   1.8753e-01   9.3894e-02   9.3052e-01   8.2899e-02   9.9500e-01   8.2743e-02
-#> 311:    1.0188e+02  -4.1204e+00  -2.3534e+00  -4.0685e+00  -1.0103e+00   1.1449e-02   3.6311e-02   5.0884e-07   8.4434e-02   2.2231e-02   1.8783e-01   9.3542e-02   9.3039e-01   8.2864e-02   9.9458e-01   8.2733e-02
-#> 312:    1.0188e+02  -4.1204e+00  -2.3535e+00  -4.0685e+00  -1.0102e+00   1.2173e-02   3.6373e-02   5.0821e-07   8.4730e-02   2.2176e-02   1.8769e-01   9.3317e-02   9.2982e-01   8.2916e-02   9.9438e-01   8.2740e-02
-#> 313:    1.0188e+02  -4.1204e+00  -2.3533e+00  -4.0688e+00  -1.0103e+00   1.2812e-02   3.6558e-02   5.0751e-07   8.5211e-02   2.2131e-02   1.8754e-01   9.3387e-02   9.2962e-01   8.2892e-02   9.9458e-01   8.2741e-02
-#> 314:    1.0188e+02  -4.1204e+00  -2.3534e+00  -4.0690e+00  -1.0103e+00   1.3241e-02   3.6680e-02   5.0887e-07   8.5667e-02   2.2079e-02   1.8772e-01   9.3442e-02   9.2941e-01   8.2947e-02   9.9511e-01   8.2743e-02
-#> 315:    1.0188e+02  -4.1204e+00  -2.3534e+00  -4.0691e+00  -1.0104e+00   1.3699e-02   3.6924e-02   5.0965e-07   8.5865e-02   2.2028e-02   1.8766e-01   9.3264e-02   9.2904e-01   8.2986e-02   9.9543e-01   8.2763e-02
-#> 316:    1.0188e+02  -4.1204e+00  -2.3533e+00  -4.0693e+00  -1.0103e+00   1.4121e-02   3.7218e-02   5.1041e-07   8.6216e-02   2.2076e-02   1.8773e-01   9.3035e-02   9.2917e-01   8.3013e-02   9.9486e-01   8.2782e-02
-#> 317:    1.0188e+02  -4.1204e+00  -2.3533e+00  -4.0694e+00  -1.0102e+00   1.4588e-02   3.7304e-02   5.0994e-07   8.6513e-02   2.2128e-02   1.8773e-01   9.2766e-02   9.2943e-01   8.3025e-02   9.9441e-01   8.2779e-02
-#> 318:    1.0188e+02  -4.1204e+00  -2.3534e+00  -4.0693e+00  -1.0101e+00   1.4714e-02   3.7538e-02   5.0773e-07   8.6801e-02   2.2128e-02   1.8767e-01   9.2698e-02   9.2907e-01   8.3052e-02   9.9378e-01   8.2780e-02
-#> 319:    1.0187e+02  -4.1204e+00  -2.3533e+00  -4.0692e+00  -1.0099e+00   1.4582e-02   3.7563e-02   5.0550e-07   8.6669e-02   2.2135e-02   1.8775e-01   9.2604e-02   9.2925e-01   8.3042e-02   9.9356e-01   8.2773e-02
-#> 320:    1.0187e+02  -4.1204e+00  -2.3535e+00  -4.0690e+00  -1.0102e+00   1.4511e-02   3.7580e-02   5.0281e-07   8.6617e-02   2.2121e-02   1.8780e-01   9.2508e-02   9.3001e-01   8.3032e-02   9.9322e-01   8.2780e-02
-#> 321:    1.0187e+02  -4.1204e+00  -2.3534e+00  -4.0688e+00  -1.0100e+00   1.4288e-02   3.7624e-02   5.0172e-07   8.6311e-02   2.2115e-02   1.8783e-01   9.2445e-02   9.3011e-01   8.3054e-02   9.9288e-01   8.2772e-02
-#> 322:    1.0187e+02  -4.1204e+00  -2.3532e+00  -4.0687e+00  -1.0098e+00   1.3834e-02   3.7497e-02   5.0086e-07   8.6187e-02   2.2111e-02   1.8791e-01   9.2699e-02   9.3037e-01   8.3069e-02   9.9284e-01   8.2773e-02
-#> 323:    1.0187e+02  -4.1204e+00  -2.3524e+00  -4.0683e+00  -1.0097e+00   1.2977e-02   3.7420e-02   4.9925e-07   8.6082e-02   2.2084e-02   1.8818e-01   9.3123e-02   9.3036e-01   8.3012e-02   9.9265e-01   8.2813e-02
-#> 324:    1.0187e+02  -4.1204e+00  -2.3523e+00  -4.0682e+00  -1.0096e+00   1.2679e-02   3.7420e-02   4.9836e-07   8.5721e-02   2.2071e-02   1.8829e-01   9.3535e-02   9.3062e-01   8.3011e-02   9.9241e-01   8.2827e-02
-#> 325:    1.0187e+02  -4.1204e+00  -2.3520e+00  -4.0680e+00  -1.0094e+00   1.2196e-02   3.7298e-02   4.9735e-07   8.5411e-02   2.2028e-02   1.8848e-01   9.3706e-02   9.3043e-01   8.3020e-02   9.9256e-01   8.2826e-02
-#> 326:    1.0187e+02  -4.1204e+00  -2.3517e+00  -4.0678e+00  -1.0091e+00   1.1924e-02   3.7185e-02   4.9661e-07   8.5453e-02   2.1983e-02   1.8830e-01   9.3688e-02   9.3050e-01   8.2996e-02   9.9284e-01   8.2806e-02
-#> 327:    1.0187e+02  -4.1204e+00  -2.3516e+00  -4.0677e+00  -1.0090e+00   1.1449e-02   3.7155e-02   4.9755e-07   8.5761e-02   2.1967e-02   1.8819e-01   9.3936e-02   9.3052e-01   8.2912e-02   9.9245e-01   8.2806e-02
-#> 328:    1.0187e+02  -4.1204e+00  -2.3514e+00  -4.0675e+00  -1.0089e+00   1.0758e-02   3.7146e-02   4.9892e-07   8.6019e-02   2.1971e-02   1.8806e-01   9.4361e-02   9.3070e-01   8.2833e-02   9.9182e-01   8.2840e-02
-#> 329:    1.0187e+02  -4.1204e+00  -2.3515e+00  -4.0672e+00  -1.0087e+00   1.0256e-02   3.7342e-02   5.0019e-07   8.5965e-02   2.1989e-02   1.8796e-01   9.4614e-02   9.3067e-01   8.2818e-02   9.9159e-01   8.2858e-02
-#> 330:    1.0187e+02  -4.1204e+00  -2.3520e+00  -4.0670e+00  -1.0086e+00   1.0021e-02   3.7376e-02   4.9911e-07   8.6124e-02   2.1978e-02   1.8796e-01   9.4836e-02   9.3036e-01   8.2819e-02   9.9148e-01   8.2866e-02
-#> 331:    1.0187e+02  -4.1204e+00  -2.3521e+00  -4.0668e+00  -1.0086e+00   9.5790e-03   3.7296e-02   4.9753e-07   8.6122e-02   2.1951e-02   1.8782e-01   9.5042e-02   9.3064e-01   8.2783e-02   9.9196e-01   8.2863e-02
-#> 332:    1.0187e+02  -4.1204e+00  -2.3523e+00  -4.0667e+00  -1.0085e+00   9.2971e-03   3.7221e-02   4.9729e-07   8.6215e-02   2.1952e-02   1.8787e-01   9.5082e-02   9.3103e-01   8.2782e-02   9.9224e-01   8.2861e-02
-#> 333:    1.0187e+02  -4.1204e+00  -2.3524e+00  -4.0667e+00  -1.0084e+00   9.2591e-03   3.7097e-02   4.9556e-07   8.6302e-02   2.1922e-02   1.8792e-01   9.5155e-02   9.3058e-01   8.2798e-02   9.9202e-01   8.2831e-02
-#> 334:    1.0187e+02  -4.1204e+00  -2.3528e+00  -4.0667e+00  -1.0082e+00   9.5799e-03   3.6997e-02   4.9398e-07   8.6409e-02   2.1911e-02   1.8792e-01   9.5231e-02   9.3035e-01   8.2810e-02   9.9157e-01   8.2803e-02
-#> 335:    1.0187e+02  -4.1204e+00  -2.3529e+00  -4.0667e+00  -1.0080e+00   9.5724e-03   3.6912e-02   4.9206e-07   8.6310e-02   2.1923e-02   1.8791e-01   9.5379e-02   9.3054e-01   8.2759e-02   9.9143e-01   8.2776e-02
-#> 336:    1.0187e+02  -4.1204e+00  -2.3525e+00  -4.0667e+00  -1.0082e+00   9.5794e-03   3.6983e-02   4.9255e-07   8.6282e-02   2.1882e-02   1.8789e-01   9.5422e-02   9.3064e-01   8.2705e-02   9.9138e-01   8.2778e-02
-#> 337:    1.0187e+02  -4.1204e+00  -2.3525e+00  -4.0669e+00  -1.0083e+00   1.0008e-02   3.6943e-02   4.9278e-07   8.6483e-02   2.1844e-02   1.8794e-01   9.5240e-02   9.2981e-01   8.2753e-02   9.9100e-01   8.2774e-02
-#> 338:    1.0187e+02  -4.1204e+00  -2.3525e+00  -4.0669e+00  -1.0084e+00   1.0297e-02   3.6869e-02   4.9309e-07   8.6547e-02   2.1803e-02   1.8808e-01   9.5094e-02   9.2978e-01   8.2764e-02   9.9113e-01   8.2759e-02
-#> 339:    1.0187e+02  -4.1204e+00  -2.3528e+00  -4.0669e+00  -1.0083e+00   1.0465e-02   3.6822e-02   4.9257e-07   8.6779e-02   2.1769e-02   1.8813e-01   9.5062e-02   9.3020e-01   8.2702e-02   9.9135e-01   8.2750e-02
-#> 340:    1.0187e+02  -4.1204e+00  -2.3531e+00  -4.0668e+00  -1.0083e+00   1.0321e-02   3.6733e-02   4.9228e-07   8.7033e-02   2.1721e-02   1.8827e-01   9.4862e-02   9.3062e-01   8.2698e-02   9.9195e-01   8.2729e-02
-#> 341:    1.0187e+02  -4.1204e+00  -2.3531e+00  -4.0670e+00  -1.0085e+00   1.0501e-02   3.6671e-02   4.9236e-07   8.7297e-02   2.1733e-02   1.8820e-01   9.4558e-02   9.3121e-01   8.2677e-02   9.9238e-01   8.2713e-02
-#> 342:    1.0187e+02  -4.1204e+00  -2.3534e+00  -4.0670e+00  -1.0085e+00   1.0818e-02   3.6715e-02   4.9084e-07   8.7450e-02   2.1726e-02   1.8801e-01   9.4252e-02   9.3160e-01   8.2657e-02   9.9232e-01   8.2708e-02
-#> 343:    1.0187e+02  -4.1204e+00  -2.3535e+00  -4.0670e+00  -1.0087e+00   1.1046e-02   3.6784e-02   4.8872e-07   8.7718e-02   2.1718e-02   1.8799e-01   9.3887e-02   9.3187e-01   8.2645e-02   9.9225e-01   8.2722e-02
-#> 344:    1.0187e+02  -4.1204e+00  -2.3535e+00  -4.0670e+00  -1.0087e+00   1.0652e-02   3.6736e-02   4.8852e-07   8.7725e-02   2.1730e-02   1.8792e-01   9.3731e-02   9.3202e-01   8.2618e-02   9.9218e-01   8.2712e-02
-#> 345:    1.0187e+02  -4.1204e+00  -2.3536e+00  -4.0669e+00  -1.0090e+00   1.0445e-02   3.6714e-02   4.8690e-07   8.7782e-02   2.1751e-02   1.8798e-01   9.3450e-02   9.3223e-01   8.2582e-02   9.9239e-01   8.2706e-02
-#> 346:    1.0187e+02  -4.1204e+00  -2.3536e+00  -4.0668e+00  -1.0089e+00   1.0173e-02   3.6743e-02   4.8656e-07   8.7733e-02   2.1810e-02   1.8814e-01   9.3151e-02   9.3257e-01   8.2575e-02   9.9181e-01   8.2708e-02
-#> 347:    1.0187e+02  -4.1205e+00  -2.3532e+00  -4.0668e+00  -1.0089e+00   9.9457e-03   3.6808e-02   4.8756e-07   8.7948e-02   2.1819e-02   1.8813e-01   9.3040e-02   9.3255e-01   8.2599e-02   9.9124e-01   8.2727e-02
-#> 348:    1.0187e+02  -4.1205e+00  -2.3534e+00  -4.0667e+00  -1.0090e+00   9.8498e-03   3.6967e-02   4.8883e-07   8.7998e-02   2.1841e-02   1.8820e-01   9.3180e-02   9.3259e-01   8.2612e-02   9.9148e-01   8.2750e-02
-#> 349:    1.0187e+02  -4.1205e+00  -2.3535e+00  -4.0668e+00  -1.0091e+00   9.6211e-03   3.6891e-02   4.8867e-07   8.8006e-02   2.1930e-02   1.8819e-01   9.3390e-02   9.3232e-01   8.2612e-02   9.9073e-01   8.2738e-02
-#> 350:    1.0187e+02  -4.1205e+00  -2.3534e+00  -4.0669e+00  -1.0090e+00   9.7176e-03   3.6813e-02   4.8925e-07   8.7923e-02   2.1964e-02   1.8820e-01   9.3434e-02   9.3224e-01   8.2600e-02   9.9031e-01   8.2734e-02
-#> 351:    1.0187e+02  -4.1204e+00  -2.3535e+00  -4.0669e+00  -1.0090e+00   9.6652e-03   3.6769e-02   4.8873e-07   8.7985e-02   2.2046e-02   1.8814e-01   9.3529e-02   9.3220e-01   8.2558e-02   9.8978e-01   8.2728e-02
-#> 352:    1.0187e+02  -4.1204e+00  -2.3536e+00  -4.0669e+00  -1.0089e+00   9.8745e-03   3.6732e-02   4.8969e-07   8.8016e-02   2.2094e-02   1.8799e-01   9.3644e-02   9.3168e-01   8.2577e-02   9.8913e-01   8.2722e-02
-#> 353:    1.0187e+02  -4.1204e+00  -2.3537e+00  -4.0669e+00  -1.0088e+00   9.7530e-03   3.6700e-02   4.9008e-07   8.7949e-02   2.2116e-02   1.8798e-01   9.3769e-02   9.3165e-01   8.2559e-02   9.8871e-01   8.2711e-02
-#> 354:    1.0187e+02  -4.1204e+00  -2.3538e+00  -4.0667e+00  -1.0089e+00   9.4103e-03   3.6653e-02   4.9045e-07   8.7894e-02   2.2118e-02   1.8793e-01   9.3872e-02   9.3188e-01   8.2551e-02   9.8887e-01   8.2692e-02
-#> 355:    1.0187e+02  -4.1204e+00  -2.3540e+00  -4.0666e+00  -1.0088e+00   9.1684e-03   3.6536e-02   4.9125e-07   8.7920e-02   2.2107e-02   1.8812e-01   9.4123e-02   9.3223e-01   8.2517e-02   9.8893e-01   8.2687e-02
-#> 356:    1.0187e+02  -4.1204e+00  -2.3542e+00  -4.0664e+00  -1.0086e+00   8.9025e-03   3.6431e-02   4.9325e-07   8.7949e-02   2.2110e-02   1.8827e-01   9.4135e-02   9.3252e-01   8.2503e-02   9.8907e-01   8.2649e-02
-#> 357:    1.0187e+02  -4.1204e+00  -2.3542e+00  -4.0663e+00  -1.0085e+00   8.6757e-03   3.6417e-02   4.9505e-07   8.8052e-02   2.2096e-02   1.8848e-01   9.4192e-02   9.3281e-01   8.2490e-02   9.8957e-01   8.2624e-02
-#> 358:    1.0187e+02  -4.1204e+00  -2.3542e+00  -4.0661e+00  -1.0084e+00   8.1812e-03   3.6349e-02   4.9610e-07   8.8344e-02   2.2104e-02   1.8844e-01   9.4129e-02   9.3294e-01   8.2493e-02   9.8977e-01   8.2614e-02
-#> 359:    1.0187e+02  -4.1204e+00  -2.3541e+00  -4.0659e+00  -1.0083e+00   8.0905e-03   3.6475e-02   4.9675e-07   8.8647e-02   2.2116e-02   1.8831e-01   9.4146e-02   9.3322e-01   8.2473e-02   9.8978e-01   8.2622e-02
-#> 360:    1.0187e+02  -4.1204e+00  -2.3542e+00  -4.0657e+00  -1.0082e+00   7.8390e-03   3.6468e-02   4.9649e-07   8.8981e-02   2.2120e-02   1.8815e-01   9.4249e-02   9.3361e-01   8.2430e-02   9.8997e-01   8.2616e-02
-#> 361:    1.0187e+02  -4.1204e+00  -2.3545e+00  -4.0656e+00  -1.0083e+00   7.9104e-03   3.6434e-02   4.9737e-07   8.9447e-02   2.2133e-02   1.8808e-01   9.4085e-02   9.3387e-01   8.2426e-02   9.9025e-01   8.2616e-02
-#> 362:    1.0187e+02  -4.1204e+00  -2.3547e+00  -4.0655e+00  -1.0087e+00   7.6341e-03   3.6428e-02   4.9748e-07   8.9872e-02   2.2148e-02   1.8805e-01   9.4025e-02   9.3407e-01   8.2456e-02   9.9070e-01   8.2609e-02
-#> 363:    1.0187e+02  -4.1204e+00  -2.3546e+00  -4.0653e+00  -1.0087e+00   7.2351e-03   3.6392e-02   4.9842e-07   9.0125e-02   2.2179e-02   1.8818e-01   9.4157e-02   9.3437e-01   8.2439e-02   9.9051e-01   8.2626e-02
-#> 364:    1.0187e+02  -4.1204e+00  -2.3543e+00  -4.0651e+00  -1.0089e+00   6.7851e-03   3.6303e-02   4.9890e-07   9.0448e-02   2.2189e-02   1.8831e-01   9.4432e-02   9.3513e-01   8.2433e-02   9.9051e-01   8.2655e-02
-#> 365:    1.0187e+02  -4.1204e+00  -2.3538e+00  -4.0650e+00  -1.0089e+00   6.2935e-03   3.6267e-02   4.9829e-07   9.0718e-02   2.2204e-02   1.8818e-01   9.4507e-02   9.3580e-01   8.2387e-02   9.9049e-01   8.2678e-02
-#> 366:    1.0187e+02  -4.1204e+00  -2.3535e+00  -4.0649e+00  -1.0088e+00   5.8910e-03   3.6339e-02   4.9911e-07   9.0727e-02   2.2231e-02   1.8801e-01   9.4683e-02   9.3567e-01   8.2359e-02   9.8997e-01   8.2681e-02
-#> 367:    1.0187e+02  -4.1204e+00  -2.3533e+00  -4.0649e+00  -1.0088e+00   5.8610e-03   3.6366e-02   5.0123e-07   9.0732e-02   2.2245e-02   1.8793e-01   9.4666e-02   9.3556e-01   8.2339e-02   9.8945e-01   8.2691e-02
-#> 368:    1.0187e+02  -4.1204e+00  -2.3531e+00  -4.0650e+00  -1.0088e+00   6.1043e-03   3.6424e-02   5.0107e-07   9.0729e-02   2.2248e-02   1.8780e-01   9.4599e-02   9.3554e-01   8.2315e-02   9.8903e-01   8.2705e-02
-#> 369:    1.0187e+02  -4.1204e+00  -2.3530e+00  -4.0650e+00  -1.0088e+00   6.1767e-03   3.6436e-02   5.0046e-07   9.0617e-02   2.2226e-02   1.8787e-01   9.4410e-02   9.3504e-01   8.2361e-02   9.8843e-01   8.2694e-02
-#> 370:    1.0187e+02  -4.1204e+00  -2.3528e+00  -4.0651e+00  -1.0088e+00   6.2532e-03   3.6467e-02   5.0024e-07   9.0741e-02   2.2223e-02   1.8794e-01   9.4288e-02   9.3472e-01   8.2374e-02   9.8781e-01   8.2703e-02
-#> 371:    1.0186e+02  -4.1204e+00  -2.3525e+00  -4.0652e+00  -1.0088e+00   6.2117e-03   3.6465e-02   4.9964e-07   9.0904e-02   2.2220e-02   1.8788e-01   9.4310e-02   9.3470e-01   8.2367e-02   9.8730e-01   8.2731e-02
-#> 372:    1.0186e+02  -4.1204e+00  -2.3524e+00  -4.0651e+00  -1.0089e+00   6.1363e-03   3.6367e-02   5.0037e-07   9.1177e-02   2.2230e-02   1.8783e-01   9.4288e-02   9.3496e-01   8.2365e-02   9.8699e-01   8.2729e-02
-#> 373:    1.0186e+02  -4.1204e+00  -2.3523e+00  -4.0650e+00  -1.0089e+00   6.0384e-03   3.6353e-02   5.0195e-07   9.1402e-02   2.2219e-02   1.8764e-01   9.4343e-02   9.3478e-01   8.2430e-02   9.8641e-01   8.2747e-02
-#> 374:    1.0186e+02  -4.1204e+00  -2.3523e+00  -4.0650e+00  -1.0091e+00   5.9821e-03   3.6377e-02   5.0424e-07   9.1532e-02   2.2243e-02   1.8761e-01   9.4219e-02   9.3466e-01   8.2418e-02   9.8614e-01   8.2735e-02
-#> 375:    1.0186e+02  -4.1204e+00  -2.3524e+00  -4.0649e+00  -1.0091e+00   5.8843e-03   3.6358e-02   5.0568e-07   9.1556e-02   2.2250e-02   1.8768e-01   9.4173e-02   9.3432e-01   8.2413e-02   9.8592e-01   8.2728e-02
-#> 376:    1.0186e+02  -4.1204e+00  -2.3526e+00  -4.0649e+00  -1.0090e+00   5.7256e-03   3.6406e-02   5.0673e-07   9.1590e-02   2.2260e-02   1.8765e-01   9.4159e-02   9.3417e-01   8.2400e-02   9.8565e-01   8.2701e-02
-#> 377:    1.0186e+02  -4.1204e+00  -2.3527e+00  -4.0647e+00  -1.0091e+00   5.2782e-03   3.6397e-02   5.0740e-07   9.1564e-02   2.2263e-02   1.8765e-01   9.4084e-02   9.3434e-01   8.2395e-02   9.8563e-01   8.2680e-02
-#> 378:    1.0186e+02  -4.1204e+00  -2.3524e+00  -4.0646e+00  -1.0091e+00   4.8184e-03   3.6478e-02   5.0759e-07   9.1590e-02   2.2213e-02   1.8766e-01   9.4162e-02   9.3432e-01   8.2353e-02   9.8595e-01   8.2681e-02
-#> 379:    1.0186e+02  -4.1204e+00  -2.3521e+00  -4.0646e+00  -1.0089e+00   4.4861e-03   3.6557e-02   5.0710e-07   9.1595e-02   2.2159e-02   1.8767e-01   9.3894e-02   9.3395e-01   8.2341e-02   9.8636e-01   8.2671e-02
-#> 380:    1.0186e+02  -4.1204e+00  -2.3517e+00  -4.0644e+00  -1.0089e+00   3.9799e-03   3.6543e-02   5.0682e-07   9.1532e-02   2.2143e-02   1.8768e-01   9.3854e-02   9.3372e-01   8.2331e-02   9.8640e-01   8.2678e-02
-#> 381:    1.0186e+02  -4.1204e+00  -2.3515e+00  -4.0643e+00  -1.0089e+00   3.6269e-03   3.6531e-02   5.0770e-07   9.1364e-02   2.2157e-02   1.8768e-01   9.3897e-02   9.3383e-01   8.2326e-02   9.8630e-01   8.2675e-02
-#> 382:    1.0186e+02  -4.1204e+00  -2.3513e+00  -4.0643e+00  -1.0090e+00   3.1691e-03   3.6469e-02   5.0860e-07   9.1318e-02   2.2188e-02   1.8767e-01   9.3787e-02   9.3433e-01   8.2306e-02   9.8643e-01   8.2670e-02
-#> 383:    1.0186e+02  -4.1204e+00  -2.3508e+00  -4.0642e+00  -1.0090e+00   2.6209e-03   3.6416e-02   5.0893e-07   9.1374e-02   2.2165e-02   1.8759e-01   9.3654e-02   9.3443e-01   8.2289e-02   9.8663e-01   8.2672e-02
-#> 384:    1.0186e+02  -4.1204e+00  -2.3505e+00  -4.0640e+00  -1.0090e+00   2.1556e-03   3.6403e-02   5.0834e-07   9.1550e-02   2.2148e-02   1.8750e-01   9.3422e-02   9.3444e-01   8.2277e-02   9.8639e-01   8.2670e-02
-#> 385:    1.0186e+02  -4.1204e+00  -2.3505e+00  -4.0638e+00  -1.0089e+00   1.7048e-03   3.6391e-02   5.0788e-07   9.1717e-02   2.2160e-02   1.8746e-01   9.3178e-02   9.3457e-01   8.2261e-02   9.8616e-01   8.2636e-02
-#> 386:    1.0186e+02  -4.1204e+00  -2.3504e+00  -4.0637e+00  -1.0089e+00   1.4309e-03   3.6372e-02   5.0847e-07   9.1895e-02   2.2157e-02   1.8754e-01   9.2918e-02   9.3439e-01   8.2246e-02   9.8601e-01   8.2617e-02
-#> 387:    1.0186e+02  -4.1204e+00  -2.3505e+00  -4.0636e+00  -1.0089e+00   1.3524e-03   3.6446e-02   5.0896e-07   9.2022e-02   2.2182e-02   1.8768e-01   9.2684e-02   9.3470e-01   8.2216e-02   9.8593e-01   8.2620e-02
-#> 388:    1.0186e+02  -4.1204e+00  -2.3506e+00  -4.0635e+00  -1.0089e+00   1.2887e-03   3.6478e-02   5.0904e-07   9.2117e-02   2.2174e-02   1.8761e-01   9.2506e-02   9.3463e-01   8.2221e-02   9.8563e-01   8.2609e-02
-#> 389:    1.0186e+02  -4.1204e+00  -2.3505e+00  -4.0635e+00  -1.0089e+00   1.2044e-03   3.6479e-02   5.0969e-07   9.2068e-02   2.2180e-02   1.8751e-01   9.2308e-02   9.3438e-01   8.2241e-02   9.8516e-01   8.2592e-02
-#> 390:    1.0186e+02  -4.1204e+00  -2.3506e+00  -4.0635e+00  -1.0087e+00   1.1442e-03   3.6497e-02   5.0878e-07   9.1995e-02   2.2156e-02   1.8744e-01   9.2169e-02   9.3410e-01   8.2257e-02   9.8511e-01   8.2581e-02
-#> 391:    1.0186e+02  -4.1204e+00  -2.3508e+00  -4.0635e+00  -1.0089e+00   1.0925e-03   3.6454e-02   5.0876e-07   9.1945e-02   2.2177e-02   1.8739e-01   9.1989e-02   9.3439e-01   8.2254e-02   9.8472e-01   8.2579e-02
-#> 392:    1.0186e+02  -4.1204e+00  -2.3506e+00  -4.0633e+00  -1.0091e+00   7.9940e-04   3.6417e-02   5.0874e-07   9.1956e-02   2.2185e-02   1.8730e-01   9.1977e-02   9.3422e-01   8.2244e-02   9.8463e-01   8.2589e-02
-#> 393:    1.0186e+02  -4.1204e+00  -2.3504e+00  -4.0632e+00  -1.0093e+00   4.2112e-04   3.6433e-02   5.0843e-07   9.1868e-02   2.2211e-02   1.8739e-01   9.2106e-02   9.3464e-01   8.2217e-02   9.8458e-01   8.2594e-02
-#> 394:    1.0186e+02  -4.1204e+00  -2.3502e+00  -4.0631e+00  -1.0093e+00   1.4926e-04   3.6534e-02   5.0862e-07   9.1713e-02   2.2244e-02   1.8735e-01   9.2105e-02   9.3454e-01   8.2239e-02   9.8410e-01   8.2601e-02
-#> 395:    1.0186e+02  -4.1204e+00  -2.3499e+00  -4.0630e+00  -1.0095e+00   5.2506e-05   3.6667e-02   5.0955e-07   9.1548e-02   2.2269e-02   1.8733e-01   9.2151e-02   9.3450e-01   8.2256e-02   9.8389e-01   8.2612e-02
-#> 396:    1.0186e+02  -4.1204e+00  -2.3497e+00  -4.0630e+00  -1.0097e+00   1.6581e-05   3.6789e-02   5.1002e-07   9.1431e-02   2.2299e-02   1.8742e-01   9.2120e-02   9.3450e-01   8.2252e-02   9.8367e-01   8.2620e-02
-#> 397:    1.0186e+02  -4.1205e+00  -2.3495e+00  -4.0629e+00  -1.0098e+00  -5.0310e-05   3.6860e-02   5.0949e-07   9.1311e-02   2.2323e-02   1.8738e-01   9.2130e-02   9.3467e-01   8.2250e-02   9.8388e-01   8.2628e-02
-#> 398:    1.0186e+02  -4.1205e+00  -2.3494e+00  -4.0629e+00  -1.0097e+00  -1.4918e-04   3.6902e-02   5.0935e-07   9.1211e-02   2.2330e-02   1.8747e-01   9.2144e-02   9.3478e-01   8.2260e-02   9.8420e-01   8.2632e-02
-#> 399:    1.0186e+02  -4.1205e+00  -2.3497e+00  -4.0628e+00  -1.0097e+00  -2.2152e-04   3.6932e-02   5.0927e-07   9.1209e-02   2.2377e-02   1.8750e-01   9.2136e-02   9.3481e-01   8.2286e-02   9.8431e-01   8.2622e-02
-#> 400:    1.0186e+02  -4.1205e+00  -2.3499e+00  -4.0629e+00  -1.0097e+00   3.2878e-05   3.6943e-02   5.0892e-07   9.1092e-02   2.2388e-02   1.8752e-01   9.2072e-02   9.3534e-01   8.2276e-02   9.8472e-01   8.2615e-02
-#> 401:    1.0186e+02  -4.1205e+00  -2.3501e+00  -4.0630e+00  -1.0097e+00   2.6776e-04   3.6950e-02   5.0860e-07   9.1038e-02   2.2395e-02   1.8740e-01   9.1911e-02   9.3515e-01   8.2331e-02   9.8459e-01   8.2615e-02
-#> 402:    1.0186e+02  -4.1205e+00  -2.3502e+00  -4.0632e+00  -1.0097e+00   3.9988e-04   3.6912e-02   5.0849e-07   9.0944e-02   2.2401e-02   1.8737e-01   9.1701e-02   9.3494e-01   8.2353e-02   9.8479e-01   8.2609e-02
-#> 403:    1.0186e+02  -4.1205e+00  -2.3503e+00  -4.0633e+00  -1.0098e+00   4.9714e-04   3.6935e-02   5.0805e-07   9.0895e-02   2.2404e-02   1.8741e-01   9.1609e-02   9.3444e-01   8.2372e-02   9.8505e-01   8.2638e-02
-#> 404:    1.0186e+02  -4.1205e+00  -2.3504e+00  -4.0633e+00  -1.0100e+00   5.8465e-04   3.6978e-02   5.0889e-07   9.0862e-02   2.2453e-02   1.8746e-01   9.1650e-02   9.3491e-01   8.2364e-02   9.8484e-01   8.2653e-02
-#> 405:    1.0186e+02  -4.1205e+00  -2.3505e+00  -4.0634e+00  -1.0099e+00   5.5970e-04   3.6999e-02   5.0964e-07   9.0930e-02   2.2480e-02   1.8742e-01   9.1823e-02   9.3458e-01   8.2371e-02   9.8465e-01   8.2670e-02
-#> 406:    1.0186e+02  -4.1205e+00  -2.3507e+00  -4.0634e+00  -1.0098e+00   5.4464e-04   3.7123e-02   5.1046e-07   9.1008e-02   2.2478e-02   1.8749e-01   9.1930e-02   9.3449e-01   8.2361e-02   9.8440e-01   8.2666e-02
-#> 407:    1.0186e+02  -4.1205e+00  -2.3506e+00  -4.0634e+00  -1.0097e+00   3.5564e-04   3.7226e-02   5.0978e-07   9.0891e-02   2.2469e-02   1.8751e-01   9.2130e-02   9.3444e-01   8.2380e-02   9.8462e-01   8.2660e-02
-#> 408:    1.0186e+02  -4.1205e+00  -2.3506e+00  -4.0635e+00  -1.0097e+00   3.8362e-04   3.7354e-02   5.0967e-07   9.0892e-02   2.2461e-02   1.8747e-01   9.2230e-02   9.3453e-01   8.2363e-02   9.8466e-01   8.2661e-02
-#> 409:    1.0186e+02  -4.1205e+00  -2.3505e+00  -4.0635e+00  -1.0097e+00   2.6671e-04   3.7473e-02   5.0928e-07   9.0894e-02   2.2519e-02   1.8751e-01   9.2243e-02   9.3447e-01   8.2347e-02   9.8449e-01   8.2667e-02
-#> 410:    1.0186e+02  -4.1205e+00  -2.3506e+00  -4.0634e+00  -1.0098e+00   1.7963e-04   3.7438e-02   5.0981e-07   9.0898e-02   2.2600e-02   1.8764e-01   9.2237e-02   9.3502e-01   8.2320e-02   9.8430e-01   8.2663e-02
-#> 411:    1.0186e+02  -4.1205e+00  -2.3506e+00  -4.0634e+00  -1.0098e+00   1.0085e-04   3.7381e-02   5.0970e-07   9.0820e-02   2.2618e-02   1.8767e-01   9.2103e-02   9.3480e-01   8.2324e-02   9.8427e-01   8.2652e-02
-#> 412:    1.0186e+02  -4.1205e+00  -2.3508e+00  -4.0633e+00  -1.0097e+00   1.9452e-04   3.7315e-02   5.0984e-07   9.0784e-02   2.2605e-02   1.8772e-01   9.2118e-02   9.3504e-01   8.2314e-02   9.8431e-01   8.2636e-02
-#> 413:    1.0186e+02  -4.1205e+00  -2.3508e+00  -4.0632e+00  -1.0097e+00   1.8432e-04   3.7243e-02   5.0946e-07   9.0798e-02   2.2604e-02   1.8765e-01   9.2206e-02   9.3499e-01   8.2299e-02   9.8426e-01   8.2636e-02
-#> 414:    1.0186e+02  -4.1205e+00  -2.3505e+00  -4.0632e+00  -1.0097e+00   2.1744e-04   3.7203e-02   5.0880e-07   9.0769e-02   2.2604e-02   1.8757e-01   9.2403e-02   9.3516e-01   8.2279e-02   9.8414e-01   8.2659e-02
-#> 415:    1.0186e+02  -4.1205e+00  -2.3505e+00  -4.0633e+00  -1.0097e+00   1.9330e-04   3.7197e-02   5.0896e-07   9.0657e-02   2.2618e-02   1.8764e-01   9.2565e-02   9.3514e-01   8.2264e-02   9.8435e-01   8.2655e-02
-#> 416:    1.0186e+02  -4.1205e+00  -2.3501e+00  -4.0634e+00  -1.0097e+00   2.1450e-04   3.7144e-02   5.0882e-07   9.0762e-02   2.2645e-02   1.8761e-01   9.2614e-02   9.3511e-01   8.2277e-02   9.8415e-01   8.2669e-02
-#> 417:    1.0186e+02  -4.1205e+00  -2.3498e+00  -4.0634e+00  -1.0099e+00   1.0737e-04   3.7092e-02   5.0932e-07   9.0804e-02   2.2631e-02   1.8754e-01   9.2581e-02   9.3509e-01   8.2284e-02   9.8430e-01   8.2667e-02
-#> 418:    1.0186e+02  -4.1205e+00  -2.3495e+00  -4.0633e+00  -1.0099e+00   2.4734e-05   3.7061e-02   5.0972e-07   9.0913e-02   2.2624e-02   1.8736e-01   9.2572e-02   9.3482e-01   8.2275e-02   9.8413e-01   8.2682e-02
-#> 419:    1.0186e+02  -4.1205e+00  -2.3495e+00  -4.0633e+00  -1.0099e+00  -3.9197e-05   3.7070e-02   5.1000e-07   9.1084e-02   2.2644e-02   1.8727e-01   9.2636e-02   9.3494e-01   8.2259e-02   9.8382e-01   8.2673e-02
-#> 420:    1.0186e+02  -4.1205e+00  -2.3494e+00  -4.0633e+00  -1.0098e+00  -1.2434e-04   3.7103e-02   5.1037e-07   9.1152e-02   2.2631e-02   1.8733e-01   9.2862e-02   9.3515e-01   8.2244e-02   9.8388e-01   8.2656e-02
-#> 421:    1.0186e+02  -4.1205e+00  -2.3494e+00  -4.0632e+00  -1.0097e+00  -1.5440e-04   3.7123e-02   5.1205e-07   9.1233e-02   2.2626e-02   1.8744e-01   9.2935e-02   9.3523e-01   8.2241e-02   9.8360e-01   8.2652e-02
-#> 422:    1.0186e+02  -4.1205e+00  -2.3495e+00  -4.0633e+00  -1.0095e+00  -8.9184e-05   3.7182e-02   5.1296e-07   9.1123e-02   2.2617e-02   1.8749e-01   9.2915e-02   9.3509e-01   8.2276e-02   9.8367e-01   8.2637e-02
-#> 423:    1.0186e+02  -4.1205e+00  -2.3497e+00  -4.0634e+00  -1.0095e+00   6.7469e-05   3.7194e-02   5.1323e-07   9.1083e-02   2.2642e-02   1.8739e-01   9.3097e-02   9.3529e-01   8.2270e-02   9.8367e-01   8.2642e-02
-#> 424:    1.0186e+02  -4.1205e+00  -2.3498e+00  -4.0635e+00  -1.0094e+00   1.5970e-04   3.7258e-02   5.1292e-07   9.0998e-02   2.2667e-02   1.8730e-01   9.3311e-02   9.3525e-01   8.2262e-02   9.8362e-01   8.2648e-02
-#> 425:    1.0186e+02  -4.1205e+00  -2.3499e+00  -4.0636e+00  -1.0095e+00   2.7004e-04   3.7298e-02   5.1307e-07   9.0839e-02   2.2665e-02   1.8744e-01   9.3429e-02   9.3497e-01   8.2282e-02   9.8395e-01   8.2657e-02
-#> 426:    1.0186e+02  -4.1205e+00  -2.3499e+00  -4.0636e+00  -1.0094e+00   3.9201e-04   3.7303e-02   5.1305e-07   9.0647e-02   2.2675e-02   1.8743e-01   9.3523e-02   9.3477e-01   8.2314e-02   9.8371e-01   8.2655e-02
-#> 427:    1.0186e+02  -4.1205e+00  -2.3496e+00  -4.0636e+00  -1.0093e+00   2.9359e-04   3.7366e-02   5.1245e-07   9.0630e-02   2.2673e-02   1.8738e-01   9.3813e-02   9.3495e-01   8.2291e-02   9.8368e-01   8.2653e-02
-#> 428:    1.0186e+02  -4.1204e+00  -2.3496e+00  -4.0635e+00  -1.0094e+00   2.5099e-04   3.7411e-02   5.1144e-07   9.0647e-02   2.2674e-02   1.8732e-01   9.3993e-02   9.3493e-01   8.2273e-02   9.8373e-01   8.2652e-02
-#> 429:    1.0186e+02  -4.1204e+00  -2.3495e+00  -4.0635e+00  -1.0095e+00   2.4723e-04   3.7543e-02   5.1084e-07   9.0600e-02   2.2677e-02   1.8723e-01   9.4269e-02   9.3518e-01   8.2286e-02   9.8396e-01   8.2659e-02
-#> 430:    1.0186e+02  -4.1204e+00  -2.3494e+00  -4.0635e+00  -1.0096e+00   2.7711e-04   3.7579e-02   5.1022e-07   9.0496e-02   2.2679e-02   1.8708e-01   9.4484e-02   9.3525e-01   8.2309e-02   9.8433e-01   8.2672e-02
-#> 431:    1.0186e+02  -4.1204e+00  -2.3494e+00  -4.0634e+00  -1.0095e+00   1.3934e-05   3.7631e-02   5.0908e-07   9.0378e-02   2.2671e-02   1.8708e-01   9.4770e-02   9.3528e-01   8.2302e-02   9.8470e-01   8.2682e-02
-#> 432:    1.0186e+02  -4.1204e+00  -2.3495e+00  -4.0633e+00  -1.0096e+00  -8.9401e-05   3.7677e-02   5.0861e-07   9.0278e-02   2.2654e-02   1.8702e-01   9.4882e-02   9.3518e-01   8.2318e-02   9.8488e-01   8.2667e-02
-#> 433:    1.0186e+02  -4.1205e+00  -2.3495e+00  -4.0633e+00  -1.0096e+00  -3.6841e-04   3.7706e-02   5.0854e-07   9.0108e-02   2.2652e-02   1.8703e-01   9.5039e-02   9.3487e-01   8.2331e-02   9.8494e-01   8.2669e-02
-#> 434:    1.0186e+02  -4.1205e+00  -2.3493e+00  -4.0632e+00  -1.0096e+00  -4.3399e-04   3.7671e-02   5.0796e-07   9.0036e-02   2.2661e-02   1.8701e-01   9.5122e-02   9.3474e-01   8.2331e-02   9.8474e-01   8.2675e-02
-#> 435:    1.0186e+02  -4.1205e+00  -2.3491e+00  -4.0632e+00  -1.0096e+00  -6.1398e-04   3.7654e-02   5.0727e-07   8.9940e-02   2.2664e-02   1.8691e-01   9.5242e-02   9.3451e-01   8.2346e-02   9.8466e-01   8.2677e-02
-#> 436:    1.0186e+02  -4.1205e+00  -2.3487e+00  -4.0632e+00  -1.0094e+00  -7.2148e-04   3.7647e-02   5.0649e-07   8.9838e-02   2.2661e-02   1.8694e-01   9.5465e-02   9.3429e-01   8.2365e-02   9.8475e-01   8.2683e-02
-#> 437:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0632e+00  -1.0093e+00  -1.1480e-03   3.7613e-02   5.0662e-07   8.9719e-02   2.2674e-02   1.8698e-01   9.5631e-02   9.3419e-01   8.2380e-02   9.8490e-01   8.2684e-02
-#> 438:    1.0186e+02  -4.1204e+00  -2.3482e+00  -4.0631e+00  -1.0092e+00  -1.5547e-03   3.7583e-02   5.0753e-07   8.9612e-02   2.2680e-02   1.8703e-01   9.5913e-02   9.3413e-01   8.2394e-02   9.8523e-01   8.2678e-02
-#> 439:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0630e+00  -1.0093e+00  -1.9392e-03   3.7463e-02   5.0769e-07   8.9410e-02   2.2706e-02   1.8706e-01   9.6149e-02   9.3392e-01   8.2425e-02   9.8512e-01   8.2670e-02
-#> 440:    1.0186e+02  -4.1205e+00  -2.3482e+00  -4.0629e+00  -1.0094e+00  -2.1940e-03   3.7360e-02   5.0743e-07   8.9245e-02   2.2742e-02   1.8710e-01   9.6213e-02   9.3400e-01   8.2445e-02   9.8490e-01   8.2676e-02
-#> 441:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0629e+00  -1.0095e+00  -2.3414e-03   3.7297e-02   5.0838e-07   8.9137e-02   2.2806e-02   1.8721e-01   9.6155e-02   9.3405e-01   8.2450e-02   9.8470e-01   8.2684e-02
-#> 442:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0628e+00  -1.0095e+00  -2.6378e-03   3.7241e-02   5.0923e-07   8.9066e-02   2.2846e-02   1.8727e-01   9.6135e-02   9.3389e-01   8.2465e-02   9.8454e-01   8.2686e-02
-#> 443:    1.0186e+02  -4.1205e+00  -2.3482e+00  -4.0627e+00  -1.0094e+00  -2.8716e-03   3.7214e-02   5.1026e-07   8.9128e-02   2.2901e-02   1.8740e-01   9.6077e-02   9.3386e-01   8.2444e-02   9.8421e-01   8.2692e-02
-#> 444:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0627e+00  -1.0092e+00  -2.9147e-03   3.7196e-02   5.1104e-07   8.9190e-02   2.2985e-02   1.8744e-01   9.5999e-02   9.3390e-01   8.2424e-02   9.8381e-01   8.2696e-02
-#> 445:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0626e+00  -1.0090e+00  -2.9638e-03   3.7251e-02   5.1283e-07   8.9335e-02   2.3004e-02   1.8756e-01   9.5788e-02   9.3382e-01   8.2416e-02   9.8347e-01   8.2683e-02
-#> 446:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0627e+00  -1.0090e+00  -2.8796e-03   3.7331e-02   5.1479e-07   8.9470e-02   2.3017e-02   1.8762e-01   9.5656e-02   9.3368e-01   8.2405e-02   9.8325e-01   8.2680e-02
-#> 447:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0628e+00  -1.0091e+00  -2.7695e-03   3.7473e-02   5.1656e-07   8.9568e-02   2.3030e-02   1.8757e-01   9.5575e-02   9.3379e-01   8.2386e-02   9.8306e-01   8.2690e-02
-#> 448:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0629e+00  -1.0091e+00  -2.6293e-03   3.7498e-02   5.1814e-07   8.9776e-02   2.3052e-02   1.8762e-01   9.5422e-02   9.3373e-01   8.2372e-02   9.8274e-01   8.2685e-02
-#> 449:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0628e+00  -1.0092e+00  -2.5640e-03   3.7542e-02   5.1867e-07   8.9888e-02   2.3056e-02   1.8763e-01   9.5364e-02   9.3400e-01   8.2365e-02   9.8239e-01   8.2691e-02
-#> 450:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0628e+00  -1.0093e+00  -2.5816e-03   3.7622e-02   5.1849e-07   9.0050e-02   2.3061e-02   1.8765e-01   9.5274e-02   9.3435e-01   8.2341e-02   9.8235e-01   8.2699e-02
-#> 451:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0627e+00  -1.0094e+00  -2.4837e-03   3.7631e-02   5.1931e-07   9.0177e-02   2.3053e-02   1.8766e-01   9.5103e-02   9.3459e-01   8.2322e-02   9.8226e-01   8.2715e-02
-#> 452:    1.0186e+02  -4.1205e+00  -2.3482e+00  -4.0627e+00  -1.0094e+00  -2.4156e-03   3.7606e-02   5.1901e-07   9.0333e-02   2.3047e-02   1.8763e-01   9.4959e-02   9.3485e-01   8.2289e-02   9.8210e-01   8.2713e-02
-#> 453:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0627e+00  -1.0093e+00  -2.4619e-03   3.7552e-02   5.1874e-07   9.0495e-02   2.3066e-02   1.8761e-01   9.4960e-02   9.3485e-01   8.2293e-02   9.8178e-01   8.2703e-02
-#> 454:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0627e+00  -1.0092e+00  -2.4816e-03   3.7514e-02   5.1835e-07   9.0606e-02   2.3073e-02   1.8754e-01   9.4896e-02   9.3491e-01   8.2277e-02   9.8154e-01   8.2696e-02
-#> 455:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0627e+00  -1.0092e+00  -2.3708e-03   3.7457e-02   5.1742e-07   9.0715e-02   2.3099e-02   1.8756e-01   9.4804e-02   9.3481e-01   8.2272e-02   9.8122e-01   8.2688e-02
-#> 456:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0627e+00  -1.0093e+00  -2.2313e-03   3.7409e-02   5.1680e-07   9.0906e-02   2.3131e-02   1.8743e-01   9.4814e-02   9.3476e-01   8.2261e-02   9.8108e-01   8.2694e-02
-#> 457:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0628e+00  -1.0095e+00  -2.1182e-03   3.7342e-02   5.1630e-07   9.0986e-02   2.3158e-02   1.8733e-01   9.4843e-02   9.3488e-01   8.2244e-02   9.8094e-01   8.2700e-02
-#> 458:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0628e+00  -1.0095e+00  -1.9242e-03   3.7244e-02   5.1605e-07   9.1085e-02   2.3168e-02   1.8720e-01   9.4820e-02   9.3509e-01   8.2228e-02   9.8093e-01   8.2703e-02
-#> 459:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0629e+00  -1.0095e+00  -1.7643e-03   3.7203e-02   5.1566e-07   9.1179e-02   2.3175e-02   1.8715e-01   9.4809e-02   9.3516e-01   8.2216e-02   9.8087e-01   8.2690e-02
-#> 460:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0629e+00  -1.0094e+00  -1.5479e-03   3.7151e-02   5.1547e-07   9.1211e-02   2.3155e-02   1.8712e-01   9.4703e-02   9.3539e-01   8.2201e-02   9.8100e-01   8.2683e-02
-#> 461:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0630e+00  -1.0095e+00  -1.4993e-03   3.7111e-02   5.1446e-07   9.1225e-02   2.3159e-02   1.8705e-01   9.4569e-02   9.3555e-01   8.2183e-02   9.8078e-01   8.2680e-02
-#> 462:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0629e+00  -1.0094e+00  -1.4890e-03   3.7056e-02   5.1361e-07   9.1446e-02   2.3158e-02   1.8694e-01   9.4494e-02   9.3557e-01   8.2171e-02   9.8058e-01   8.2688e-02
-#> 463:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0629e+00  -1.0094e+00  -1.3999e-03   3.6996e-02   5.1319e-07   9.1659e-02   2.3176e-02   1.8695e-01   9.4436e-02   9.3570e-01   8.2153e-02   9.8053e-01   8.2686e-02
-#> 464:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0630e+00  -1.0095e+00  -1.1544e-03   3.6949e-02   5.1300e-07   9.1885e-02   2.3162e-02   1.8688e-01   9.4378e-02   9.3599e-01   8.2134e-02   9.8051e-01   8.2694e-02
-#> 465:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0630e+00  -1.0097e+00  -9.7372e-04   3.6943e-02   5.1235e-07   9.2014e-02   2.3136e-02   1.8692e-01   9.4288e-02   9.3605e-01   8.2141e-02   9.8053e-01   8.2693e-02
-#> 466:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0630e+00  -1.0097e+00  -9.2442e-04   3.6916e-02   5.1246e-07   9.2074e-02   2.3132e-02   1.8688e-01   9.4254e-02   9.3590e-01   8.2131e-02   9.8016e-01   8.2691e-02
-#> 467:    1.0186e+02  -4.1205e+00  -2.3485e+00  -4.0631e+00  -1.0098e+00  -8.2540e-04   3.6928e-02   5.1340e-07   9.2164e-02   2.3141e-02   1.8690e-01   9.4382e-02   9.3620e-01   8.2106e-02   9.7996e-01   8.2705e-02
-#> 468:    1.0186e+02  -4.1205e+00  -2.3484e+00  -4.0631e+00  -1.0097e+00  -7.3368e-04   3.6925e-02   5.1395e-07   9.2218e-02   2.3136e-02   1.8695e-01   9.4504e-02   9.3629e-01   8.2094e-02   9.7985e-01   8.2716e-02
-#> 469:    1.0186e+02  -4.1205e+00  -2.3483e+00  -4.0630e+00  -1.0096e+00  -7.4343e-04   3.6891e-02   5.1401e-07   9.2204e-02   2.3114e-02   1.8700e-01   9.4639e-02   9.3643e-01   8.2078e-02   9.7996e-01   8.2709e-02
-#> 470:    1.0186e+02  -4.1205e+00  -2.3482e+00  -4.0630e+00  -1.0096e+00  -7.8250e-04   3.6874e-02   5.1370e-07   9.2209e-02   2.3083e-02   1.8702e-01   9.4728e-02   9.3646e-01   8.2073e-02   9.7989e-01   8.2703e-02
-#> 471:    1.0186e+02  -4.1205e+00  -2.3480e+00  -4.0629e+00  -1.0095e+00  -1.0440e-03   3.6843e-02   5.1358e-07   9.2194e-02   2.3062e-02   1.8710e-01   9.4741e-02   9.3649e-01   8.2082e-02   9.8003e-01   8.2701e-02
-#> 472:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0629e+00  -1.0096e+00  -9.5438e-04   3.6869e-02   5.1330e-07   9.2176e-02   2.3050e-02   1.8712e-01   9.4766e-02   9.3666e-01   8.2080e-02   9.7996e-01   8.2691e-02
-#> 473:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0630e+00  -1.0096e+00  -8.2178e-04   3.6877e-02   5.1283e-07   9.2191e-02   2.3021e-02   1.8703e-01   9.4747e-02   9.3670e-01   8.2072e-02   9.8007e-01   8.2693e-02
-#> 474:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0630e+00  -1.0096e+00  -7.0189e-04   3.6927e-02   5.1196e-07   9.2195e-02   2.2989e-02   1.8702e-01   9.4746e-02   9.3669e-01   8.2054e-02   9.8029e-01   8.2689e-02
-#> 475:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0630e+00  -1.0095e+00  -7.1989e-04   3.6993e-02   5.1125e-07   9.2159e-02   2.2963e-02   1.8700e-01   9.4813e-02   9.3681e-01   8.2051e-02   9.8027e-01   8.2680e-02
-#> 476:    1.0186e+02  -4.1205e+00  -2.3481e+00  -4.0629e+00  -1.0096e+00  -7.1806e-04   3.7018e-02   5.1105e-07   9.2091e-02   2.2933e-02   1.8696e-01   9.4837e-02   9.3713e-01   8.2067e-02   9.8033e-01   8.2674e-02
-#> 477:    1.0186e+02  -4.1205e+00  -2.3479e+00  -4.0630e+00  -1.0097e+00  -7.3438e-04   3.6986e-02   5.1121e-07   9.2046e-02   2.2909e-02   1.8698e-01   9.4809e-02   9.3743e-01   8.2059e-02   9.8045e-01   8.2693e-02
-#> 478:    1.0186e+02  -4.1205e+00  -2.3478e+00  -4.0630e+00  -1.0096e+00  -7.9338e-04   3.6912e-02   5.1224e-07   9.2056e-02   2.2881e-02   1.8698e-01   9.4791e-02   9.3757e-01   8.2042e-02   9.8072e-01   8.2682e-02
-#> 479:    1.0186e+02  -4.1205e+00  -2.3476e+00  -4.0629e+00  -1.0096e+00  -8.6158e-04   3.6882e-02   5.1284e-07   9.2159e-02   2.2867e-02   1.8694e-01   9.4774e-02   9.3749e-01   8.2051e-02   9.8088e-01   8.2679e-02
-#> 480:    1.0186e+02  -4.1205e+00  -2.3474e+00  -4.0629e+00  -1.0096e+00  -1.1334e-03   3.6851e-02   5.1423e-07   9.2253e-02   2.2869e-02   1.8696e-01   9.4820e-02   9.3751e-01   8.2063e-02   9.8097e-01   8.2693e-02
-#> 481:    1.0186e+02  -4.1205e+00  -2.3470e+00  -4.0629e+00  -1.0096e+00  -1.2444e-03   3.6785e-02   5.1490e-07   9.2397e-02   2.2853e-02   1.8694e-01   9.4838e-02   9.3770e-01   8.2031e-02   9.8124e-01   8.2707e-02
-#> 482:    1.0186e+02  -4.1205e+00  -2.3467e+00  -4.0629e+00  -1.0095e+00  -1.3612e-03   3.6750e-02   5.1658e-07   9.2440e-02   2.2842e-02   1.8683e-01   9.4800e-02   9.3786e-01   8.2041e-02   9.8107e-01   8.2719e-02
-#> 483:    1.0186e+02  -4.1205e+00  -2.3467e+00  -4.0628e+00  -1.0096e+00  -1.5168e-03   3.6783e-02   5.1708e-07   9.2590e-02   2.2804e-02   1.8674e-01   9.4804e-02   9.3790e-01   8.2042e-02   9.8116e-01   8.2719e-02
-#> 484:    1.0186e+02  -4.1205e+00  -2.3466e+00  -4.0628e+00  -1.0097e+00  -1.5218e-03   3.6848e-02   5.1669e-07   9.2717e-02   2.2775e-02   1.8670e-01   9.4940e-02   9.3798e-01   8.2028e-02   9.8106e-01   8.2719e-02
-#> 485:    1.0186e+02  -4.1205e+00  -2.3464e+00  -4.0628e+00  -1.0097e+00  -1.4177e-03   3.6867e-02   5.1615e-07   9.2806e-02   2.2765e-02   1.8669e-01   9.5018e-02   9.3816e-01   8.2020e-02   9.8090e-01   8.2721e-02
-#> 486:    1.0186e+02  -4.1205e+00  -2.3462e+00  -4.0628e+00  -1.0098e+00  -1.5257e-03   3.6968e-02   5.1513e-07   9.3019e-02   2.2762e-02   1.8663e-01   9.5111e-02   9.3816e-01   8.2013e-02   9.8071e-01   8.2732e-02
-#> 487:    1.0186e+02  -4.1205e+00  -2.3460e+00  -4.0628e+00  -1.0097e+00  -1.7055e-03   3.7021e-02   5.1446e-07   9.3161e-02   2.2732e-02   1.8652e-01   9.5373e-02   9.3832e-01   8.1997e-02   9.8078e-01   8.2737e-02
-#> 488:    1.0186e+02  -4.1205e+00  -2.3459e+00  -4.0628e+00  -1.0097e+00  -1.8502e-03   3.7069e-02   5.1391e-07   9.3282e-02   2.2741e-02   1.8641e-01   9.5414e-02   9.3818e-01   8.2001e-02   9.8064e-01   8.2738e-02
-#> 489:    1.0186e+02  -4.1205e+00  -2.3458e+00  -4.0628e+00  -1.0097e+00  -1.9091e-03   3.7017e-02   5.1291e-07   9.3286e-02   2.2738e-02   1.8639e-01   9.5453e-02   9.3808e-01   8.1991e-02   9.8047e-01   8.2728e-02
-#> 490:    1.0186e+02  -4.1205e+00  -2.3456e+00  -4.0628e+00  -1.0097e+00  -1.8766e-03   3.6969e-02   5.1220e-07   9.3297e-02   2.2728e-02   1.8635e-01   9.5468e-02   9.3793e-01   8.1988e-02   9.8034e-01   8.2726e-02
-#> 491:    1.0186e+02  -4.1205e+00  -2.3457e+00  -4.0627e+00  -1.0097e+00  -1.7736e-03   3.6915e-02   5.1153e-07   9.3298e-02   2.2716e-02   1.8634e-01   9.5548e-02   9.3772e-01   8.2005e-02   9.8025e-01   8.2722e-02
-#> 492:    1.0186e+02  -4.1205e+00  -2.3457e+00  -4.0627e+00  -1.0097e+00  -1.7747e-03   3.6877e-02   5.1077e-07   9.3336e-02   2.2697e-02   1.8635e-01   9.5593e-02   9.3778e-01   8.2001e-02   9.8013e-01   8.2725e-02
-#> 493:    1.0186e+02  -4.1205e+00  -2.3456e+00  -4.0628e+00  -1.0094e+00  -1.6324e-03   3.6857e-02   5.1020e-07   9.3348e-02   2.2668e-02   1.8636e-01   9.5735e-02   9.3764e-01   8.1984e-02   9.8019e-01   8.2723e-02
-#> 494:    1.0186e+02  -4.1205e+00  -2.3456e+00  -4.0629e+00  -1.0094e+00  -1.5393e-03   3.6842e-02   5.1022e-07   9.3359e-02   2.2649e-02   1.8637e-01   9.5812e-02   9.3739e-01   8.1982e-02   9.8033e-01   8.2708e-02
-#> 495:    1.0186e+02  -4.1205e+00  -2.3456e+00  -4.0629e+00  -1.0094e+00  -1.5166e-03   3.6841e-02   5.1004e-07   9.3321e-02   2.2642e-02   1.8640e-01   9.5849e-02   9.3716e-01   8.1979e-02   9.8016e-01   8.2700e-02
-#> 496:    1.0186e+02  -4.1205e+00  -2.3456e+00  -4.0630e+00  -1.0095e+00  -1.4947e-03   3.6841e-02   5.0969e-07   9.3236e-02   2.2646e-02   1.8640e-01   9.5916e-02   9.3719e-01   8.1963e-02   9.8028e-01   8.2702e-02
-#> 497:    1.0186e+02  -4.1205e+00  -2.3457e+00  -4.0629e+00  -1.0094e+00  -1.4507e-03   3.6827e-02   5.0937e-07   9.3185e-02   2.2663e-02   1.8638e-01   9.5991e-02   9.3707e-01   8.1954e-02   9.8047e-01   8.2718e-02
-#> 498:    1.0186e+02  -4.1205e+00  -2.3459e+00  -4.0630e+00  -1.0094e+00  -1.2569e-03   3.6805e-02   5.0854e-07   9.3089e-02   2.2677e-02   1.8634e-01   9.5931e-02   9.3719e-01   8.1952e-02   9.8051e-01   8.2718e-02
-#> 499:    1.0186e+02  -4.1205e+00  -2.3460e+00  -4.0630e+00  -1.0093e+00  -1.0466e-03   3.6769e-02   5.0789e-07   9.3029e-02   2.2690e-02   1.8631e-01   9.5862e-02   9.3729e-01   8.1956e-02   9.8046e-01   8.2731e-02
-#> 500:    1.0186e+02  -4.1205e+00  -2.3464e+00  -4.0630e+00  -1.0093e+00  -7.3346e-04   3.6766e-02   5.0769e-07   9.3093e-02   2.2701e-02   1.8633e-01   9.5687e-02   9.3739e-01   8.1977e-02   9.8039e-01   8.2728e-02
#> Calculating covariance matrix
#> 
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → compiling EBE model...
#>  
#> ✔ done
#> Needed Covariates:
#> [1] "CMT"
#> Calculating residuals/tables
#> done
# The following takes a very long time but gives
+
#> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>  
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc,     ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG,     addProp = .addProp, tol = .tol, itmax = .itmax, type = .type,     powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_m1
#> Timing stopped at: 1.281 0.142 1.422
# The following takes a very long time but gives
 f_nlmixr_dfop_sfo_focei <- nlmixr(f_mmkin_dfop_sfo, est = "focei")
-
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Needed Covariates:
#> [1] "CMT"
-#> Key: U: Unscaled Parameters; X: Back-transformed parameters; G: Gill difference gradient approximation
-#> F: Forward difference gradient approximation
-#> C: Central difference gradient approximation
-#> M: Mixed forward and central difference gradient approximation
-#> Unscaled parameters for Omegas=chol(solve(omega));
-#> Diagonals are transformed, as specified by foceiControl(diagXform=)
-#> |-----+---------------+-----------+-----------+-----------+-----------|
-#> |    #| Objective Fun |  parent_0 |  log_k_m1 |f_parent_qlogis |    log_k1 |
-#> |.....................|    log_k2 |  g_qlogis | sigma_low |  rsd_high |
-#> |.....................|        o1 |        o2 |        o3 |        o4 |
-#> |.....................|        o5 |        o6 |...........|...........|
-#> |    1|     496.98032 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     496.98032 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     496.98032 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    G|    Gill Diff. |     57.10 |   -0.1453 |   -0.1275 |    0.2854 |
-#> |.....................|   -0.6156 |  0.007043 |    -23.49 |    -32.87 |
-#> |.....................|     3.669 |    -17.46 |    -13.05 |    -13.08 |
-#> |.....................|    -16.16 |    -9.766 |...........|...........|
-#> |    2|     3094.8373 |    0.2572 |   -0.9978 |   -0.9392 |   -0.9714 |
-#> |.....................|   -0.9920 |   -0.9233 |   -0.6037 |   -0.4942 |
-#> |.....................|   -0.9579 |   -0.6658 |   -0.7293 |   -0.7310 |
-#> |.....................|   -0.6848 |   -0.7742 |...........|...........|
-#> |    U|     3094.8373 |     26.15 |    -4.052 |   -0.9415 |    -2.363 |
-#> |.....................|    -4.062 |  -0.01133 |    0.8386 |   0.08074 |
-#> |.....................|    0.6445 |     1.946 |     1.477 |     1.348 |
-#> |.....................|     1.794 |     1.297 |...........|...........|
-#> |    X|     3094.8373 |     26.15 |   0.01739 |    0.2806 |   0.09412 |
-#> |.....................|   0.01721 |    0.4972 |    0.8386 |   0.08074 |
-#> |.....................|    0.6445 |     1.946 |     1.477 |     1.348 |
-#> |.....................|     1.794 |     1.297 |...........|...........|
-#> |    3|     557.60681 |    0.9257 |   -0.9995 |   -0.9407 |   -0.9680 |
-#> |.....................|   -0.9992 |   -0.9232 |   -0.8787 |   -0.8790 |
-#> |.....................|   -0.9150 |   -0.8703 |   -0.8821 |   -0.8842 |
-#> |.....................|   -0.8739 |   -0.8885 |...........|...........|
-#> |    U|     557.60681 |     94.11 |    -4.053 |   -0.9430 |    -2.360 |
-#> |.....................|    -4.069 |  -0.01133 |    0.7386 |   0.06794 |
-#> |.....................|    0.6735 |     1.622 |     1.284 |     1.172 |
-#> |.....................|     1.513 |     1.165 |...........|...........|
-#> |    X|     557.60681 |     94.11 |   0.01736 |    0.2803 |   0.09444 |
-#> |.....................|   0.01709 |    0.4972 |    0.7386 |   0.06794 |
-#> |.....................|    0.6735 |     1.622 |     1.284 |     1.172 |
-#> |.....................|     1.513 |     1.165 |...........|...........|
-#> |    4|     543.47785 |    0.9926 |   -0.9997 |   -0.9408 |   -0.9677 |
-#> |.....................|   -0.9999 |   -0.9232 |   -0.9062 |   -0.9175 |
-#> |.....................|   -0.9107 |   -0.8907 |   -0.8974 |   -0.8995 |
-#> |.....................|   -0.8929 |   -0.9000 |...........|...........|
-#> |    U|     543.47785 |     100.9 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7286 |   0.06666 |
-#> |.....................|    0.6764 |     1.589 |     1.264 |     1.154 |
-#> |.....................|     1.485 |     1.152 |...........|...........|
-#> |    X|     543.47785 |     100.9 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7286 |   0.06666 |
-#> |.....................|    0.6764 |     1.589 |     1.264 |     1.154 |
-#> |.....................|     1.485 |     1.152 |...........|...........|
-#> |    5|     544.09017 |    0.9993 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9089 |   -0.9213 |
-#> |.....................|   -0.9103 |   -0.8928 |   -0.8990 |   -0.9010 |
-#> |.....................|   -0.8948 |   -0.9011 |...........|...........|
-#> |    U|     544.09017 |     101.6 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7276 |   0.06654 |
-#> |.....................|    0.6767 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.09017 |     101.6 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7276 |   0.06654 |
-#> |.....................|    0.6767 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    6|     544.17109 |    0.9999 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8949 |   -0.9012 |...........|...........|
-#> |    U|     544.17109 |     101.6 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.17109 |     101.6 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    7|     544.17937 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.17937 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.17937 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    8|     544.18025 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18025 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18025 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    9|     544.18033 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18033 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18033 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   10|     544.18034 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18034 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18034 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   11|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   12|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   13|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   14|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   15|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   16|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |   17|     544.18036 |     1.000 |   -0.9997 |   -0.9408 |   -0.9676 |
-#> |.....................|    -1.000 |   -0.9232 |   -0.9092 |   -0.9217 |
-#> |.....................|   -0.9102 |   -0.8930 |   -0.8991 |   -0.9012 |
-#> |.....................|   -0.8950 |   -0.9012 |...........|...........|
-#> |    U|     544.18036 |     101.7 |    -4.054 |   -0.9431 |    -2.359 |
-#> |.....................|    -4.070 |  -0.01132 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> |    X|     544.18036 |     101.7 |   0.01736 |    0.2803 |   0.09447 |
-#> |.....................|   0.01708 |    0.4972 |    0.7275 |   0.06652 |
-#> |.....................|    0.6768 |     1.586 |     1.262 |     1.152 |
-#> |.....................|     1.482 |     1.151 |...........|...........|
-#> calculating covariance matrix
-#> done
#> Calculating residuals/tables
#> done
#> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
#> Warning: last objective function was not at minimum, possible problems in optimization
#> Warning: using R matrix to calculate covariance, can check sandwich or S matrix with $covRS and $covS
#> Warning: gradient problems with initial estimate and covariance; see $scaleInfo
AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm)
-
#> Calculating -2LL by Gaussian quadrature (nnodes=3,nsd=1.6)
#> 
#>                            df      AIC
-#> f_nlmixr_dfop_sfo_saem$nm  16      Inf
-#> f_nlmixr_dfop_sfo_focei$nm 14 886.4573
summary(f_nlmixr_dfop_sfo_sfo, data = TRUE)
+
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> 
#> → calculate sensitivities
#> 
#> → calculate ∂(f)/∂(η)
#> 
#> → calculate ∂(R²)/∂(η)
#> 
#> → finding duplicate expressions in inner model...
#> 
#> → optimizing duplicate expressions in inner model...
#> 
#> → finding duplicate expressions in EBE model...
#> 
#> → optimizing duplicate expressions in EBE model...
#> 
#> → compiling inner model...
#>  
#> ✔ done
#> → finding duplicate expressions in FD model...
#> 
#> → optimizing duplicate expressions in FD model...
#> 
#> → compiling EBE model...
#>  
#> ✔ done
#> → compiling events FD model...
#>  
#> ✔ done
#> Model:
#> cmt(parent);
+#> cmt(m1);
+#> rx_expr_6~ETA[1]+THETA[1];
+#> parent(0)=rx_expr_6;
+#> rx_expr_7~ETA[4]+THETA[4];
+#> rx_expr_8~ETA[6]+THETA[6];
+#> rx_expr_9~ETA[5]+THETA[5];
+#> rx_expr_12~exp(rx_expr_7);
+#> rx_expr_13~exp(rx_expr_9);
+#> rx_expr_15~t*rx_expr_12;
+#> rx_expr_16~t*rx_expr_13;
+#> rx_expr_19~exp(-(rx_expr_8));
+#> rx_expr_21~1+rx_expr_19;
+#> rx_expr_26~1/(rx_expr_21);
+#> rx_expr_28~(rx_expr_26);
+#> rx_expr_29~1-rx_expr_28;
+#> d/dt(parent)=-parent*(exp(rx_expr_7-rx_expr_15)/(rx_expr_21)+exp(rx_expr_9-rx_expr_16)*(rx_expr_29))/(exp(-t*rx_expr_12)/(rx_expr_21)+exp(-t*rx_expr_13)*(rx_expr_29));
+#> rx_expr_10~ETA[2]+THETA[2];
+#> rx_expr_14~exp(rx_expr_10);
+#> d/dt(m1)=-rx_expr_14*m1+parent*f_parent_to_m1*(exp(rx_expr_7-rx_expr_15)/(rx_expr_21)+exp(rx_expr_9-rx_expr_16)*(rx_expr_29))/(exp(-t*rx_expr_12)/(rx_expr_21)+exp(-t*rx_expr_13)*(rx_expr_29));
+#> rx_expr_0~CMT==2;
+#> rx_expr_1~CMT==1;
+#> rx_expr_2~1-(rx_expr_0);
+#> rx_yj_~2*(rx_expr_2)*(rx_expr_1)+2*(rx_expr_0);
+#> rx_expr_3~(rx_expr_0);
+#> rx_expr_5~(rx_expr_2);
+#> rx_expr_20~rx_expr_5*(rx_expr_1);
+#> rx_lambda_~rx_expr_20+rx_expr_3;
+#> rx_hi_~rx_expr_20+rx_expr_3;
+#> rx_low_~0;
+#> rx_expr_4~m1*(rx_expr_0);
+#> rx_expr_11~parent*(rx_expr_2);
+#> rx_expr_24~rx_expr_11*(rx_expr_1);
+#> rx_pred_=(rx_expr_4+rx_expr_24)*(rx_expr_0)+(rx_expr_4+rx_expr_24)*(rx_expr_2)*(rx_expr_1);
+#> rx_expr_17~Rx_pow_di(THETA[8],2);
+#> rx_expr_18~Rx_pow_di(THETA[7],2);
+#> rx_r_=(Rx_pow_di(((rx_expr_4+rx_expr_24)*(rx_expr_0)+(rx_expr_4+rx_expr_24)*(rx_expr_2)*(rx_expr_1)),2)*rx_expr_17+rx_expr_18)*(rx_expr_0)+(Rx_pow_di(((rx_expr_4+rx_expr_24)*(rx_expr_1)),2)*rx_expr_17+rx_expr_18)*(rx_expr_2)*(rx_expr_1);
+#> parent_0=THETA[1];
+#> log_k_m1=THETA[2];
+#> f_parent_qlogis=THETA[3];
+#> log_k1=THETA[4];
+#> log_k2=THETA[5];
+#> g_qlogis=THETA[6];
+#> sigma_low=THETA[7];
+#> rsd_high=THETA[8];
+#> eta.parent_0=ETA[1];
+#> eta.log_k_m1=ETA[2];
+#> eta.f_parent_qlogis=ETA[3];
+#> eta.log_k1=ETA[4];
+#> eta.log_k2=ETA[5];
+#> eta.g_qlogis=ETA[6];
+#> parent_0_model=rx_expr_6;
+#> k_m1=rx_expr_14;
+#> k1=rx_expr_12;
+#> k2=rx_expr_13;
+#> f_parent=1/(1+exp(-(ETA[3]+THETA[3])));
+#> g=1/(rx_expr_21);
+#> tad=tad();
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_m1" "CMT"           
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL,     lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL,     control = foceiControl(), thetaNames = NULL, etaNames = NULL,     etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) {    set.seed(control$seed)    .pt <- proc.time()    RxODE::.setWarnIdSort(FALSE)    on.exit(RxODE::.setWarnIdSort(TRUE))    loadNamespace("n1qn1")    if (!RxODE::rxIs(control, "foceiControl")) {        control <- do.call(foceiControl, control)    }    if (is.null(env)) {        .ret <- new.env(parent = emptyenv())    }    else {        .ret <- env    }    .ret$origData <- data    .ret$etaNames <- etaNames    .ret$thetaFixed <- fixed    .ret$control <- control    .ret$control$focei.mu.ref <- integer(0)    if (is(model, "RxODE") || is(model, "character")) {        .ret$ODEmodel <- TRUE        if (class(pred) != "function") {            stop("pred must be a function specifying the prediction variables in this model.")        }    }    else {        .ret$ODEmodel <- TRUE        model <- RxODE::rxGetLin(PKpars)        pred <- eval(parse(text = "function(){return(Central);}"))    }    .square <- function(x) x * x    .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform]    if (is.null(err)) {        err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]],             collapse = ""), "}")))    }    .covNames <- .parNames <- c()    .ret$adjLik <- control$adjLik    .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0    if (!exists("noLik", envir = .ret)) {        .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))        .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))        .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state))        .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state))        .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars,             err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE,             sum.prod = control$sumProd, theta.derivs = FALSE,             optExpression = control$optExpression, interaction = (control$interaction ==                 1L), only.numeric = !.mixed, run.internal = TRUE,             addProp = control$addProp)        if (!is.null(.ret$model$inner)) {            .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.atol)))            .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.rtol)))            .ret$control$rxControl$atol <- .atol            .ret$control$rxControl$rtol <- .rtol            .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssAtol)))            .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                 length(.ssRtol)))            .ret$control$rxControl$ssAtol <- .ssAtol            .ret$control$rxControl$ssRtol <- .ssRtol        }        .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)        .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",             "ETA"), "[", numbers, "]", end), .covNames) == -1]        colnames(data) <- sapply(names(data), function(x) {            if (any(x == .covNames)) {                return(x)            }            else {                return(toupper(x))            }        })        .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),             RxODE::rxLhs(.ret$model$pred.only))        if (length(.lhs) > 0) {            .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs),                 end), .covNames) == -1]        }        if (length(.covNames) > 0) {            if (!all(.covNames %in% names(data))) {                message("Model:")                RxODE::rxCat(.ret$model$pred.only)                message("Needed Covariates:")                nlmixrPrint(.covNames)                stop("Not all the covariates are in the dataset.")            }            message("Needed Covariates:")            print(.covNames)        }        .extraPars <- .ret$model$extra.pars    }    else {        if (.ret$noLik) {            .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state))            .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state))            .ret$model <- RxODE::rxSymPySetupPred(model, pred,                 PKpars, err, grad = FALSE, pred.minus.dv = TRUE,                 sum.prod = control$sumProd, theta.derivs = FALSE,                 optExpression = control$optExpression, run.internal = TRUE,                 only.numeric = TRUE, addProp = control$addProp)            if (!is.null(.ret$model$inner)) {                .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.atol)))                .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) -                   length(.rtol)))                .ret$control$rxControl$atol <- .atol                .ret$control$rxControl$rtol <- .rtol            }            .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only)            .covNames <- .covNames[regexpr(rex::rex(start, or("THETA",                 "ETA"), "[", numbers, "]", end), .covNames) ==                 -1]            colnames(data) <- sapply(names(data), function(x) {                if (any(x == .covNames)) {                  return(x)                }                else {                  return(toupper(x))                }            })            .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)),                 RxODE::rxLhs(.ret$model$pred.only))            if (length(.lhs) > 0) {                .covNames <- .covNames[regexpr(rex::rex(start,                   or(.lhs), end), .covNames) == -1]            }            if (length(.covNames) > 0) {                if (!all(.covNames %in% names(data))) {                  message("Model:")                  RxODE::rxCat(.ret$model$pred.only)                  message("Needed Covariates:")                  nlmixrPrint(.covNames)                  stop("Not all the covariates are in the dataset.")                }                message("Needed Covariates:")                print(.covNames)            }            .extraPars <- .ret$model$extra.pars        }        else {            .extraPars <- NULL        }    }    .ret$skipCov <- skipCov    if (is.null(skipCov)) {        if (is.null(fixed)) {            .tmp <- rep(FALSE, length(inits$THTA))        }        else {            if (length(fixed) < length(inits$THTA)) {                .tmp <- c(fixed, rep(FALSE, length(inits$THTA) -                   length(fixed)))            }            else {                .tmp <- fixed[1:length(inits$THTA)]            }        }        if (exists("uif", envir = .ret)) {            .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)]            .uifErr <- sapply(.uifErr, function(x) {                if (is.na(x)) {                  return(FALSE)                }                return(!any(x == c("pow2", "tbs", "tbsYj")))            })            .tmp <- (.tmp | .uifErr)        }        .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars)))        .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref    }    if (is.null(.extraPars)) {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)))    }    else {        .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)),             sprintf("ERR[%s]", seq_along(.extraPars)))    }    if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) ==         length(thetaNames)) {        .nms <- thetaNames    }    .ret$thetaNames <- .nms    .thetaReset$thetaNames <- .nms    if (length(lower) == 1) {        lower <- rep(lower, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        print(inits$THTA)        print(lower)        stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (length(upper) == 1) {        upper <- rep(upper, length(inits$THTA))    }    else if (length(lower) != length(inits$THTA)) {        stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.")    }    if (!is.null(.extraPars)) {        .ret$model$extra.pars <- eval(call(control$diagXform,             .ret$model$extra.pars))        if (length(.ret$model$extra.pars) > 0) {            inits$THTA <- c(inits$THTA, .ret$model$extra.pars)            .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars))            .upperErr <- rep(Inf, length(.ret$model$extra.pars))            lower <- c(lower, .lowerErr)            upper <- c(upper, .upperErr)        }    }    if (is.null(data$ID))         stop("\"ID\" not found in data")    if (is.null(data$DV))         stop("\"DV\" not found in data")    if (is.null(data$EVID))         data$EVID <- 0    if (is.null(data$AMT))         data$AMT <- 0    for (.v in c("TIME", "AMT", "DV", .covNames)) {        data[[.v]] <- as.double(data[[.v]])    }    .ret$dataSav <- data    .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME",         "AMT", "EVID", .covNames)]    .w <- which(tolower(names(data)) == "limit")    .limitName <- NULL    if (length(.w) == 1L) {        .limitName <- names(data)[.w]    }    .censName <- NULL    .w <- which(tolower(names(data)) == "cens")    if (length(.w) == 1L) {        .censName <- names(data[.w])    }    data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME",         "DV", "EVID", .covNames, .limitName, .censName)]    .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep)))    names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w]))    if (.mixed) {        .lh <- .parseOM(inits$OMGA)        .nlh <- sapply(.lh, length)        .osplt <- rep(1:length(.lh), .nlh)        .lini <- list(inits$THTA, unlist(.lh))        .nlini <- sapply(.lini, length)        .nsplt <- rep(1:length(.lini), .nlini)        .om0 <- .genOM(.lh)        if (length(etaNames) == dim(.om0)[1]) {            .ret$etaNames <- .ret$etaNames        }        else {            .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1]))        }        .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform)        .ret$xType <- .ret$rxInv$xType        .om0a <- .om0        .om0a <- .om0a/control$diagOmegaBoundLower        .om0b <- .om0        .om0b <- .om0b * control$diagOmegaBoundUpper        .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform)        .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform)        .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta,             b = .om0b$theta, diag = .om0a$theta.diag)        .omdf$lower <- with(.omdf, ifelse(a > b, b, a))        .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower))        .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower))        .omdf$upper <- with(.omdf, ifelse(a < b, b, a))        .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper))        .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper))        .ret$control$nomega <- length(.omdf$lower)        .ret$control$neta <- sum(.omdf$diag)        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)        lower <- c(lower, .omdf$lower)        upper <- c(upper, .omdf$upper)    }    else {        .ret$control$nomega <- 0        .ret$control$neta <- 0        .ret$xType <- -1        .ret$control$ntheta <- length(lower)        .ret$control$nfixed <- sum(fixed)    }    .ret$lower <- lower    .ret$upper <- upper    .ret$thetaIni <- inits$THTA    .scaleC <- double(length(lower))    if (is.null(control$scaleC)) {        .scaleC <- rep(NA_real_, length(lower))    }    else {        .scaleC <- as.double(control$scaleC)        if (length(lower) > length(.scaleC)) {            .scaleC <- c(.scaleC, rep(NA_real_, length(lower) -                 length(.scaleC)))        }        else if (length(lower) < length(.scaleC)) {            .scaleC <- .scaleC[seq(1, length(lower))]            warning("scaleC control option has more options than estimated population parameters, please check.")        }    }    .ret$scaleC <- .scaleC    if (exists("uif", envir = .ret)) {        .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err),             c("est", "err", "ntheta")]        for (.i in seq_along(.ini$err)) {            if (is.na(.ret$scaleC[.ini$ntheta[.i]])) {                if (any(.ini$err[.i] == c("boxCox", "yeoJohnson",                   "pow2", "tbs", "tbsYj"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 1                }                else if (any(.ini$err[.i] == c("prop", "add",                   "norm", "dnorm", "logn", "dlogn", "lnorm",                   "dlnorm"))) {                  .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i])                }            }        }        for (.i in .ini$model$extraProps$powTheta) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- 1        }        .ini <- as.data.frame(.ret$uif$ini)        for (.i in .ini$model$extraProps$factorial) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] +                   1))        }        for (.i in .ini$model$extraProps$gamma) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i]))        }        for (.i in .ini$model$extraProps$log) {            if (is.na(.ret$scaleC[.i]))                 .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i])        }        for (.i in .ret$logitThetas) {            .b <- .ret$logitThetasLow[.i]            .c <- .ret$logitThetasHi[.i]            .a <- .ini$est[.i]            if (is.na(.ret$scaleC[.i])) {                .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 +                   exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a))))            }        }    }    names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni))    if (is.null(etaMat) & !is.null(control$etaMat)) {        .ret$etaMat <- control$etaMat    }    else {        .ret$etaMat <- etaMat    }    .ret$setupTime <- (proc.time() - .pt)["elapsed"]    if (exists("uif", envir = .ret)) {        .tmp <- .ret$uif$logThetasList        .ret$logThetas <- .tmp[[1]]        .ret$logThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasList        .ret$logitThetas <- .tmp[[1]]        .ret$logitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListLow        .ret$logitThetasLow <- .tmp[[1]]        .ret$logitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$logitThetasListHi        .ret$logitThetasHi <- .tmp[[1]]        .ret$logitThetasHiF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasList        .ret$probitThetas <- .tmp[[1]]        .ret$probitThetasF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListLow        .ret$probitThetasLow <- .tmp[[1]]        .ret$probitThetasLowF <- .tmp[[2]]        .tmp <- .ret$uif$probitThetasListHi        .ret$probitThetasHi <- .tmp[[1]]        .ret$probitThetasHiF <- .tmp[[2]]    }    else {        .ret$logThetasF <- integer(0)        .ret$logitThetasF <- integer(0)        .ret$logitThetasHiF <- numeric(0)        .ret$logitThetasLowF <- numeric(0)        .ret$logitThetas <- integer(0)        .ret$logitThetasHi <- numeric(0)        .ret$logitThetasLow <- numeric(0)        .ret$probitThetasF <- integer(0)        .ret$probitThetasHiF <- numeric(0)        .ret$probitThetasLowF <- numeric(0)        .ret$probitThetas <- integer(0)        .ret$probitThetasHi <- numeric(0)        .ret$probitThetasLow <- numeric(0)    }    if (exists("noLik", envir = .ret)) {        if (!.ret$noLik) {            .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)),                 sprintf("ETA[%d]", seq(1, dim(.om0)[1])))            .ret$.thetan <- length(.ret$thetaIni)            .ret$nobs <- sum(data$EVID == 0)        }    }    .ret$control$printTop <- TRUE    .ret$control$nF <- 0    .est0 <- .ret$thetaIni    if (!is.null(.ret$model$pred.nolhs)) {        .ret$control$predNeq <- length(.ret$model$pred.nolhs$state)    }    else {        .ret$control$predNeq <- 0L    }    .fitFun <- function(.ret) {        this.env <- environment()        assign("err", "theta reset", this.env)        while (this.env$err == "theta reset") {            assign("err", "", this.env)            .ret0 <- tryCatch({                foceiFitCpp_(.ret)            }, error = function(e) {                if (regexpr("theta reset", e$message) != -1) {                  assign("zeroOuter", FALSE, this.env)                  assign("zeroGrad", FALSE, this.env)                  if (regexpr("theta reset0", e$message) != -1) {                    assign("zeroGrad", TRUE, this.env)                  }                  else if (regexpr("theta resetZ", e$message) !=                     -1) {                    assign("zeroOuter", TRUE, this.env)                  }                  assign("err", "theta reset", this.env)                }                else {                  assign("err", e$message, this.env)                }            })            if (this.env$err == "theta reset") {                .nm <- names(.ret$thetaIni)                .ret$thetaIni <- setNames(.thetaReset$thetaIni +                   0, .nm)                .ret$rxInv$theta <- .thetaReset$omegaTheta                .ret$control$printTop <- FALSE                .ret$etaMat <- .thetaReset$etaMat                .ret$control$etaMat <- .thetaReset$etaMat                .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations                .ret$control$nF <- .thetaReset$nF                .ret$control$gillRetC <- .thetaReset$gillRetC                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillRet <- .thetaReset$gillRet                .ret$control$gillDf <- .thetaReset$gillDf                .ret$control$gillDf2 <- .thetaReset$gillDf2                .ret$control$gillErr <- .thetaReset$gillErr                .ret$control$rEps <- .thetaReset$rEps                .ret$control$aEps <- .thetaReset$aEps                .ret$control$rEpsC <- .thetaReset$rEpsC                .ret$control$aEpsC <- .thetaReset$aEpsC                .ret$control$c1 <- .thetaReset$c1                .ret$control$c2 <- .thetaReset$c2                if (this.env$zeroOuter) {                  message("Posthoc reset")                  .ret$control$maxOuterIterations <- 0L                }                else if (this.env$zeroGrad) {                  message("Theta reset (zero gradient values); Switch to bobyqa")                  RxODE::rxReq("minqa")                  .ret$control$outerOptFun <- .bobyqa                  .ret$control$outerOpt <- -1L                }                else {                  message("Theta reset (ETA drift)")                }            }        }        if (this.env$err != "") {            stop(this.env$err)        }        else {            return(.ret0)        }    }    .ret0 <- try(.fitFun(.ret))    .n <- 1    while (inherits(.ret0, "try-error") && control$maxOuterIterations !=         0 && .n <= control$nRetries) {        message(sprintf("Restart %s", .n))        .ret$control$nF <- 0        .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) -             0.1 * .n        .estNew <- sapply(seq_along(.est0), function(.i) {            if (.ret$thetaFixed[.i]) {                return(.est0[.i])            }            else if (.estNew[.i] < lower[.i]) {                return(lower + (.Machine$double.eps)^(1/7))            }            else if (.estNew[.i] > upper[.i]) {                return(upper - (.Machine$double.eps)^(1/7))            }            else {                return(.estNew[.i])            }        })        .ret$thetaIni <- .estNew        .ret0 <- try(.fitFun(.ret))        .n <- .n + 1    }    if (inherits(.ret0, "try-error"))         stop("Could not fit data.")    .ret <- .ret0    if (exists("parHistData", .ret)) {        .tmp <- .ret$parHistData        .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) !=             "type"]        .iter <- .tmp$iter        .tmp <- .tmp[, names(.tmp) != "iter"]        .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter)        names(.ret$parHistStacked) <- c("val", "par", "iter")        .ret$parHist <- data.frame(iter = .iter, .tmp)    }    if (.mixed) {        .etas <- .ret$ranef        .thetas <- .ret$fixef        .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas)        .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega,             .pars$eta.lst, length(.etas$ID))        .updateParFixed(.ret)    }    else {        .updateParFixed(.ret)    }    if (!exists("table", .ret)) {        .ret$table <- tableControl()    }    if (control$calcTables) {        .ret <- addTable(.ret, updateObject = "no", keep = keep,             drop = drop, table = .ret$table)    }    .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod,     pred = function() {        return(nlmixr_pred)    }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper,     fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names,     control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 19.01 0.403 19.42
AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm)
+
#> Error in AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm): object 'f_nlmixr_dfop_sfo_saem' not found
summary(f_nlmixr_dfop_sfo_sfo, data = TRUE)
 
#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'f_nlmixr_dfop_sfo_sfo' not found
# }
diff --git a/docs/dev/reference/tffm0.html b/docs/dev/reference/tffm0.html index d993e8ff..67f26b85 100644 --- a/docs/dev/reference/tffm0.html +++ b/docs/dev/reference/tffm0.html @@ -81,7 +81,7 @@ from RxODE." /> mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/sitemap.xml b/docs/dev/sitemap.xml index 150840e1..b5e83f34 100644 --- a/docs/dev/sitemap.xml +++ b/docs/dev/sitemap.xml @@ -246,4 +246,7 @@ https://pkgdown.jrwb.de/mkin/articles/web_only/compiled_models.html + + https://pkgdown.jrwb.de/mkin/articles/web_only/dimethenamid_2018.html + diff --git a/vignettes/web_only/dimethenamid_2018.html b/vignettes/web_only/dimethenamid_2018.html index e84a435c..df8200eb 100644 --- a/vignettes/web_only/dimethenamid_2018.html +++ b/vignettes/web_only/dimethenamid_2018.html @@ -1594,7 +1594,7 @@ div.tocify {

Example evaluations of the dimethenamid data from 2018

Johannes Ranke

-

Last change 23 June 2021, built on 25 Jun 2021

+

Last change 27 July 2021, built on 27 Jul 2021

@@ -1655,18 +1655,20 @@ f_parent_mkin_tc <- mmkin(c("SFO", "DFOP"), dmta_ds,

nlme

The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We use would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.

-
f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ])
-#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ]) # error
+
library(nlme)
+f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ])
+#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ])
+# maxIter = 50 reached
 f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ])
 f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ])

 
Note that overparameterisation is also indicated by warnings obtained when fitting SFO or DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in some iterations). In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.

 
f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ],
   random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1)))
 anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better
-f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc,
-  random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))
+#f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc,
+#  random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))
 # using log Cholesky parameterisation for random effects (nlme default) does
-# not converge and gives lots of warnings about the LME step not converging

+# not converge here and gives lots of warnings about the LME step not converging

The model comparison function of the nlme package can directly be applied to these fits showing a similar goodness-of-fit of the SFO model, but a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.

anova(
   f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
@@ -1685,24 +1687,24 @@ f_parent_nlme_dfop_tc       3 10 687.84 718.59 -333.92 2 vs 3 140.771  <.0001
 
The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit.

 
The convergence plot for the SFO model using constant variance is shown below.

 
library(saemix)
-f_parent_saemix_sfo_const <- saem(f_parent_mkin_const["SFO", ], quiet = TRUE,
+f_parent_saemix_sfo_const <- mkin::saem(f_parent_mkin_const["SFO", ], quiet = TRUE,
   transformations = "saemix")
 plot(f_parent_saemix_sfo_const$so, plot.type = "convergence")

 

 
Obviously the default number of iterations is sufficient to reach convergence. This can also be said for the SFO fit using the two-component error model.

-
f_parent_saemix_sfo_tc <- saem(f_parent_mkin_tc["SFO", ], quiet = TRUE,
+
f_parent_saemix_sfo_tc <- mkin::saem(f_parent_mkin_tc["SFO", ], quiet = TRUE,
   transformations = "saemix")
 plot(f_parent_saemix_sfo_tc$so, plot.type = "convergence")

 

-
When fitting the DFOP model with constant variance, parameter convergence is not as unambiguous. Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence.

-
f_parent_saemix_dfop_const <- saem(f_parent_mkin_const["DFOP", ], quiet = TRUE,
+
When fitting the DFOP model with constant variance, parameter convergence is not as unambiguous (see the failure of nlme with the default number of iterations above). Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence.

+
f_parent_saemix_dfop_const <- mkin::saem(f_parent_mkin_const["DFOP", ], quiet = TRUE,
   control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
     save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
   transformations = "saemix")
 plot(f_parent_saemix_dfop_const$so, plot.type = "convergence")

 

-
The same applies to the case where the DFOP model is fitted with the two-component error model.

-
f_parent_saemix_dfop_tc_moreiter <- saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE,
+
The same applies to the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced by using the two-component error, it remains more or less stable already after 200 iterations of the first phase.

+
f_parent_saemix_dfop_tc_moreiter <- mkin::saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE,
   control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
     save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
   transformations = "saemix")
@@ -1710,20 +1712,31 @@ plot(f_parent_saemix_dfop_tc_moreiter$so, plot.type = "convergence")

 
The four combinations can be compared using the model comparison function from the saemix package:

 
compare.saemix(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
-  f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc$so)

+  f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so)

 
Likelihoods calculated by importance sampling

 
     AIC    BIC
 1 818.37 817.33
 2 820.38 819.14
 3 725.91 724.04
-4 688.09 686.01

+4 683.64 681.55

 
As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. The numeric values are reasonably close to the ones obtained using nlme, considering that the algorithms for fitting the model and for the likelihood calculation are quite different.

+
In order to check the influence of the likelihood calculation algorithms implemented in saemix, the likelihood from Gaussian quadrature is added to the best fit, and the AIC values obtained from the three methods are compared.

+
f_parent_saemix_dfop_tc_moreiter$so <-
+  llgq.saemix(f_parent_saemix_dfop_tc_moreiter$so)
+AIC(f_parent_saemix_dfop_tc_moreiter$so)

+
[1] 683.64

+
AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "gq")

+
[1] 683.7

+
AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "lin")

+
[1] 683.17

+
The AIC values based on importance sampling and Gaussian quadrature are quite similar. Using linearisation is less accurate, but still gives a similar value.

nlmixr

In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.

First, the focei algorithm is used for the four model combinations and the goodness of fit of the results is compared.

-
f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei")
+
library(nlmixr)
+f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei")
 f_parent_nlmixr_focei_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "focei")
 f_parent_nlmixr_focei_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "focei")
 f_parent_nlmixr_focei_dfop_tc<- nlmixr(f_parent_mkin_tc["DFOP", ], est = "focei")

@@ -1734,7 +1747,14 @@ f_parent_nlmixr_focei_sfo_const$nm   5 818.63
 f_parent_nlmixr_focei_sfo_tc$nm      6 820.61
 f_parent_nlmixr_focei_dfop_const$nm  9 728.11
 f_parent_nlmixr_focei_dfop_tc$nm    10 687.82
-

The AIC values are very close to the ones obtained with nlme.

+

The AIC values are very close to the ones obtained with nlme which are repeated below for convenience.

+
AIC(
+  f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
+)
+
                        df    AIC
+f_parent_nlme_sfo_const  5 818.63
+f_parent_nlme_sfo_tc     6 820.61
+f_parent_nlme_dfop_tc   10 687.84

Secondly, we use the SAEM estimation routine and check the convergence plots for SFO with constant variance

f_parent_nlmixr_saem_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "saem",
   control = nlmixr::saemControl(logLik = TRUE))
@@ -1743,17 +1763,17 @@ traceplot(f_parent_nlmixr_saem_sfo_const$nm)

for SFO with two-component error

f_parent_nlmixr_saem_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "saem",
   control = nlmixr::saemControl(logLik = TRUE))
-nlmixr::traceplot(f_parent_nlmixr_saem_sfo_tc$nm)
+traceplot(f_parent_nlmixr_saem_sfo_tc$nm)

For DFOP with constant variance, the convergence plots show considerable instability of the fit, which can be alleviated by increasing the number of iterations and the number of parallel chains for the first phase of algorithm.

f_parent_nlmixr_saem_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "saem",
   control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000), nmc = 15)
-nlmixr::traceplot(f_parent_nlmixr_saem_dfop_const$nm)
+traceplot(f_parent_nlmixr_saem_dfop_const$nm)

For DFOP with two-component error, the same increase in iterations and parallel chains was used, but using the two-component error appears to lead to a less erratic convergence, so this may not be necessary to this degree.

f_parent_nlmixr_saem_dfop_tc <- nlmixr(f_parent_mkin_tc["DFOP", ], est = "saem",
   control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000, nmc = 15))
-nlmixr::traceplot(f_parent_nlmixr_saem_dfop_tc$nm)
+traceplot(f_parent_nlmixr_saem_dfop_tc$nm)

The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using the two-component error model is given as Infinity.

AIC(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
@@ -1761,8 +1781,55 @@ nlmixr::traceplot(f_parent_nlmixr_saem_dfop_tc$nm)
                                   df    AIC
 f_parent_nlmixr_saem_sfo_const$nm   5 820.54
 f_parent_nlmixr_saem_sfo_tc$nm      6 835.26
-f_parent_nlmixr_saem_dfop_const$nm  9 850.72
-f_parent_nlmixr_saem_dfop_tc$nm    10    Inf
+f_parent_nlmixr_saem_dfop_const$nm 9 842.84 +f_parent_nlmixr_saem_dfop_tc$nm 10 684.51 +

The following table gives the AIC values obtained with the three packages.

+
AIC_all <- data.frame(
+  nlme = c(AIC(f_parent_nlme_sfo_const), AIC(f_parent_nlme_sfo_tc), NA, AIC(f_parent_nlme_dfop_tc)),
+  nlmixr_focei = sapply(list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
+  f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm), AIC),
+  saemix = sapply(list(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
+    f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so), AIC),
+  nlmixr_saem = sapply(list(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
+  f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm), AIC)
+)
+kable(AIC_all)
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
nlmenlmixr_foceisaemixnlmixr_saem
818.63818.63818.37820.54
820.61820.61820.38835.26
NA728.11725.91842.84
687.84687.82683.64684.51
diff --git a/vignettes/web_only/dimethenamid_2018.rmd b/vignettes/web_only/dimethenamid_2018.rmd index d3541a34..30325044 100644 --- a/vignettes/web_only/dimethenamid_2018.rmd +++ b/vignettes/web_only/dimethenamid_2018.rmd @@ -1,7 +1,7 @@ --- title: Example evaluations of the dimethenamid data from 2018 author: Johannes Ranke -date: Last change 23 June 2021, built on `r format(Sys.Date(), format = "%d %b %Y")` +date: Last change 27 July 2021, built on `r format(Sys.Date(), format = "%d %b %Y")` output: html_document: toc: true @@ -163,8 +163,10 @@ tendency of the algorithm to try parameter combinations unsuitable for fitting these data. ```{r f_parent_nlme, warning = FALSE} +library(nlme) f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ]) -#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ]) # error +#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ]) +# maxIter = 50 reached f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ]) f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ]) ``` @@ -180,10 +182,10 @@ used for these attempts can be made visible below. f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ], random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1))) anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better -f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc, - random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1))) +#f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc, +# random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1))) # using log Cholesky parameterisation for random effects (nlme default) does -# not converge and gives lots of warnings about the LME step not converging +# not converge here and gives lots of warnings about the LME step not converging ``` The model comparison function of the nlme package can directly be applied @@ -221,7 +223,7 @@ The convergence plot for the SFO model using constant variance is shown below. ```{r f_parent_saemix_sfo_const, results = 'hide'} library(saemix) -f_parent_saemix_sfo_const <- saem(f_parent_mkin_const["SFO", ], quiet = TRUE, +f_parent_saemix_sfo_const <- mkin::saem(f_parent_mkin_const["SFO", ], quiet = TRUE, transformations = "saemix") plot(f_parent_saemix_sfo_const$so, plot.type = "convergence") ``` @@ -230,18 +232,19 @@ Obviously the default number of iterations is sufficient to reach convergence. This can also be said for the SFO fit using the two-component error model. ```{r f_parent_saemix_sfo_tc, results = 'hide'} -f_parent_saemix_sfo_tc <- saem(f_parent_mkin_tc["SFO", ], quiet = TRUE, +f_parent_saemix_sfo_tc <- mkin::saem(f_parent_mkin_tc["SFO", ], quiet = TRUE, transformations = "saemix") plot(f_parent_saemix_sfo_tc$so, plot.type = "convergence") ``` When fitting the DFOP model with constant variance, parameter convergence -is not as unambiguous. Therefore, the number of iterations in the first +is not as unambiguous (see the failure of nlme with the default number of +iterations above). Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence. ```{r f_parent_saemix_dfop_const, results = 'hide'} -f_parent_saemix_dfop_const <- saem(f_parent_mkin_const["DFOP", ], quiet = TRUE, +f_parent_saemix_dfop_const <- mkin::saem(f_parent_mkin_const["DFOP", ], quiet = TRUE, control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE, save = FALSE, save.graphs = FALSE, displayProgress = FALSE), transformations = "saemix") @@ -250,11 +253,11 @@ plot(f_parent_saemix_dfop_const$so, plot.type = "convergence") The same applies to the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced -by using the two-component error, it remains pretty stable already after 200 +by using the two-component error, it remains more or less stable already after 200 iterations of the first phase. ```{r f_parent_saemix_dfop_tc_moreiter, results = 'hide'} -f_parent_saemix_dfop_tc_moreiter <- saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE, +f_parent_saemix_dfop_tc_moreiter <- mkin::saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE, control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE, save = FALSE, save.graphs = FALSE, displayProgress = FALSE), transformations = "saemix") @@ -306,6 +309,7 @@ First, the focei algorithm is used for the four model combinations and the goodness of fit of the results is compared. ```{r f_parent_nlmixr_focei, results = "hide", message = FALSE, warning = FALSE} +library(nlmixr) f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei") f_parent_nlmixr_focei_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "focei") f_parent_nlmixr_focei_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "focei") @@ -317,7 +321,14 @@ AIC(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm, f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm) ``` -The AIC values are very close to the ones obtained with nlme. +The AIC values are very close to the ones obtained with nlme which are repeated below +for convenience. + +```{r AIC_parent_nlme_rep} +AIC( + f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc +) +``` Secondly, we use the SAEM estimation routine and check the convergence plots for SFO with constant variance @@ -333,7 +344,7 @@ for SFO with two-component error ```{r f_parent_nlmixr_saem_sfo_tc, results = "hide", warning = FALSE, message = FALSE} f_parent_nlmixr_saem_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "saem", control = nlmixr::saemControl(logLik = TRUE)) -nlmixr::traceplot(f_parent_nlmixr_saem_sfo_tc$nm) +traceplot(f_parent_nlmixr_saem_sfo_tc$nm) ``` For DFOP with constant variance, the convergence plots show considerable instability @@ -343,7 +354,7 @@ the number of parallel chains for the first phase of algorithm. ```{r f_parent_nlmixr_saem_dfop_const, results = "hide", warning = FALSE, message = FALSE} f_parent_nlmixr_saem_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "saem", control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000), nmc = 15) -nlmixr::traceplot(f_parent_nlmixr_saem_dfop_const$nm) +traceplot(f_parent_nlmixr_saem_dfop_const$nm) ``` For DFOP with two-component error, the same increase in iterations and parallel @@ -354,7 +365,7 @@ erratic convergence, so this may not be necessary to this degree. ```{r f_parent_nlmixr_saem_dfop_tc, results = "hide", warning = FALSE, message = FALSE} f_parent_nlmixr_saem_dfop_tc <- nlmixr(f_parent_mkin_tc["DFOP", ], est = "saem", control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000, nmc = 15)) -nlmixr::traceplot(f_parent_nlmixr_saem_dfop_tc$nm) +traceplot(f_parent_nlmixr_saem_dfop_tc$nm) ``` The AIC values are internally calculated using Gaussian quadrature. For an @@ -366,8 +377,20 @@ AIC(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm, f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm) ``` - - +The following table gives the AIC values obtained with the three packages. + +```{r AIC_all} +AIC_all <- data.frame( + nlme = c(AIC(f_parent_nlme_sfo_const), AIC(f_parent_nlme_sfo_tc), NA, AIC(f_parent_nlme_dfop_tc)), + nlmixr_focei = sapply(list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm, + f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm), AIC), + saemix = sapply(list(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so, + f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so), AIC), + nlmixr_saem = sapply(list(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm, + f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm), AIC) +) +kable(AIC_all) +``` # References -- cgit v1.2.3 From 51fab94230e926cec690dc455964bd797a97b7c7 Mon Sep 17 00:00:00 2001 From: Johannes Ranke Date: Wed, 4 Aug 2021 16:37:52 +0200 Subject: Improve AIC table in vignette --- docs/dev/articles/web_only/dimethenamid_2018.html | 14 ++++++++- docs/dev/pkgdown.yml | 2 +- docs/dev/reference/Rplot001.png | Bin 70653 -> 1011 bytes docs/dev/reference/dimethenamid_2018.html | 26 ++++++++--------- docs/dev/reference/mkinmod.html | 4 +-- docs/dev/reference/nlmixr.mmkin.html | 26 ++++++++--------- docs/dev/reference/plot.mixed.mmkin.html | 4 +-- docs/dev/reference/saem.html | 34 +++++++++++----------- docs/dev/reference/summary.nlmixr.mmkin.html | 8 ++--- docs/dev/reference/summary.saem.mmkin.html | 10 +++---- vignettes/web_only/dimethenamid_2018.rmd | 4 ++- 11 files changed, 73 insertions(+), 59 deletions(-) (limited to 'vignettes/web_only') diff --git a/docs/dev/articles/web_only/dimethenamid_2018.html b/docs/dev/articles/web_only/dimethenamid_2018.html index 34d882a4..9a6d8388 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018.html +++ b/docs/dev/articles/web_only/dimethenamid_2018.html @@ -101,7 +101,7 @@

Example evaluations of the dimethenamid data from 2018

Johannes Ranke

-

Last change 27 July 2021, built on 29 Jul 2021

+

Last change 4 August 2021, built on 04 Aug 2021

Source: vignettes/web_only/dimethenamid_2018.rmd @@ -331,6 +331,8 @@ f_parent_nlmixr_saem_dfop_tc$nm 10 684.51

The following table gives the AIC values obtained with the three packages.

 AIC_all <- data.frame(
+  "Degradation model" = c("SFO", "SFO", "DFOP", "DFOP"),
+  "Error model" = c("const", "tc", "const", "tc"),
   nlme = c(AIC(f_parent_nlme_sfo_const), AIC(f_parent_nlme_sfo_tc), NA, AIC(f_parent_nlme_dfop_tc)),
   nlmixr_focei = sapply(list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
   f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm), AIC),
@@ -342,6 +344,8 @@ f_parent_nlmixr_saem_dfop_tc$nm    10 684.51
kable(AIC_all)
+ + @@ -349,24 +353,32 @@ f_parent_nlmixr_saem_dfop_tc$nm 10 684.51 + + + + + + + + diff --git a/docs/dev/pkgdown.yml b/docs/dev/pkgdown.yml index b987dcf7..f184b7a5 100644 --- a/docs/dev/pkgdown.yml +++ b/docs/dev/pkgdown.yml @@ -11,7 +11,7 @@ articles: web_only/benchmarks: benchmarks.html web_only/compiled_models: compiled_models.html web_only/dimethenamid_2018: dimethenamid_2018.html -last_built: 2021-07-29T10:35Z +last_built: 2021-08-04T13:49Z urls: reference: https://pkgdown.jrwb.de/mkin/reference article: https://pkgdown.jrwb.de/mkin/articles diff --git a/docs/dev/reference/Rplot001.png b/docs/dev/reference/Rplot001.png index 48f53a2a..17a35806 100644 Binary files a/docs/dev/reference/Rplot001.png and b/docs/dev/reference/Rplot001.png differ diff --git a/docs/dev/reference/dimethenamid_2018.html b/docs/dev/reference/dimethenamid_2018.html index c893da63..a77cf0f4 100644 --- a/docs/dev/reference/dimethenamid_2018.html +++ b/docs/dev/reference/dimethenamid_2018.html @@ -295,7 +295,7 @@ specific pieces of information in the comments.

#> M31 ~ add(sigma_low_M31) + prop(rsd_high_M31) #> }) #> } -#> <environment: 0x555559bfc940>
# The focei fit takes about four minutes on my system +#> <environment: 0x555559ac3820>
# The focei fit takes about four minutes on my system system.time( f_dmta_nlmixr_focei <- nlmixr(f_dmta_mkin_tc, est = "focei", control = nlmixr::foceiControl(print = 500)) @@ -303,7 +303,7 @@ specific pieces of information in the comments.

#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#> [====|====|====|====|====|====|====|====|====|====] 0:00:02 #>
#> → calculate sensitivities
#> [====|====|====|====|====|====|====|====|====|====] 0:00:04 #>
#> → calculate ∂(f)/∂(η)
#> [====|====|====|====|====|====|====|====|====|====] 0:00:01 -#>
#> → calculate ∂(R²)/∂(η)
#> [====|====|====|====|====|====|====|====|====|====] 0:00:09 +#>
#> → calculate ∂(R²)/∂(η)
#> [====|====|====|====|====|====|====|====|====|====] 0:00:08 #>
#> → finding duplicate expressions in inner model...
#> [====|====|====|====|====|====|====|====|====|====] 0:00:07 #>
#> → optimizing duplicate expressions in inner model...
#> [====|====|====|====|====|====|====|====|====|====] 0:00:07 #>
#> → finding duplicate expressions in EBE model...
#> [====|====|====|====|====|====|====|====|====|====] 0:00:00 @@ -324,12 +324,12 @@ specific pieces of information in the comments.

#> |.....................| o9 | o10 |...........|...........| #> calculating covariance matrix #> done
#> Calculating residuals/tables
#> done
#> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
#> Warning: last objective function was not at minimum, possible problems in optimization
#> Warning: S matrix non-positive definite
#> Warning: using R matrix to calculate covariance
#> Warning: gradient problems with initial estimate and covariance; see $scaleInfo
#> user system elapsed -#> 227.223 8.444 235.624
summary(f_dmta_nlmixr_focei) +#> 232.621 14.126 246.850
summary(f_dmta_nlmixr_focei)
#> nlmixr version used for fitting: 2.0.4 #> mkin version used for pre-fitting: 1.0.5 #> R version used for fitting: 4.1.0 -#> Date of fit: Thu Jul 29 11:45:46 2021 -#> Date of summary: Thu Jul 29 11:45:46 2021 +#> Date of fit: Wed Aug 4 15:53:54 2021 +#> Date of summary: Wed Aug 4 15:53:54 2021 #> #> Equations: #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -350,7 +350,7 @@ specific pieces of information in the comments.

#> #> Degradation model predictions using RxODE #> -#> Fitted in 235.457 s +#> Fitted in 246.669 s #> #> Variance model: Two-component variance function #> @@ -489,11 +489,11 @@ specific pieces of information in the comments.

f_dmta_saemix <- saem(f_dmta_mkin_tc, test_log_parms = TRUE) )
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 11:45:47 2021" +#> [1] "Wed Aug 4 15:53:55 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:04:25 2021"
#> user system elapsed -#> 1185.594 0.028 1185.687
+#> [1] "Wed Aug 4 16:12:40 2021"
#> user system elapsed +#> 1192.021 0.064 1192.182
# nlmixr with est = "saem" is pretty fast with default iteration numbers, most # of the time (about 2.5 minutes) is spent for calculating the log likelihood at the end # The likelihood calculated for the nlmixr fit is much lower than that found by saemix @@ -506,13 +506,13 @@ specific pieces of information in the comments.

)
#> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> 1: 98.3427 -3.5148 -3.3187 -3.7728 -2.1163 -2.8457 0.9482 -2.8064 -2.7412 -2.8745 2.7912 0.6805 0.8213 0.8055 0.8578 1.4980 2.9309 0.2850 0.2854 0.2850 4.0990 0.3821 3.5349 0.6537 5.4143 0.0002 4.5093 0.1905 #> 500: 97.8277 -4.3506 -4.0318 -4.1520 -3.0553 -3.5843 1.1326 -2.0873 -2.0421 -2.0751 0.2960 1.2515 0.2531 0.3807 0.7928 0.8863 6.5211 0.1433 0.1082 0.3353 0.8960 0.0470 0.7501 0.0475 0.9527 0.0281 0.7321 0.0594
#> Calculating covariance matrix
#>
#> Calculating -2LL by Gaussian quadrature (nnodes=3,nsd=1.6)
#>
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → compiling EBE model...
#>
#> ✔ done
#> Needed Covariates:
#> [1] "CMT"
#> Calculating residuals/tables
#> done
#> user system elapsed -#> 809.956 4.286 156.438
traceplot(f_dmta_nlmixr_saem$nm) +#> 813.299 3.736 151.935
traceplot(f_dmta_nlmixr_saem$nm)
#> Error in traceplot(f_dmta_nlmixr_saem$nm): could not find function "traceplot"
summary(f_dmta_nlmixr_saem)
#> nlmixr version used for fitting: 2.0.4 #> mkin version used for pre-fitting: 1.0.5 #> R version used for fitting: 4.1.0 -#> Date of fit: Thu Jul 29 12:08:09 2021 -#> Date of summary: Thu Jul 29 12:08:09 2021 +#> Date of fit: Wed Aug 4 16:16:18 2021 +#> Date of summary: Wed Aug 4 16:16:18 2021 #> #> Equations: #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -533,7 +533,7 @@ specific pieces of information in the comments.

#> #> Degradation model predictions using RxODE #> -#> Fitted in 156.17 s +#> Fitted in 151.67 s #> #> Variance model: Two-component variance function #> diff --git a/docs/dev/reference/mkinmod.html b/docs/dev/reference/mkinmod.html index 5db8e719..ac7c2daa 100644 --- a/docs/dev/reference/mkinmod.html +++ b/docs/dev/reference/mkinmod.html @@ -344,7 +344,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media

parent = mkinsub("SFO", "m1", full_name = "Test compound"), m1 = mkinsub("SFO", full_name = "Metabolite M1"), name = "SFO_SFO", dll_dir = DLL_dir, unload = TRUE, overwrite = TRUE) -
#> Copied DLL from /tmp/Rtmpjz6gts/filefa69f342e9d9d.so to /home/jranke/.local/share/mkin/SFO_SFO.so
# Now we can save the model and restore it in a new session +
#> Copied DLL from /tmp/RtmpKZJMFk/file179ba717d15c81.so to /home/jranke/.local/share/mkin/SFO_SFO.so
# Now we can save the model and restore it in a new session saveRDS(SFO_SFO.2, file = "~/SFO_SFO.rds") # Terminate the R session here if you would like to check, and then do library(mkin) @@ -393,7 +393,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media

#> }) #> return(predicted) #> } -#> <environment: 0x55556283eae8>
+#> <environment: 0x555559c54f78>
# If we have several parallel metabolites # (compare tests/testthat/test_synthetic_data_for_UBA_2014.R) m_synth_DFOP_par <- mkinmod( diff --git a/docs/dev/reference/nlmixr.mmkin.html b/docs/dev/reference/nlmixr.mmkin.html index b7dfb9ca..99a7ad14 100644 --- a/docs/dev/reference/nlmixr.mmkin.html +++ b/docs/dev/reference/nlmixr.mmkin.html @@ -4501,7 +4501,7 @@ obtained by fitting the same model to a list of datasets using k_A1=rx_expr_11; #> f_parent=1/(1+exp(-(ETA[4]+THETA[4]))); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 5.801 0.369 6.185
f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei") +#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 5.723 0.414 6.136
f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4550,7 +4550,7 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 7.136 0.414 7.548
f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei") +#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.874 0.399 7.27
f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4607,10 +4607,10 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_20); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 15.76 0.429 16.19
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 14.83 0.382 15.21
# Variance by variable is supported by 'saem' and 'focei' f_nlmixr_fomc_sfo_saem_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "saem") -
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.311 0.125 1.436
f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei") +
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.22 0.146 1.365
f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4659,8 +4659,8 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.969 0.428 7.395
f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem") -
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.38 0.122 1.504
f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei") +#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 6.6 0.416 7.016
f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem") +
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 1.551 0.126 1.673
f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4717,7 +4717,7 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_19); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 15.48 0.348 15.82
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 15.24 0.429 15.67
# Identical two-component error for all variables is only possible with # est = 'focei' in nlmixr f_nlmixr_fomc_sfo_focei_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei") @@ -4771,7 +4771,7 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.84 0.482 9.319
f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei") +#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.644 0.416 9.058
f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4830,12 +4830,12 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_21); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 19.56 0.433 19.99
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 18.76 0.426 19.18
# Two-component error by variable is possible with both estimation methods # Variance by variable is supported by 'saem' and 'focei' f_nlmixr_fomc_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "saem", error_model = "obs_tc") -
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.817 0.016 0.834
f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei", +
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.757 0.072 0.829
f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei", error_model = "obs_tc")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); @@ -4887,9 +4887,9 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.572 0.437 9.008
f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem", +#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 8.417 0.388 8.803
f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem", error_model = "obs_tc") -
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.866 0.032 0.897
f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei", +
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
#> Timing stopped at: 0.82 0.035 0.857
f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei", error_model = "obs_tc")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(A1); @@ -4949,7 +4949,7 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_19); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 19.34 0.349 19.69
+#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_A1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 17.61 0.452 18.06
AIC( f_nlmixr_sfo_sfo_focei_const$nm, f_nlmixr_fomc_sfo_focei_const$nm, diff --git a/docs/dev/reference/plot.mixed.mmkin.html b/docs/dev/reference/plot.mixed.mmkin.html index 8962ce1c..746a8640 100644 --- a/docs/dev/reference/plot.mixed.mmkin.html +++ b/docs/dev/reference/plot.mixed.mmkin.html @@ -296,10 +296,10 @@ corresponding model prediction lines for the different datasets.

f_saem <- saem(f, transformations = "saemix")
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:13:54 2021" +#> [1] "Wed Aug 4 16:21:52 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:02 2021"
plot(f_saem) +#> [1] "Wed Aug 4 16:22:00 2021"
plot(f_saem)
f_obs <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE, error_model = "obs") f_nlmix <- nlmix(f_obs) diff --git a/docs/dev/reference/saem.html b/docs/dev/reference/saem.html index 0334e0e1..620173b2 100644 --- a/docs/dev/reference/saem.html +++ b/docs/dev/reference/saem.html @@ -288,27 +288,27 @@ using mmkin.

state.ini = c(parent = 100), fixed_initials = "parent", quiet = TRUE) f_saem_p0_fixed <- saem(f_mmkin_parent_p0_fixed)
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:07 2021" +#> [1] "Wed Aug 4 16:22:05 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:08 2021"
+#> [1] "Wed Aug 4 16:22:06 2021"
f_mmkin_parent <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE) f_saem_sfo <- saem(f_mmkin_parent["SFO", ])
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:11 2021" +#> [1] "Wed Aug 4 16:22:08 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:12 2021"
f_saem_fomc <- saem(f_mmkin_parent["FOMC", ]) +#> [1] "Wed Aug 4 16:22:10 2021"
f_saem_fomc <- saem(f_mmkin_parent["FOMC", ])
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:12 2021" +#> [1] "Wed Aug 4 16:22:10 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:14 2021"
f_saem_dfop <- saem(f_mmkin_parent["DFOP", ]) +#> [1] "Wed Aug 4 16:22:12 2021"
f_saem_dfop <- saem(f_mmkin_parent["DFOP", ])
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:15 2021" +#> [1] "Wed Aug 4 16:22:12 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:18 2021"
+#> [1] "Wed Aug 4 16:22:16 2021"
# The returned saem.mmkin object contains an SaemixObject, therefore we can use # functions from saemix library(saemix) @@ -357,10 +357,10 @@ using mmkin.

f_mmkin_parent_tc <- update(f_mmkin_parent, error_model = "tc") f_saem_fomc_tc <- saem(f_mmkin_parent_tc["FOMC", ])
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:21 2021" +#> [1] "Wed Aug 4 16:22:19 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:27 2021"
compare.saemix(f_saem_fomc$so, f_saem_fomc_tc$so) +#> [1] "Wed Aug 4 16:22:24 2021"
compare.saemix(f_saem_fomc$so, f_saem_fomc_tc$so)
#> Likelihoods calculated by importance sampling
#> AIC BIC #> 1 467.7096 464.9757 #> 2 469.6831 466.5586
@@ -381,15 +381,15 @@ using mmkin.

# four minutes f_saem_sfo_sfo <- saem(f_mmkin["SFO-SFO", ])
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:31 2021" +#> [1] "Wed Aug 4 16:22:27 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:36 2021"
f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ]) +#> [1] "Wed Aug 4 16:22:32 2021"
f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ])
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:36 2021" +#> [1] "Wed Aug 4 16:22:33 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:14:46 2021"
# We can use print, plot and summary methods to check the results +#> [1] "Wed Aug 4 16:22:42 2021"
# We can use print, plot and summary methods to check the results print(f_saem_dfop_sfo)
#> Kinetic nonlinear mixed-effects model fit by SAEM #> Structural model: @@ -432,8 +432,8 @@ using mmkin.

#> saemix version used for fitting: 3.1.9000 #> mkin version used for pre-fitting: 1.0.5 #> R version used for fitting: 4.1.0 -#> Date of fit: Thu Jul 29 12:14:46 2021 -#> Date of summary: Thu Jul 29 12:14:46 2021 +#> Date of fit: Wed Aug 4 16:22:43 2021 +#> Date of summary: Wed Aug 4 16:22:43 2021 #> #> Equations: #> d_parent/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -448,7 +448,7 @@ using mmkin.

#> #> Model predictions using solution type analytical #> -#> Fitted in 9.987 s using 300, 100 iterations +#> Fitted in 10.143 s using 300, 100 iterations #> #> Variance model: Constant variance #> diff --git a/docs/dev/reference/summary.nlmixr.mmkin.html b/docs/dev/reference/summary.nlmixr.mmkin.html index f0131701..70a71683 100644 --- a/docs/dev/reference/summary.nlmixr.mmkin.html +++ b/docs/dev/reference/summary.nlmixr.mmkin.html @@ -258,12 +258,12 @@ nlmixr authors for the parts inherited from nlmixr.

quiet = TRUE, error_model = "tc", cores = 5) f_saemix_dfop_sfo <- mkin::saem(f_mmkin_dfop_sfo)
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:14:50 2021" +#> [1] "Wed Aug 4 16:22:46 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:15:03 2021"
f_nlme_dfop_sfo <- mkin::nlme(f_mmkin_dfop_sfo) +#> [1] "Wed Aug 4 16:22:59 2021"
f_nlme_dfop_sfo <- mkin::nlme(f_mmkin_dfop_sfo)
#> Warning: Iteration 4, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)
#> Warning: Iteration 6, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)
f_nlmixr_dfop_sfo_saem <- nlmixr(f_mmkin_dfop_sfo, est = "saem") -
#> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_m1
#> Timing stopped at: 1.464 0.114 1.576
# The following takes a very long time but gives +
#> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#>
#> → generate SAEM model
#> ✔ done
#> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_m1
#> Timing stopped at: 1.383 0.12 1.503
# The following takes a very long time but gives f_nlmixr_dfop_sfo_focei <- nlmixr(f_mmkin_dfop_sfo, est = "focei")
#> ℹ parameter labels from comments are typically ignored in non-interactive mode
#> ℹ Need to run with the source intact to parse comments
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → creating full model...
#> → pruning branches (`if`/`else`)...
#> ✔ done
#> → loading into symengine environment...
#> ✔ done
#> → calculate jacobian
#>
#> → calculate sensitivities
#>
#> → calculate ∂(f)/∂(η)
#>
#> → calculate ∂(R²)/∂(η)
#>
#> → finding duplicate expressions in inner model...
#>
#> → optimizing duplicate expressions in inner model...
#>
#> → finding duplicate expressions in EBE model...
#>
#> → optimizing duplicate expressions in EBE model...
#>
#> → compiling inner model...
#>
#> ✔ done
#> → finding duplicate expressions in FD model...
#>
#> → optimizing duplicate expressions in FD model...
#>
#> → compiling EBE model...
#>
#> ✔ done
#> → compiling events FD model...
#>
#> ✔ done
#> Model:
#> cmt(parent); #> cmt(m1); @@ -323,7 +323,7 @@ nlmixr authors for the parts inherited from nlmixr.

#> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_21); #> tad=tad(); -#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_m1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 19.62 0.431 20.06
AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm) +#> dosenum=dosenum();
#> Needed Covariates:
#> [1] "f_parent_to_m1" "CMT"
#> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
#> Timing stopped at: 18.43 0.422 18.87
AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm)
#> Error in AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm): object 'f_nlmixr_dfop_sfo_saem' not found
summary(f_nlmixr_dfop_sfo_sfo, data = TRUE)
#> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'f_nlmixr_dfop_sfo_sfo' not found
# } diff --git a/docs/dev/reference/summary.saem.mmkin.html b/docs/dev/reference/summary.saem.mmkin.html index aeb08d12..08e3c8f8 100644 --- a/docs/dev/reference/summary.saem.mmkin.html +++ b/docs/dev/reference/summary.saem.mmkin.html @@ -260,15 +260,15 @@ saemix authors for the parts inherited from saemix.

quiet = TRUE, error_model = "tc", cores = 5) f_saem_dfop_sfo <- saem(f_mmkin_dfop_sfo)
#> Running main SAEM algorithm -#> [1] "Thu Jul 29 12:15:32 2021" +#> [1] "Wed Aug 4 16:23:26 2021" #> .... #> Minimisation finished -#> [1] "Thu Jul 29 12:15:44 2021"
summary(f_saem_dfop_sfo, data = TRUE) +#> [1] "Wed Aug 4 16:23:38 2021"
summary(f_saem_dfop_sfo, data = TRUE)
#> saemix version used for fitting: 3.1.9000 #> mkin version used for pre-fitting: 1.0.5 #> R version used for fitting: 4.1.0 -#> Date of fit: Thu Jul 29 12:15:45 2021 -#> Date of summary: Thu Jul 29 12:15:45 2021 +#> Date of fit: Wed Aug 4 16:23:39 2021 +#> Date of summary: Wed Aug 4 16:23:39 2021 #> #> Equations: #> d_parent/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -283,7 +283,7 @@ saemix authors for the parts inherited from saemix.

#> #> Model predictions using solution type analytical #> -#> Fitted in 13.372 s using 300, 100 iterations +#> Fitted in 12.54 s using 300, 100 iterations #> #> Variance model: Two-component variance function #> diff --git a/vignettes/web_only/dimethenamid_2018.rmd b/vignettes/web_only/dimethenamid_2018.rmd index 30325044..c152e578 100644 --- a/vignettes/web_only/dimethenamid_2018.rmd +++ b/vignettes/web_only/dimethenamid_2018.rmd @@ -1,7 +1,7 @@ --- title: Example evaluations of the dimethenamid data from 2018 author: Johannes Ranke -date: Last change 27 July 2021, built on `r format(Sys.Date(), format = "%d %b %Y")` +date: Last change 4 August 2021, built on `r format(Sys.Date(), format = "%d %b %Y")` output: html_document: toc: true @@ -381,6 +381,8 @@ The following table gives the AIC values obtained with the three packages. ```{r AIC_all} AIC_all <- data.frame( + "Degradation model" = c("SFO", "SFO", "DFOP", "DFOP"), + "Error model" = c("const", "tc", "const", "tc"), nlme = c(AIC(f_parent_nlme_sfo_const), AIC(f_parent_nlme_sfo_tc), NA, AIC(f_parent_nlme_dfop_tc)), nlmixr_focei = sapply(list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm, f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm), AIC), -- cgit v1.2.3 From c41381a961263c28d60976e68923157916c78b15 Mon Sep 17 00:00:00 2001 From: Johannes Ranke Date: Thu, 16 Sep 2021 15:31:13 +0200 Subject: Adapt and improve the dimethenamid vignette Adapt to the corrected data and unify control parameters for saemix and nlmixr with saem. Update docs --- check.log | 15 +- docs/dev/404.html | 2 +- docs/dev/articles/index.html | 2 +- docs/dev/articles/web_only/dimethenamid_2018.html | 245 ++++++++-------- .../figure-html/f_parent_mkin_dfop_const-1.png | Bin 145534 -> 141661 bytes .../f_parent_mkin_dfop_const_test-1.png | Bin 146181 -> 141889 bytes .../figure-html/f_parent_mkin_dfop_tc_test-1.png | Bin 150274 -> 144254 bytes .../figure-html/f_parent_mkin_sfo_const-1.png | Bin 141499 -> 137650 bytes .../f_parent_nlmixr_saem_dfop_const-1.png | Bin 180061 -> 174055 bytes .../figure-html/f_parent_nlmixr_saem_dfop_tc-1.png | Bin 151832 -> 162039 bytes .../f_parent_nlmixr_saem_sfo_const-1.png | Bin 124946 -> 142453 bytes .../figure-html/f_parent_nlmixr_saem_sfo_tc-1.png | Bin 140491 -> 144010 bytes .../figure-html/f_parent_saemix_dfop_const-1.png | Bin 58759 -> 55927 bytes .../figure-html/f_parent_saemix_dfop_tc-1.png | Bin 0 -> 43674 bytes .../figure-html/f_parent_saemix_sfo_const-1.png | Bin 59913 -> 55667 bytes .../figure-html/f_parent_saemix_sfo_tc-1.png | Bin 53550 -> 50848 bytes .../figure-html/plot_parent_nlme-1.png | Bin 147409 -> 143978 bytes .../header-attrs-2.11/header-attrs.js | 12 + docs/dev/authors.html | 2 +- docs/dev/index.html | 4 +- docs/dev/news/index.html | 15 +- docs/dev/pkgdown.yml | 2 +- docs/dev/reference/dimethenamid_2018-1.png | Bin 264364 -> 263830 bytes docs/dev/reference/dimethenamid_2018-2.png | Bin 245108 -> 246327 bytes docs/dev/reference/dimethenamid_2018.html | 320 ++++++++++----------- docs/dev/reference/endpoints.html | 2 +- docs/dev/reference/index.html | 2 +- docs/dev/reference/mean_degparms.html | 2 +- docs/dev/reference/mkinmod.html | 6 +- docs/dev/reference/nlme-1.png | Bin 68943 -> 68789 bytes docs/dev/reference/nlme-2.png | Bin 94409 -> 92904 bytes docs/dev/reference/nlme.html | 18 +- docs/dev/reference/nlme.mmkin.html | 2 +- docs/dev/reference/nlmixr.mmkin.html | 31 +- docs/dev/reference/plot.mixed.mmkin.html | 6 +- docs/dev/reference/reexports.html | 2 +- docs/dev/reference/saem.html | 40 +-- docs/dev/reference/summary.nlmixr.mmkin.html | 10 +- docs/dev/reference/tffm0.html | 2 +- test.log | 6 +- vignettes/FOCUS_D.html | 10 +- vignettes/FOCUS_L.html | 71 +++-- vignettes/mkin.html | 2 +- vignettes/references.bib | 13 + vignettes/twa.html | 2 +- vignettes/web_only/.build.timestamp | 0 vignettes/web_only/dimethenamid_2018.R | 116 ++++++++ vignettes/web_only/dimethenamid_2018.html | 250 ++++++++-------- vignettes/web_only/dimethenamid_2018.rmd | 248 ++++++++-------- .../figure-html/f_parent_mkin_dfop_const-1.png | Bin 60693 -> 58963 bytes .../f_parent_mkin_dfop_const_test-1.png | Bin 60929 -> 59123 bytes .../figure-html/f_parent_mkin_dfop_tc_test-1.png | Bin 62234 -> 60654 bytes .../figure-html/f_parent_mkin_sfo_const-1.png | Bin 58445 -> 57222 bytes .../f_parent_nlmixr_saem_dfop_const-1.png | Bin 92167 -> 87338 bytes .../figure-html/f_parent_nlmixr_saem_dfop_tc-1.png | Bin 76934 -> 81506 bytes .../f_parent_nlmixr_saem_sfo_const-1.png | Bin 62426 -> 72547 bytes .../figure-html/f_parent_nlmixr_saem_sfo_tc-1.png | Bin 70230 -> 73363 bytes .../figure-html/f_parent_saemix_dfop_const-1.png | Bin 41208 -> 38179 bytes .../f_parent_saemix_dfop_const_moreiter-1.png | Bin 39456 -> 0 bytes .../figure-html/f_parent_saemix_dfop_tc-1.png | Bin 31646 -> 30583 bytes .../f_parent_saemix_dfop_tc_moreiter-1.png | Bin 32077 -> 0 bytes .../figure-html/f_parent_saemix_sfo_const-1.png | Bin 35758 -> 34645 bytes .../figure-html/f_parent_saemix_sfo_tc-1.png | Bin 30708 -> 28683 bytes .../f_parent_saemix_sfo_tc_moreiter-1.png | Bin 30416 -> 0 bytes .../figure-html/plot_parent_nlme-1.png | Bin 60491 -> 59533 bytes 65 files changed, 818 insertions(+), 642 deletions(-) create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png create mode 100644 docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js delete mode 100644 vignettes/web_only/.build.timestamp create mode 100644 vignettes/web_only/dimethenamid_2018.R delete mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const_moreiter-1.png delete mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png delete mode 100644 vignettes/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc_moreiter-1.png (limited to 'vignettes/web_only') diff --git a/check.log b/check.log index 79fe0113..5acb6a4d 100644 --- a/check.log +++ b/check.log @@ -14,14 +14,7 @@ Maintainer: ‘Johannes Ranke ’ * checking if this is a source package ... OK * checking if there is a namespace ... OK * checking for executable files ... OK -* checking for hidden files and directories ... NOTE -Found the following hidden files and directories: - vignettes/web_only/.build.timestamp -These were most likely included in error. See section ‘Package -structure’ in the ‘Writing R Extensions’ manual. - -CRAN-pack does not know about - vignettes/web_only/.build.timestamp +* checking for hidden files and directories ... OK * checking for portable file names ... OK * checking for sufficient/correct file permissions ... OK * checking serialization versions ... OK @@ -75,9 +68,5 @@ CRAN-pack does not know about * checking for detritus in the temp directory ... OK * DONE -Status: 1 NOTE -See - ‘/home/jranke/git/mkin/mkin.Rcheck/00check.log’ -for details. - +Status: OK diff --git a/docs/dev/404.html b/docs/dev/404.html index 98c0b1e0..38898979 100644 --- a/docs/dev/404.html +++ b/docs/dev/404.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0
diff --git a/docs/dev/articles/index.html b/docs/dev/articles/index.html index 99ce950b..c0338df8 100644 --- a/docs/dev/articles/index.html +++ b/docs/dev/articles/index.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/articles/web_only/dimethenamid_2018.html b/docs/dev/articles/web_only/dimethenamid_2018.html index 9a6d8388..b35d8210 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018.html +++ b/docs/dev/articles/web_only/dimethenamid_2018.html @@ -32,7 +32,7 @@ mkin - 1.0.5 + 1.1.0 @@ -95,13 +95,13 @@ -
+

Example evaluations of the dimethenamid data from 2018

Johannes Ranke

-

Last change 4 August 2021, built on 04 Aug 2021

+

Last change 16 September 2021, built on 16 Sep 2021

Source: vignettes/web_only/dimethenamid_2018.rmd @@ -110,31 +110,28 @@ -

Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany
Privatdozent at the University of Bremen

+

Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany

Introduction

-

During the preparation of the journal article on nonlinear mixed-effects models in degradation kinetics (submitted) and the analysis of the dimethenamid degradation data analysed therein, a need for a more detailed analysis using not only nlme and saemix, but also nlmixr for fitting the mixed-effects models was identified.

+

During the preparation of the journal article on nonlinear mixed-effects models in degradation kinetics (Ranke et al. 2021) and the analysis of the dimethenamid degradation data analysed therein, a need for a more detailed analysis using not only nlme and saemix, but also nlmixr for fitting the mixed-effects models was identified.

This vignette is an attempt to satisfy this need.

Data

-

Residue data forming the basis for the endpoints derived in the conclusion on the peer review of the pesticide risk assessment of dimethenamid-P published by the European Food Safety Authority (EFSA) in 2018 (EFSA 2018) were transcribed from the risk assessment report (Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria 2018) which can be downloaded from the EFSA register of questions.

+

Residue data forming the basis for the endpoints derived in the conclusion on the peer review of the pesticide risk assessment of dimethenamid-P published by the European Food Safety Authority (EFSA) in 2018 (EFSA 2018) were transcribed from the risk assessment report (Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria 2018) which can be downloaded from the Open EFSA repository https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716.

The data are available in the mkin package. The following code (hidden by default, please use the button to the right to show it) treats the data available for the racemic mixture dimethenamid (DMTA) and its enantiomer dimethenamid-P (DMTAP) in the same way, as no difference between their degradation behaviour was identified in the EU risk assessment. The observation times of each dataset are multiplied with the corresponding normalisation factor also available in the dataset, in order to make it possible to describe all datasets with a single set of parameters.

Also, datasets observed in the same soil are merged, resulting in dimethenamid (DMTA) data from six soils.

 library(mkin)
-dmta_ds <- lapply(1:8, function(i) {
+dmta_ds <- lapply(1:7, function(i) {
   ds_i <- dimethenamid_2018$ds[[i]]$data
   ds_i[ds_i$name == "DMTAP", "name"] <-  "DMTA"
   ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i]
   ds_i
 })
 names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title)
-dmta_ds[["Borstel"]] <- rbind(dmta_ds[["Borstel 1"]], dmta_ds[["Borstel 2"]])
-dmta_ds[["Borstel 1"]] <- NULL
-dmta_ds[["Borstel 2"]] <- NULL
 dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]])
 dmta_ds[["Elliot 1"]] <- NULL
 dmta_ds[["Elliot 2"]] <- NULL
@@ -154,20 +151,20 @@ error_model = "tc", quiet = TRUE)

The plot of the individual SFO fits shown below suggests that at least in some datasets the degradation slows down towards later time points, and that the scatter of the residuals error is smaller for smaller values (panel to the right):

-plot(mixed(f_parent_mkin_const["SFO", ]))
+plot(mixed(f_parent_mkin_const["SFO", ]))

Using biexponential decline (DFOP) results in a slightly more random scatter of the residuals:

-plot(mixed(f_parent_mkin_const["DFOP", ]))
+plot(mixed(f_parent_mkin_const["DFOP", ]))

The population curve (bold line) in the above plot results from taking the mean of the individual transformed parameters, i.e. of log k1 and log k2, as well as of the logit of the g parameter of the DFOP model). Here, this procedure does not result in parameters that represent the degradation well, because in some datasets the fitted value for k2 is extremely close to zero, leading to a log k2 value that dominates the average. This is alleviated if only rate constants that pass the t-test for significant difference from zero (on the untransformed scale) are considered in the averaging:

-plot(mixed(f_parent_mkin_const["DFOP", ]), test_log_parms = TRUE)
+plot(mixed(f_parent_mkin_const["DFOP", ]), test_log_parms = TRUE)

While this is visually much more satisfactory, such an average procedure could introduce a bias, as not all results from the individual fits enter the population curve with the same weight. This is where nonlinear mixed-effects models can help out by treating all datasets with equally by fitting a parameter distribution model together with the degradation model and the error model (see below).

The remaining trend of the residuals to be higher for higher predicted residues is reduced by using the two-component error model:

-plot(mixed(f_parent_mkin_tc["DFOP", ]), test_log_parms = TRUE)
+plot(mixed(f_parent_mkin_tc["DFOP", ]), test_log_parms = TRUE)

@@ -177,175 +174,184 @@

nlme

-

The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We use would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.

+

The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.

 library(nlme)
 f_parent_nlme_sfo_const <- nlme(f_parent_mkin_const["SFO", ])
-#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ])
-# maxIter = 50 reached
+# f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ])
 f_parent_nlme_sfo_tc <- nlme(f_parent_mkin_tc["SFO", ])
 f_parent_nlme_dfop_tc <- nlme(f_parent_mkin_tc["DFOP", ])
-

Note that overparameterisation is also indicated by warnings obtained when fitting SFO or DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in some iterations). In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.

+

Note that a certain degree of overparameterisation is also indicated by a warning obtained when fitting DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in iteration 3). However, as this warning does not occur in later iterations, and specifically not in the last of the 6 iterations, we can ignore this warning.

+

The model comparison function of the nlme package can directly be applied to these fits showing a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.

-f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ],
-  random = pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1)))
-anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol) # not better
-#f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc,
-#  random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))
-# using log Cholesky parameterisation for random effects (nlme default) does
-# not converge here and gives lots of warnings about the LME step not converging
-

The model comparison function of the nlme package can directly be applied to these fits showing a similar goodness-of-fit of the SFO model, but a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.

-
 anova(
   f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
 )
                        Model df    AIC    BIC  logLik   Test L.Ratio p-value
-f_parent_nlme_sfo_const     1  5 818.63 834.00 -404.31                       
-f_parent_nlme_sfo_tc        2  6 820.61 839.06 -404.31 1 vs 2   0.014  0.9049
-f_parent_nlme_dfop_tc       3 10 687.84 718.59 -333.92 2 vs 3 140.771  <.0001
+f_parent_nlme_sfo_const 1 5 796.60 811.82 -393.30 +f_parent_nlme_sfo_tc 2 6 798.60 816.86 -393.30 1 vs 2 0.00 0.998 +f_parent_nlme_dfop_tc 3 10 671.91 702.34 -325.96 2 vs 3 134.69 <.0001 +

In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.

+
+f_parent_nlme_sfo_const_logchol <- nlme(f_parent_mkin_const["SFO", ],
+  random = nlme::pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1)))
+anova(f_parent_nlme_sfo_const, f_parent_nlme_sfo_const_logchol)
+f_parent_nlme_sfo_tc_logchol <- nlme(f_parent_mkin_tc["SFO", ],
+  random = nlme::pdLogChol(list(DMTA_0 ~ 1, log_k_DMTA ~ 1)))
+anova(f_parent_nlme_sfo_tc, f_parent_nlme_sfo_tc_logchol)
+f_parent_nlme_dfop_tc_logchol <- nlme(f_parent_mkin_const["DFOP", ],
+  random = nlme::pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))
+anova(f_parent_nlme_dfop_tc, f_parent_nlme_dfop_tc_logchol)
+

While the SFO variants converge fast, the additional parameters introduced by this lead to convergence warnings for the DFOP model. The model comparison clearly show that adding correlations between random effects does not improve the fits.

The selected model (DFOP with two-component error) fitted to the data assuming no correlations between random effects is shown below.

-plot(f_parent_nlme_dfop_tc)
+plot(f_parent_nlme_dfop_tc)

saemix

-

The saemix package provided the first Open Source implementation of the Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. SAEM fits of degradation models can be performed using an interface to the saemix package available in current development versions of the mkin package.

-

The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit.

-

The convergence plot for the SFO model using constant variance is shown below.

+

The saemix package provided the first Open Source implementation of the Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. SAEM fits of degradation models can be conveniently performed using an interface to the saemix package available in current development versions of the mkin package.

+

The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit. As we will compare the SAEM implementation of saemix to the results obtained using the nlmixr package later, we define control settings that work well for all the parent data fits shown in this vignette.

 library(saemix)
-f_parent_saemix_sfo_const <- mkin::saem(f_parent_mkin_const["SFO", ], quiet = TRUE,
-  transformations = "saemix")
+saemix_control <- saemixControl(nbiter.saemix = c(800, 300), nb.chains = 15,
+    print = FALSE, save = FALSE, save.graphs = FALSE, displayProgress = FALSE)
+

The convergence plot for the SFO model using constant variance is shown below.

+
+f_parent_saemix_sfo_const <- mkin::saem(f_parent_mkin_const["SFO", ], quiet = TRUE,
+  control = saemix_control, transformations = "saemix")
 plot(f_parent_saemix_sfo_const$so, plot.type = "convergence")

Obviously the default number of iterations is sufficient to reach convergence. This can also be said for the SFO fit using the two-component error model.

-
+
 f_parent_saemix_sfo_tc <- mkin::saem(f_parent_mkin_tc["SFO", ], quiet = TRUE,
-  transformations = "saemix")
+  control = saemix_control, transformations = "saemix")
 plot(f_parent_saemix_sfo_tc$so, plot.type = "convergence")

 

 
When fitting the DFOP model with constant variance, parameter convergence is not as unambiguous (see the failure of nlme with the default number of iterations above). Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence.

-
+
 f_parent_saemix_dfop_const <- mkin::saem(f_parent_mkin_const["DFOP", ], quiet = TRUE,
-  control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
-    save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
-  transformations = "saemix")
+  control = saemix_control, transformations = "saemix")
 plot(f_parent_saemix_dfop_const$so, plot.type = "convergence")

 

-
The same applies to the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced by using the two-component error, it remains more or less stable already after 200 iterations of the first phase.

-
-f_parent_saemix_dfop_tc_moreiter <- mkin::saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE,
-  control = saemixControl(nbiter.saemix = c(800, 200), print = FALSE,
-    save = FALSE, save.graphs = FALSE, displayProgress = FALSE),
-  transformations = "saemix")
-plot(f_parent_saemix_dfop_tc_moreiter$so, plot.type = "convergence")

-

-
The four combinations can be compared using the model comparison function from the saemix package:

+
The same applies in the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced by using the two-component error, it remains more or less stable already after 200 iterations of the first phase.

 
-compare.saemix(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
-  f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so)

+f_parent_saemix_dfop_tc <- mkin::saem(f_parent_mkin_tc["DFOP", ], quiet = TRUE,
+  control = saemix_control, transformations = "saemix")
+plot(f_parent_saemix_dfop_tc$so, plot.type = "convergence")

+
 The four combinations and including the variations of the DFOP/tc combination can be compared using the model comparison function from the saemix package:

+
+compare.saemix(
+  f_parent_saemix_sfo_const$so,
+  f_parent_saemix_sfo_tc$so,
+  f_parent_saemix_dfop_const$so,
+  f_parent_saemix_dfop_tc$so)

 
Likelihoods calculated by importance sampling

 
     AIC    BIC
-1 818.37 817.33
-2 820.38 819.14
-3 725.91 724.04
-4 683.64 681.55

-
As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. The numeric values are reasonably close to the ones obtained using nlme, considering that the algorithms for fitting the model and for the likelihood calculation are quite different.

+1 796.37 795.33
+2 798.37 797.13
+3 713.16 711.28
+4 666.10 664.01
+

As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. Using more iterations and/or more chains does not have a large influence on the final AIC (not shown).

In order to check the influence of the likelihood calculation algorithms implemented in saemix, the likelihood from Gaussian quadrature is added to the best fit, and the AIC values obtained from the three methods are compared.

-
-f_parent_saemix_dfop_tc_moreiter$so <-
-  llgq.saemix(f_parent_saemix_dfop_tc_moreiter$so)
-AIC(f_parent_saemix_dfop_tc_moreiter$so)
-
[1] 683.64
-
-AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "gq")
-
[1] 683.7
-
-AIC(f_parent_saemix_dfop_tc_moreiter$so, method = "lin")
-
[1] 683.17
-

The AIC values based on importance sampling and Gaussian quadrature are quite similar. Using linearisation is less accurate, but still gives a similar value.

+
+f_parent_saemix_dfop_tc$so <-
+  llgq.saemix(f_parent_saemix_dfop_tc$so)
+AIC(f_parent_saemix_dfop_tc$so)
+
[1] 666.1
+
+AIC(f_parent_saemix_dfop_tc$so, method = "gq")
+
[1] 666.03
+
+AIC(f_parent_saemix_dfop_tc$so, method = "lin")
+
[1] 665.48
+

The AIC values based on importance sampling and Gaussian quadrature are very similar. Using linearisation is known to be less accurate, but still gives a similar value.

nlmixr

-

In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.

-

First, the focei algorithm is used for the four model combinations and the goodness of fit of the results is compared.

-
+
In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely the First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.

+
First, the focei algorithm is used for the four model combinations. A number of warnings are produced with unclear significance.

+
 library(nlmixr)
 f_parent_nlmixr_focei_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "focei")
 f_parent_nlmixr_focei_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "focei")
 f_parent_nlmixr_focei_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "focei")
 f_parent_nlmixr_focei_dfop_tc<- nlmixr(f_parent_mkin_tc["DFOP", ], est = "focei")

-
-AIC(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
-  f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm)

-
                                    df    AIC
-f_parent_nlmixr_focei_sfo_const$nm   5 818.63
-f_parent_nlmixr_focei_sfo_tc$nm      6 820.61
-f_parent_nlmixr_focei_dfop_const$nm  9 728.11
-f_parent_nlmixr_focei_dfop_tc$nm    10 687.82

+
+aic_nlmixr_focei <- sapply(
+  list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
+    f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm),
+  AIC)

 
The AIC values are very close to the ones obtained with nlme which are repeated below for convenience.

 
-AIC(
-  f_parent_nlme_sfo_const, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc
+aic_nlme <- sapply(
+  list(f_parent_nlme_sfo_const, NA, f_parent_nlme_sfo_tc, f_parent_nlme_dfop_tc),
+  function(x) if (is.na(x[1])) NA else AIC(x))
+aic_nlme_nlmixr_focei <- data.frame(
+  "Degradation model" = c("SFO", "SFO", "DFOP", "DFOP"),
+  "Error model" = rep(c("constant variance", "two-component"), 2),
+  "AIC (nlme)" = aic_nlme,
+  "AIC (nlmixr with FOCEI)" = aic_nlmixr_focei,
+  check.names = FALSE
 )

-
                        df    AIC
-f_parent_nlme_sfo_const  5 818.63
-f_parent_nlme_sfo_tc     6 820.61
-f_parent_nlme_dfop_tc   10 687.84

-
Secondly, we use the SAEM estimation routine and check the convergence plots for SFO with constant variance

+
Secondly, we use the SAEM estimation routine and check the convergence plots. The control parameters also used for the saemix fits are defined beforehand.

+
+nlmixr_saem_control <- saemControl(logLik = TRUE,
+  nBurn = 1000, nEm = 300, nmc = 15)

+
The we fit SFO with constant variance

 
 f_parent_nlmixr_saem_sfo_const <- nlmixr(f_parent_mkin_const["SFO", ], est = "saem",
-  control = nlmixr::saemControl(logLik = TRUE))
+  control = nlmixr_saem_control)
 traceplot(f_parent_nlmixr_saem_sfo_const$nm)

 

-
for SFO with two-component error

+
and SFO with two-component error.

 
 f_parent_nlmixr_saem_sfo_tc <- nlmixr(f_parent_mkin_tc["SFO", ], est = "saem",
-  control = nlmixr::saemControl(logLik = TRUE))
+  control = nlmixr_saem_control)
 traceplot(f_parent_nlmixr_saem_sfo_tc$nm)

 

-
For DFOP with constant variance, the convergence plots show considerable instability of the fit, which can be alleviated by increasing the number of iterations and the number of parallel chains for the first phase of algorithm.

+
For DFOP with constant variance, the convergence plots show considerable instability of the fit, which indicates overparameterisation which was already observed earlier for this model combination.

 
 f_parent_nlmixr_saem_dfop_const <- nlmixr(f_parent_mkin_const["DFOP", ], est = "saem",
-  control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000), nmc = 15)
+  control = nlmixr_saem_control)
 traceplot(f_parent_nlmixr_saem_dfop_const$nm)

 

-
For DFOP with two-component error, the same increase in iterations and parallel chains was used, but using the two-component error appears to lead to a less erratic convergence, so this may not be necessary to this degree.

+
For DFOP with two-component error, a less erratic convergence is seen.

 
 f_parent_nlmixr_saem_dfop_tc <- nlmixr(f_parent_mkin_tc["DFOP", ], est = "saem",
-  control = nlmixr::saemControl(logLik = TRUE, nBurn = 1000, nmc = 15))
+  control = nlmixr_saem_control)
 traceplot(f_parent_nlmixr_saem_dfop_tc$nm)

 

-
The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using the two-component error model is given as Infinity.

+
The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using constant error is given as Infinity.

 
 AIC(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
   f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm)

 
                                   df    AIC
-f_parent_nlmixr_saem_sfo_const$nm   5 820.54
-f_parent_nlmixr_saem_sfo_tc$nm      6 835.26
-f_parent_nlmixr_saem_dfop_const$nm  9 842.84
-f_parent_nlmixr_saem_dfop_tc$nm    10 684.51

+f_parent_nlmixr_saem_sfo_const$nm   5 798.68
+f_parent_nlmixr_saem_sfo_tc$nm      6 808.88
+f_parent_nlmixr_saem_dfop_const$nm  9 815.95
+f_parent_nlmixr_saem_dfop_tc$nm    10 669.57

The following table gives the AIC values obtained with the three packages.

 AIC_all <- data.frame(
+  check.names = FALSE,
   "Degradation model" = c("SFO", "SFO", "DFOP", "DFOP"),
   "Error model" = c("const", "tc", "const", "tc"),
   nlme = c(AIC(f_parent_nlme_sfo_const), AIC(f_parent_nlme_sfo_tc), NA, AIC(f_parent_nlme_dfop_tc)),
   nlmixr_focei = sapply(list(f_parent_nlmixr_focei_sfo_const$nm, f_parent_nlmixr_focei_sfo_tc$nm,
   f_parent_nlmixr_focei_dfop_const$nm, f_parent_nlmixr_focei_dfop_tc$nm), AIC),
   saemix = sapply(list(f_parent_saemix_sfo_const$so, f_parent_saemix_sfo_tc$so,
-    f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc_moreiter$so), AIC),
+    f_parent_saemix_dfop_const$so, f_parent_saemix_dfop_tc$so), AIC),
   nlmixr_saem = sapply(list(f_parent_nlmixr_saem_sfo_const$nm, f_parent_nlmixr_saem_sfo_tc$nm,
   f_parent_nlmixr_saem_dfop_const$nm, f_parent_nlmixr_saem_dfop_tc$nm), AIC)
 )
 kable(AIC_all)
Degradation.modelError.model nlme nlmixr_focei saemix
SFOconst 818.63 818.63 818.37 820.54
SFOtc 820.61 820.61 820.38 835.26
DFOPconst NA 728.11 725.91 842.84
DFOPtc 687.84 687.82 683.64
- - + + @@ -355,34 +361,34 @@ f_parent_nlmixr_saem_dfop_tc$nm 10 684.51 - - - - + + + + - - - - + + + + - - - + + + - - - - + + + +
Degradation.modelError.modelDegradation modelError model nlme nlmixr_focei saemix
SFO const818.63818.63818.37820.54796.60796.62796.37798.68
SFO tc820.61820.61820.38835.26798.60798.61798.37808.88
DFOP const NA728.11725.91842.84750.91713.16815.95
DFOP tc687.84687.82683.64684.51671.91666.60666.10669.57
@@ -397,6 +403,9 @@ f_parent_nlmixr_saem_dfop_tc$nm 10 684.51

EFSA. 2018. “Peer Review of the Pesticide Risk Assessment of the Active Substance Dimethenamid-P.” EFSA Journal 16 (4): 5211.

+
+

Ranke, Johannes, Janina Wöltjen, Jana Schmidt, and Emmanuelle Comets. 2021. “Taking Kinetic Evaluations of Degradation Data to the Next Level with Nonlinear Mixed-Effects Models.” Environments 8 (8). https://doi.org/10.3390/environments8080071.

+

Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria. 2018. “Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour, Rev. 2 - November 2017.” https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716.

diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png index c51afe54..8eb464d1 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png index 080f0dde..9e4b951a 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png index a3933e54..830fec65 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png index 8dee2e3c..133249a4 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png index 54a8c1a6..db28e43d 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png index 91f3d977..718524e7 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png index c84f2926..9dde6124 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png index cfef9dfc..e2368797 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png index a4695eea..7c79b56c 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png new file mode 100644 index 00000000..8478adcf Binary files /dev/null and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png index 469ebafd..18b546e9 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png index d26bcc09..6a0c05c5 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png index 6edeb794..ed978664 100644 Binary files a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png and b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png differ diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js b/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js new file mode 100644 index 00000000..dd57d92e --- /dev/null +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js @@ -0,0 +1,12 @@ +// Pandoc 2.9 adds attributes on both header and div. We remove the former (to +// be compatible with the behavior of Pandoc < 2.8). +document.addEventListener('DOMContentLoaded', function(e) { + var hs = document.querySelectorAll("div.section[class*='level'] > :first-child"); + var i, h, a; + for (i = 0; i < hs.length; i++) { + h = hs[i]; + if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6 + a = h.attributes; + while (a.length > 0) h.removeAttribute(a[0].name); + } +}); diff --git a/docs/dev/authors.html b/docs/dev/authors.html index 4208dc24..943cba1b 100644 --- a/docs/dev/authors.html +++ b/docs/dev/authors.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/index.html b/docs/dev/index.html index 8b0b2386..452d9bdb 100644 --- a/docs/dev/index.html +++ b/docs/dev/index.html @@ -43,7 +43,7 @@ mkin - 1.0.5 + 1.1.0 @@ -264,7 +264,7 @@ Ranke J, Wöltjen J, Meinecke S (2018) Comparison of software tools for kinetic

Dev status

    • -
  • Build Status
    • +
  • Build Status
  • codecov
diff --git a/docs/dev/news/index.html b/docs/dev/news/index.html index 5b153f37..f3cc89d9 100644 --- a/docs/dev/news/index.html +++ b/docs/dev/news/index.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 @@ -141,9 +141,9 @@ Source: NEWS.md -
-

-mkin 1.0.5 (unreleased)

+
+

+mkin 1.1.0 (unreleased)

Mixed-effects models

@@ -155,6 +155,13 @@

  • ‘vignettes/web_only/dimethenamid_2018.rmd’: Example evaluations of the dimethenamid data.

    • +
    +
    +

    +mkin 1.0.5 (2021-09-15)

    +
      +
    • ‘dimethenamid_2018’: Correct the data for the Borstel soil. The five observations from Staudenmaier (2013) that were previously stored as “Borstel 2” are actually just a subset of the 16 observations in “Borstel 1” which is now simply “Borstel”
      • +

    diff --git a/docs/dev/pkgdown.yml b/docs/dev/pkgdown.yml index f184b7a5..e932afd0 100644 --- a/docs/dev/pkgdown.yml +++ b/docs/dev/pkgdown.yml @@ -11,7 +11,7 @@ articles: web_only/benchmarks: benchmarks.html web_only/compiled_models: compiled_models.html web_only/dimethenamid_2018: dimethenamid_2018.html -last_built: 2021-08-04T13:49Z +last_built: 2021-09-16T15:10Z urls: reference: https://pkgdown.jrwb.de/mkin/reference article: https://pkgdown.jrwb.de/mkin/articles diff --git a/docs/dev/reference/dimethenamid_2018-1.png b/docs/dev/reference/dimethenamid_2018-1.png index 52b8a2be..b8c5355f 100644 Binary files a/docs/dev/reference/dimethenamid_2018-1.png and b/docs/dev/reference/dimethenamid_2018-1.png differ diff --git a/docs/dev/reference/dimethenamid_2018-2.png b/docs/dev/reference/dimethenamid_2018-2.png index a81b2aaf..3b8a123b 100644 Binary files a/docs/dev/reference/dimethenamid_2018-2.png and b/docs/dev/reference/dimethenamid_2018-2.png differ diff --git a/docs/dev/reference/dimethenamid_2018.html b/docs/dev/reference/dimethenamid_2018.html index a77cf0f4..919e9363 100644 --- a/docs/dev/reference/dimethenamid_2018.html +++ b/docs/dev/reference/dimethenamid_2018.html @@ -77,7 +77,7 @@ constrained by data protection regulations." /> mkin - 1.0.5 + 1.1.0

    @@ -162,7 +162,7 @@ constrained by data protection regulations.

    Format

    -

    An mkindsg object grouping eight datasets with some meta information

    +

    An mkindsg object grouping seven datasets with some meta information

    Source

    Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria (2018) @@ -177,42 +177,36 @@ specific pieces of information in the comments.

    Examples

    print(dimethenamid_2018)
-
    #> <mkindsg> holding 8 mkinds objects
+
    #> <mkindsg> holding 7 mkinds objects
 #> Title $title:  Aerobic soil degradation data on dimethenamid-P from the EU assessment in 2018 
 #> Occurrence of observed compounds $observed_n:
 #> DMTAP   M23   M27   M31  DMTA 
-#>     4     7     7     7     4 
+#>     3     7     7     7     4 
 #> Time normalisation factors $f_time_norm:
-#> [1] 1.0000000 0.9706477 0.9706477 1.2284784 1.2284784 0.6233856 0.7678922
-#> [8] 0.6733938
+#> [1] 1.0000000 0.9706477 1.2284784 1.2284784 0.6233856 0.7678922 0.6733938
 #> Meta information $meta:
-#>                       study  usda_soil_type study_moisture_ref_type
-#> Calke         Unsworth 2014      Sandy loam                     pF2
-#> Borstel 1 Staudenmaier 2013            Sand                     pF1
-#> Borstel 2 Staudenmaier 2009            Sand                     pF1
-#> Elliot 1         Wendt 1997       Clay loam                   pF2.5
-#> Elliot 2         Wendt 1997       Clay loam                   pF2.5
-#> Flaach           König 1996 Sandy clay loam                     pF1
-#> BBA 2.2          König 1995      Loamy sand                     pF1
-#> BBA 2.3          König 1995      Sandy loam                     pF1
-#>           rel_moisture study_ref_moisture temperature
-#> Calke             1.00                 NA          20
-#> Borstel 1         0.50              23.00          20
-#> Borstel 2         0.50              23.00          20
-#> Elliot 1          0.75              33.37          23
-#> Elliot 2          0.75              33.37          23
-#> Flaach            0.40                 NA          20
-#> BBA 2.2           0.40                 NA          20
-#> BBA 2.3           0.40                 NA          20
    dmta_ds <- lapply(1:8, function(i) {
+#>                      study  usda_soil_type study_moisture_ref_type rel_moisture
+#> Calke        Unsworth 2014      Sandy loam                     pF2         1.00
+#> Borstel  Staudenmaier 2009            Sand                     pF1         0.50
+#> Elliot 1        Wendt 1997       Clay loam                   pF2.5         0.75
+#> Elliot 2        Wendt 1997       Clay loam                   pF2.5         0.75
+#> Flaach          König 1996 Sandy clay loam                     pF1         0.40
+#> BBA 2.2         König 1995      Loamy sand                     pF1         0.40
+#> BBA 2.3         König 1995      Sandy loam                     pF1         0.40
+#>          study_ref_moisture temperature
+#> Calke                    NA          20
+#> Borstel               23.00          20
+#> Elliot 1              33.37          23
+#> Elliot 2              33.37          23
+#> Flaach                   NA          20
+#> BBA 2.2                  NA          20
+#> BBA 2.3                  NA          20
    dmta_ds <- lapply(1:7, function(i) {
   ds_i <- dimethenamid_2018$ds[[i]]$data
   ds_i[ds_i$name == "DMTAP", "name"] <-  "DMTA"
   ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i]
   ds_i
 })
 names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title)
-dmta_ds[["Borstel"]] <- rbind(dmta_ds[["Borstel 1"]], dmta_ds[["Borstel 2"]])
-dmta_ds[["Borstel 1"]] <- NULL
-dmta_ds[["Borstel 2"]] <- NULL
 dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]])
 dmta_ds[["Elliot 1"]] <- NULL
 dmta_ds[["Elliot 2"]] <- NULL
@@ -231,33 +225,33 @@ specific pieces of information in the comments.
    
 
    #> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
    #> function () 
 #> {
 #>     ini({
-#>         DMTA_0 = 98.7697627680706
-#>         eta.DMTA_0 ~ 2.35171765917765
+#>         DMTA_0 = 98.7132391714013
+#>         eta.DMTA_0 ~ 2.32692496033921
 #>         log_k_M23 = -3.92162409637283
 #>         eta.log_k_M23 ~ 0.549278519419884
-#>         log_k_M27 = -4.33774620773911
-#>         eta.log_k_M27 ~ 0.864474956685295
-#>         log_k_M31 = -4.24767627688461
-#>         eta.log_k_M31 ~ 0.750297149164171
-#>         log_k1 = -2.2341008812259
-#>         eta.log_k1 ~ 0.902976221565793
-#>         log_k2 = -3.7762779983269
-#>         eta.log_k2 ~ 1.57684519529298
-#>         g_qlogis = 0.450175725479389
-#>         eta.g_qlogis ~ 3.0851335687675
-#>         f_DMTA_tffm0_1_qlogis = -2.09240906629456
+#>         log_k_M27 = -4.33057580082049
+#>         eta.log_k_M27 ~ 0.855184233768426
+#>         log_k_M31 = -4.24415516780733
+#>         eta.log_k_M31 ~ 0.745746058085877
+#>         log_k1 = -2.23515804885306
+#>         eta.log_k1 ~ 0.901033446532357
+#>         log_k2 = -3.77581484944379
+#>         eta.log_k2 ~ 1.57682329638124
+#>         g_qlogis = 0.436302910942805
+#>         eta.g_qlogis ~ 3.10190528862808
+#>         f_DMTA_tffm0_1_qlogis = -2.0914852208395
 #>         eta.f_DMTA_tffm0_1_qlogis ~ 0.3
-#>         f_DMTA_tffm0_2_qlogis = -2.18057573598794
+#>         f_DMTA_tffm0_2_qlogis = -2.17879574608926
 #>         eta.f_DMTA_tffm0_2_qlogis ~ 0.3
-#>         f_DMTA_tffm0_3_qlogis = -2.14267187609763
+#>         f_DMTA_tffm0_3_qlogis = -2.14036526460782
 #>         eta.f_DMTA_tffm0_3_qlogis ~ 0.3
-#>         sigma_low_DMTA = 0.697933852349996
+#>         sigma_low_DMTA = 0.700117227383809
 #>         rsd_high_DMTA = 0.0257724286053519
-#>         sigma_low_M23 = 0.697933852349996
+#>         sigma_low_M23 = 0.700117227383809
 #>         rsd_high_M23 = 0.0257724286053519
-#>         sigma_low_M27 = 0.697933852349996
+#>         sigma_low_M27 = 0.700117227383809
 #>         rsd_high_M27 = 0.0257724286053519
-#>         sigma_low_M31 = 0.697933852349996
+#>         sigma_low_M31 = 0.700117227383809
 #>         rsd_high_M31 = 0.0257724286053519
 #>     })
 #>     model({
@@ -295,7 +289,7 @@ specific pieces of information in the comments.
    
 #>         M31 ~ add(sigma_low_M31) + prop(rsd_high_M31)
 #>     })
 #> }
-#> <environment: 0x555559ac3820>
    # The focei fit takes about four minutes on my system
+#> <environment: 0x555559e97ac0>
    # The focei fit takes about four minutes on my system
 system.time(
   f_dmta_nlmixr_focei <- nlmixr(f_dmta_mkin_tc, est = "focei",
     control = nlmixr::foceiControl(print = 500))
@@ -308,7 +302,7 @@ specific pieces of information in the comments.
    
 #> 
    #> → optimizing duplicate expressions in inner model...
    #> [====|====|====|====|====|====|====|====|====|====] 0:00:07 
 #> 
    #> → finding duplicate expressions in EBE model...
    #> [====|====|====|====|====|====|====|====|====|====] 0:00:00 
 #> 
    #> → optimizing duplicate expressions in EBE model...
    #> [====|====|====|====|====|====|====|====|====|====] 0:00:00 
-#> 
    #> → compiling inner model...
    #>  
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #> 
    #> → optimizing duplicate expressions in FD model...
    #> 
    #> → compiling EBE model...
    #>  
    #> ✔ done
    #> → compiling events FD model...
    #>  
    #> ✔ done
    #> Needed Covariates:
    #> [1] "CMT"
    #> RxODE 1.1.0 using 8 threads (see ?getRxThreads)
+#> 
    #> → compiling inner model...
    #>  
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #> 
    #> → optimizing duplicate expressions in FD model...
    #> 
    #> → compiling EBE model...
    #>  
    #> ✔ done
    #> → compiling events FD model...
    #>  
    #> ✔ done
    #> Needed Covariates:
    #> [1] "CMT"
    #> RxODE 1.1.1 using 8 threads (see ?getRxThreads)
 #>   no cache: create with `rxCreateCache()`
    #> Key: U: Unscaled Parameters; X: Back-transformed parameters; G: Gill difference gradient approximation
 #> F: Forward difference gradient approximation
 #> C: Central difference gradient approximation
@@ -324,12 +318,12 @@ specific pieces of information in the comments.
    
 #> |.....................|        o9 |       o10 |...........|...........|
 #> calculating covariance matrix
 #> done
    #> Calculating residuals/tables
    #> done
    #> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
    #> Warning: last objective function was not at minimum, possible problems in optimization
    #> Warning: S matrix non-positive definite
    #> Warning: using R matrix to calculate covariance
    #> Warning: gradient problems with initial estimate and covariance; see $scaleInfo
    #>    user  system elapsed 
-#> 232.621  14.126 246.850 
    summary(f_dmta_nlmixr_focei)
-
    #> nlmixr version used for fitting:    2.0.4 
-#> mkin version used for pre-fitting:  1.0.5 
-#> R version used for fitting:         4.1.0 
-#> Date of fit:     Wed Aug  4 15:53:54 2021 
-#> Date of summary: Wed Aug  4 15:53:54 2021 
+#> 230.015   8.962 238.957 
    summary(f_dmta_nlmixr_focei)
+
    #> nlmixr version used for fitting:    2.0.5 
+#> mkin version used for pre-fitting:  1.1.0 
+#> R version used for fitting:         4.1.1 
+#> Date of fit:     Thu Sep 16 14:06:55 2021 
+#> Date of summary: Thu Sep 16 14:06:55 2021 
 #> 
 #> Equations:
 #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 *
@@ -346,23 +340,23 @@ specific pieces of information in the comments.
    
 #>            exp(-k2 * time))) * DMTA - k_M31 * M31
 #> 
 #> Data:
-#> 568 observations of 4 variable(s) grouped in 6 datasets
+#> 563 observations of 4 variable(s) grouped in 6 datasets
 #> 
 #> Degradation model predictions using RxODE
 #> 
-#> Fitted in 246.669 s
+#> Fitted in 238.792 s
 #> 
 #> Variance model: Two-component variance function 
 #> 
 #> Mean of starting values for individual parameters:
 #>       DMTA_0    log_k_M23    log_k_M27    log_k_M31 f_DMTA_ilr_1 f_DMTA_ilr_2 
-#>      98.7698      -3.9216      -4.3377      -4.2477       0.1380       0.1393 
+#>      98.7132      -3.9216      -4.3306      -4.2442       0.1376       0.1388 
 #> f_DMTA_ilr_3       log_k1       log_k2     g_qlogis 
-#>      -1.7571      -2.2341      -3.7763       0.4502 
+#>      -1.7554      -2.2352      -3.7758       0.4363 
 #> 
 #> Mean of starting values for error model parameters:
 #> sigma_low  rsd_high 
-#>   0.69793   0.02577 
+#>   0.70012   0.02577 
 #> 
 #> Fixed degradation parameter values:
 #> None
@@ -371,20 +365,20 @@ specific pieces of information in the comments.
    
 #> 
 #> Likelihood calculated by focei  
 #>    AIC  BIC logLik
-#>   1936 2031 -945.9
+#>   1918 2014 -937.2
 #> 
 #> Optimised parameters:
 #>                          est.   lower   upper
-#> DMTA_0                98.7698 98.7356 98.8039
-#> log_k_M23             -3.9216 -3.9235 -3.9197
-#> log_k_M27             -4.3377 -4.3398 -4.3357
-#> log_k_M31             -4.2477 -4.2497 -4.2457
-#> log_k1                -2.2341 -2.2353 -2.2329
-#> log_k2                -3.7763 -3.7781 -3.7744
-#> g_qlogis               0.4502  0.4496  0.4507
-#> f_DMTA_tffm0_1_qlogis -2.0924 -2.0936 -2.0912
-#> f_DMTA_tffm0_2_qlogis -2.1806 -2.1818 -2.1794
-#> f_DMTA_tffm0_3_qlogis -2.1427 -2.1439 -2.1415
+#> DMTA_0                98.7132 98.6801 98.7464
+#> log_k_M23             -3.9216 -3.9235 -3.9198
+#> log_k_M27             -4.3306 -4.3326 -4.3286
+#> log_k_M31             -4.2442 -4.2461 -4.2422
+#> log_k1                -2.2352 -2.2364 -2.2340
+#> log_k2                -3.7758 -3.7776 -3.7740
+#> g_qlogis               0.4363  0.4358  0.4368
+#> f_DMTA_tffm0_1_qlogis -2.0915 -2.0926 -2.0903
+#> f_DMTA_tffm0_2_qlogis -2.1788 -2.1800 -2.1776
+#> f_DMTA_tffm0_3_qlogis -2.1404 -2.1415 -2.1392
 #> 
 #> Correlation: 
 #>                       DMTA_0 l__M23 l__M27 l__M31 log_k1 log_k2 g_qlgs
@@ -410,10 +404,10 @@ specific pieces of information in the comments.
    
 #> 
 #> Random effects (omega):
 #>                           eta.DMTA_0 eta.log_k_M23 eta.log_k_M27 eta.log_k_M31
-#> eta.DMTA_0                     2.352        0.0000        0.0000        0.0000
+#> eta.DMTA_0                     2.327        0.0000        0.0000        0.0000
 #> eta.log_k_M23                  0.000        0.5493        0.0000        0.0000
-#> eta.log_k_M27                  0.000        0.0000        0.8645        0.0000
-#> eta.log_k_M31                  0.000        0.0000        0.0000        0.7503
+#> eta.log_k_M27                  0.000        0.0000        0.8552        0.0000
+#> eta.log_k_M31                  0.000        0.0000        0.0000        0.7457
 #> eta.log_k1                     0.000        0.0000        0.0000        0.0000
 #> eta.log_k2                     0.000        0.0000        0.0000        0.0000
 #> eta.g_qlogis                   0.000        0.0000        0.0000        0.0000
@@ -425,9 +419,9 @@ specific pieces of information in the comments.
    
 #> eta.log_k_M23                  0.000      0.000        0.000
 #> eta.log_k_M27                  0.000      0.000        0.000
 #> eta.log_k_M31                  0.000      0.000        0.000
-#> eta.log_k1                     0.903      0.000        0.000
+#> eta.log_k1                     0.901      0.000        0.000
 #> eta.log_k2                     0.000      1.577        0.000
-#> eta.g_qlogis                   0.000      0.000        3.085
+#> eta.g_qlogis                   0.000      0.000        3.102
 #> eta.f_DMTA_tffm0_1_qlogis      0.000      0.000        0.000
 #> eta.f_DMTA_tffm0_2_qlogis      0.000      0.000        0.000
 #> eta.f_DMTA_tffm0_3_qlogis      0.000      0.000        0.000
@@ -456,44 +450,44 @@ specific pieces of information in the comments.
    
 #> 
 #> Variance model:
 #> sigma_low  rsd_high 
-#>   0.69793   0.02577 
+#>   0.70012   0.02577 
 #> 
 #> Backtransformed parameters:
 #>                   est.    lower    upper
-#> DMTA_0        98.76976 98.73563 98.80390
+#> DMTA_0        98.71324 98.68012 98.74636
 #> k_M23          0.01981  0.01977  0.01985
-#> k_M27          0.01307  0.01304  0.01309
-#> k_M31          0.01430  0.01427  0.01433
-#> f_DMTA_to_M23  0.10984       NA       NA
-#> f_DMTA_to_M27  0.09036       NA       NA
-#> f_DMTA_to_M31  0.08399       NA       NA
-#> k1             0.10709  0.10696  0.10722
-#> k2             0.02291  0.02287  0.02295
-#> g              0.61068  0.61055  0.61081
+#> k_M27          0.01316  0.01313  0.01319
+#> k_M31          0.01435  0.01432  0.01438
+#> f_DMTA_to_M23  0.10993       NA       NA
+#> f_DMTA_to_M27  0.09049       NA       NA
+#> f_DMTA_to_M31  0.08414       NA       NA
+#> k1             0.10698  0.10685  0.10710
+#> k2             0.02292  0.02288  0.02296
+#> g              0.60738  0.60725  0.60751
 #> 
 #> Resulting formation fractions:
 #>                ff
-#> DMTA_M23  0.10984
-#> DMTA_M27  0.09036
-#> DMTA_M31  0.08399
-#> DMTA_sink 0.71581
+#> DMTA_M23  0.10993
+#> DMTA_M27  0.09049
+#> DMTA_M31  0.08414
+#> DMTA_sink 0.71543
 #> 
 #> Estimated disappearance times:
-#>       DT50   DT90 DT50back DT50_k1 DT50_k2
-#> DMTA 10.66  59.78       18   6.473   30.26
-#> M23  34.99 116.24       NA      NA      NA
-#> M27  53.05 176.23       NA      NA      NA
-#> M31  48.48 161.05       NA      NA      NA
    plot(f_dmta_nlmixr_focei)
+#>       DT50  DT90 DT50back DT50_k1 DT50_k2
+#> DMTA 10.72  60.1    18.09    6.48   30.24
+#> M23  34.99 116.2       NA      NA      NA
+#> M27  52.67 175.0       NA      NA      NA
+#> M31  48.31 160.5       NA      NA      NA
    plot(f_dmta_nlmixr_focei)
 
    # Using saemix takes about 18 minutes
 system.time(
   f_dmta_saemix <- saem(f_dmta_mkin_tc, test_log_parms = TRUE)
 )
 
    #> Running main SAEM algorithm
-#> [1] "Wed Aug  4 15:53:55 2021"
+#> [1] "Thu Sep 16 14:06:56 2021"
 #> ....
 #>     Minimisation finished
-#> [1] "Wed Aug  4 16:12:40 2021"
    #>     user   system  elapsed 
-#> 1192.021    0.064 1192.182 
    
+#> [1] "Thu Sep 16 14:25:28 2021"
    #>     user   system  elapsed 
+#> 1176.278    0.021 1176.388 
    
 # nlmixr with est = "saem" is pretty fast with default iteration numbers, most
 # of the time (about 2.5 minutes) is spent for calculating the log likelihood at the end
 # The likelihood calculated for the nlmixr fit is much lower than that found by saemix
@@ -504,15 +498,15 @@ specific pieces of information in the comments.
    
   f_dmta_nlmixr_saem <- nlmixr(f_dmta_mkin_tc, est = "saem",
     control = nlmixr::saemControl(print = 500, logLik = TRUE, nmc = 9))
 )
-
    #> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>  
    #> → generate SAEM model
    #> ✔ done
    #> 1:    98.3427   -3.5148   -3.3187   -3.7728   -2.1163   -2.8457    0.9482   -2.8064   -2.7412   -2.8745    2.7912    0.6805    0.8213    0.8055    0.8578    1.4980    2.9309    0.2850    0.2854    0.2850    4.0990    0.3821    3.5349    0.6537    5.4143    0.0002    4.5093    0.1905
-#> 500:    97.8277   -4.3506   -4.0318   -4.1520   -3.0553   -3.5843    1.1326   -2.0873   -2.0421   -2.0751    0.2960    1.2515    0.2531    0.3807    0.7928    0.8863    6.5211    0.1433    0.1082    0.3353    0.8960    0.0470    0.7501    0.0475    0.9527    0.0281    0.7321    0.0594
    #> Calculating covariance matrix
    #> 
    #> Calculating -2LL by Gaussian quadrature (nnodes=3,nsd=1.6)
    #> 
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → compiling EBE model...
    #>  
    #> ✔ done
    #> Needed Covariates:
    #> [1] "CMT"
    #> Calculating residuals/tables
    #> done
    #>    user  system elapsed 
-#> 813.299   3.736 151.935 
    traceplot(f_dmta_nlmixr_saem$nm)
+
    #> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>  
    #> → generate SAEM model
    #> ✔ done
    #> 1:    98.3400   -3.5096   -3.3392   -3.7596   -2.2055   -2.7755    1.0281   -2.7872   -2.7223   -2.8341    2.6422    0.7027    0.8124    0.7085    0.8560    1.4980    3.2777    0.3063    0.2850    0.2850    4.1120    0.3716    4.4582    0.3994    4.4820    0.4025    3.7803    0.5780
+#> 500:    97.8212   -4.4030   -4.0872   -4.1289   -2.8278   -4.3505    2.6614   -2.1252   -2.1308   -2.0749    2.9463    1.2933    0.2802    0.3467    0.4814    0.7877    3.0743    0.1508    0.1523    0.3155    0.9557    0.0333    0.4787    0.1073    0.6826    0.0707    0.7849    0.0356
    #> Calculating covariance matrix
    #> 
    #> Calculating -2LL by Gaussian quadrature (nnodes=3,nsd=1.6)
    #> 
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → compiling EBE model...
    #>  
    #> ✔ done
    #> Needed Covariates:
    #> [1] "CMT"
    #> Calculating residuals/tables
    #> done
    #>    user  system elapsed 
+#> 800.784   3.715 149.687 
    traceplot(f_dmta_nlmixr_saem$nm)
 
    #> Error in traceplot(f_dmta_nlmixr_saem$nm): could not find function "traceplot"
    summary(f_dmta_nlmixr_saem)
-
    #> nlmixr version used for fitting:    2.0.4 
-#> mkin version used for pre-fitting:  1.0.5 
-#> R version used for fitting:         4.1.0 
-#> Date of fit:     Wed Aug  4 16:16:18 2021 
-#> Date of summary: Wed Aug  4 16:16:18 2021 
+
    #> nlmixr version used for fitting:    2.0.5 
+#> mkin version used for pre-fitting:  1.1.0 
+#> R version used for fitting:         4.1.1 
+#> Date of fit:     Thu Sep 16 14:29:02 2021 
+#> Date of summary: Thu Sep 16 14:29:02 2021 
 #> 
 #> Equations:
 #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 *
@@ -529,25 +523,25 @@ specific pieces of information in the comments.
    
 #>            exp(-k2 * time))) * DMTA - k_M31 * M31
 #> 
 #> Data:
-#> 568 observations of 4 variable(s) grouped in 6 datasets
+#> 563 observations of 4 variable(s) grouped in 6 datasets
 #> 
 #> Degradation model predictions using RxODE
 #> 
-#> Fitted in 151.67 s
+#> Fitted in 149.421 s
 #> 
 #> Variance model: Two-component variance function 
 #> 
 #> Mean of starting values for individual parameters:
 #>       DMTA_0    log_k_M23    log_k_M27    log_k_M31 f_DMTA_ilr_1 f_DMTA_ilr_2 
-#>      98.7698      -3.9216      -4.3377      -4.2477       0.1380       0.1393 
+#>      98.7132      -3.9216      -4.3306      -4.2442       0.1376       0.1388 
 #> f_DMTA_ilr_3       log_k1       log_k2     g_qlogis 
-#>      -1.7571      -2.2341      -3.7763       0.4502 
+#>      -1.7554      -2.2352      -3.7758       0.4363 
 #> 
 #> Mean of starting values for error model parameters:
 #> sigma_low_DMTA  rsd_high_DMTA  sigma_low_M23   rsd_high_M23  sigma_low_M27 
-#>        0.69793        0.02577        0.69793        0.02577        0.69793 
+#>        0.70012        0.02577        0.70012        0.02577        0.70012 
 #>   rsd_high_M27  sigma_low_M31   rsd_high_M31 
-#>        0.02577        0.69793        0.02577 
+#>        0.02577        0.70012        0.02577 
 #> 
 #> Fixed degradation parameter values:
 #> None
@@ -556,32 +550,32 @@ specific pieces of information in the comments.
    
 #> 
 #> Likelihood calculated by focei  
 #>    AIC  BIC logLik
-#>   2036 2157 -989.8
+#>   1953 2074 -948.3
 #> 
 #> Optimised parameters:
 #>                         est.  lower  upper
-#> DMTA_0                97.828 96.121 99.535
-#> log_k_M23             -4.351 -5.300 -3.401
-#> log_k_M27             -4.032 -4.470 -3.594
-#> log_k_M31             -4.152 -4.689 -3.615
-#> log_k1                -3.055 -3.785 -2.325
-#> log_k2                -3.584 -4.517 -2.651
-#> g_qlogis               1.133 -2.165  4.430
-#> f_DMTA_tffm0_1_qlogis -2.087 -2.407 -1.768
-#> f_DMTA_tffm0_2_qlogis -2.042 -2.336 -1.748
-#> f_DMTA_tffm0_3_qlogis -2.075 -2.557 -1.593
+#> DMTA_0                97.821 95.862 99.780
+#> log_k_M23             -4.403 -5.376 -3.430
+#> log_k_M27             -4.087 -4.545 -3.629
+#> log_k_M31             -4.129 -4.639 -3.618
+#> log_k1                -2.828 -3.389 -2.266
+#> log_k2                -4.351 -5.472 -3.229
+#> g_qlogis               2.661  0.824  4.499
+#> f_DMTA_tffm0_1_qlogis -2.125 -2.449 -1.801
+#> f_DMTA_tffm0_2_qlogis -2.131 -2.468 -1.794
+#> f_DMTA_tffm0_3_qlogis -2.075 -2.540 -1.610
 #> 
 #> Correlation: 
 #>                       DMTA_0 l__M23 l__M27 l__M31 log_k1 log_k2 g_qlgs
-#> log_k_M23             -0.031                                          
-#> log_k_M27             -0.050  0.004                                   
-#> log_k_M31             -0.032  0.003  0.078                            
-#> log_k1                 0.014 -0.002 -0.002 -0.001                     
-#> log_k2                 0.059  0.006 -0.001  0.002 -0.037              
-#> g_qlogis              -0.077  0.005  0.009  0.004  0.035 -0.201       
-#> f_DMTA_tffm0_1_qlogis -0.104  0.066  0.009  0.006  0.000 -0.011  0.014
-#> f_DMTA_tffm0_2_qlogis -0.120  0.013  0.081 -0.033 -0.002 -0.013  0.017
-#> f_DMTA_tffm0_3_qlogis -0.086  0.010  0.060  0.078 -0.002 -0.005  0.010
+#> log_k_M23             -0.019                                          
+#> log_k_M27             -0.028  0.004                                   
+#> log_k_M31             -0.019  0.003  0.075                            
+#> log_k1                 0.038 -0.004 -0.006 -0.003                     
+#> log_k2                 0.046  0.011  0.008  0.009  0.068              
+#> g_qlogis              -0.067  0.004  0.006  0.001 -0.076 -0.409       
+#> f_DMTA_tffm0_1_qlogis -0.062  0.055  0.006  0.004 -0.008 -0.004  0.012
+#> f_DMTA_tffm0_2_qlogis -0.062  0.010  0.058 -0.034 -0.008 -0.007  0.014
+#> f_DMTA_tffm0_3_qlogis -0.052  0.009  0.056  0.071 -0.006 -0.001  0.008
 #>                       f_DMTA_0_1 f_DMTA_0_2
 #> log_k_M23                                  
 #> log_k_M27                                  
@@ -590,15 +584,15 @@ specific pieces of information in the comments.
    
 #> log_k2                                     
 #> g_qlogis                                   
 #> f_DMTA_tffm0_1_qlogis                      
-#> f_DMTA_tffm0_2_qlogis  0.026               
-#> f_DMTA_tffm0_3_qlogis  0.019      0.002    
+#> f_DMTA_tffm0_2_qlogis  0.017               
+#> f_DMTA_tffm0_3_qlogis  0.014     -0.005    
 #> 
 #> Random effects (omega):
 #>                           eta.DMTA_0 eta.log_k_M23 eta.log_k_M27 eta.log_k_M31
-#> eta.DMTA_0                     0.296         0.000        0.0000        0.0000
-#> eta.log_k_M23                  0.000         1.252        0.0000        0.0000
-#> eta.log_k_M27                  0.000         0.000        0.2531        0.0000
-#> eta.log_k_M31                  0.000         0.000        0.0000        0.3807
+#> eta.DMTA_0                     2.946         0.000        0.0000        0.0000
+#> eta.log_k_M23                  0.000         1.293        0.0000        0.0000
+#> eta.log_k_M27                  0.000         0.000        0.2802        0.0000
+#> eta.log_k_M31                  0.000         0.000        0.0000        0.3467
 #> eta.log_k1                     0.000         0.000        0.0000        0.0000
 #> eta.log_k2                     0.000         0.000        0.0000        0.0000
 #> eta.g_qlogis                   0.000         0.000        0.0000        0.0000
@@ -610,9 +604,9 @@ specific pieces of information in the comments.
    
 #> eta.log_k_M23                 0.0000     0.0000        0.000
 #> eta.log_k_M27                 0.0000     0.0000        0.000
 #> eta.log_k_M31                 0.0000     0.0000        0.000
-#> eta.log_k1                    0.7928     0.0000        0.000
-#> eta.log_k2                    0.0000     0.8863        0.000
-#> eta.g_qlogis                  0.0000     0.0000        6.521
+#> eta.log_k1                    0.4814     0.0000        0.000
+#> eta.log_k2                    0.0000     0.7877        0.000
+#> eta.g_qlogis                  0.0000     0.0000        3.074
 #> eta.f_DMTA_tffm0_1_qlogis     0.0000     0.0000        0.000
 #> eta.f_DMTA_tffm0_2_qlogis     0.0000     0.0000        0.000
 #> eta.f_DMTA_tffm0_3_qlogis     0.0000     0.0000        0.000
@@ -624,8 +618,8 @@ specific pieces of information in the comments.
    
 #> eta.log_k1                                   0.0000                    0.0000
 #> eta.log_k2                                   0.0000                    0.0000
 #> eta.g_qlogis                                 0.0000                    0.0000
-#> eta.f_DMTA_tffm0_1_qlogis                    0.1433                    0.0000
-#> eta.f_DMTA_tffm0_2_qlogis                    0.0000                    0.1082
+#> eta.f_DMTA_tffm0_1_qlogis                    0.1508                    0.0000
+#> eta.f_DMTA_tffm0_2_qlogis                    0.0000                    0.1523
 #> eta.f_DMTA_tffm0_3_qlogis                    0.0000                    0.0000
 #>                           eta.f_DMTA_tffm0_3_qlogis
 #> eta.DMTA_0                                   0.0000
@@ -637,40 +631,40 @@ specific pieces of information in the comments.
    
 #> eta.g_qlogis                                 0.0000
 #> eta.f_DMTA_tffm0_1_qlogis                    0.0000
 #> eta.f_DMTA_tffm0_2_qlogis                    0.0000
-#> eta.f_DMTA_tffm0_3_qlogis                    0.3353
+#> eta.f_DMTA_tffm0_3_qlogis                    0.3155
 #> 
 #> Variance model:
 #> sigma_low_DMTA  rsd_high_DMTA  sigma_low_M23   rsd_high_M23  sigma_low_M27 
-#>        0.89603        0.04704        0.75015        0.04753        0.95265 
+#>        0.95572        0.03325        0.47871        0.10733        0.68264 
 #>   rsd_high_M27  sigma_low_M31   rsd_high_M31 
-#>        0.02810        0.73212        0.05942 
+#>        0.07072        0.78486        0.03557 
 #> 
 #> Backtransformed parameters:
 #>                   est.     lower    upper
-#> DMTA_0        97.82774 96.120503 99.53498
-#> k_M23          0.01290  0.004991  0.03334
-#> k_M27          0.01774  0.011451  0.02749
-#> k_M31          0.01573  0.009195  0.02692
-#> f_DMTA_to_M23  0.11033        NA       NA
-#> f_DMTA_to_M27  0.10218        NA       NA
-#> f_DMTA_to_M31  0.08784        NA       NA
-#> k1             0.04711  0.022707  0.09773
-#> k2             0.02775  0.010918  0.07056
-#> g              0.75632  0.102960  0.98823
+#> DMTA_0        97.82122 95.862233 99.78020
+#> k_M23          0.01224  0.004625  0.03239
+#> k_M27          0.01679  0.010615  0.02654
+#> k_M31          0.01610  0.009664  0.02683
+#> f_DMTA_to_M23  0.10668        NA       NA
+#> f_DMTA_to_M27  0.09481        NA       NA
+#> f_DMTA_to_M31  0.08908        NA       NA
+#> k1             0.05914  0.033731  0.10370
+#> k2             0.01290  0.004204  0.03958
+#> g              0.93471  0.695081  0.98900
 #> 
 #> Resulting formation fractions:
 #>                ff
-#> DMTA_M23  0.11033
-#> DMTA_M27  0.10218
-#> DMTA_M31  0.08784
-#> DMTA_sink 0.69965
+#> DMTA_M23  0.10668
+#> DMTA_M27  0.09481
+#> DMTA_M31  0.08908
+#> DMTA_sink 0.70943
 #> 
 #> Estimated disappearance times:
 #>       DT50   DT90 DT50back DT50_k1 DT50_k2
-#> DMTA 16.59  57.44    17.29   14.71   24.97
-#> M23  53.74 178.51       NA      NA      NA
-#> M27  39.07 129.78       NA      NA      NA
-#> M31  44.06 146.36       NA      NA      NA
    plot(f_dmta_nlmixr_saem)
+#> DMTA 12.57  45.43    13.67   11.72   53.73
+#> M23  56.63 188.11       NA      NA      NA
+#> M27  41.29 137.18       NA      NA      NA
+#> M31  43.05 143.01       NA      NA      NA
    plot(f_dmta_nlmixr_saem)
 
    # }
    diff --git a/docs/dev/reference/endpoints.html b/docs/dev/reference/endpoints.html index dc1d1f17..aa5bd773 100644 --- a/docs/dev/reference/endpoints.html +++ b/docs/dev/reference/endpoints.html @@ -78,7 +78,7 @@ advantage that the SFORB model can also be used for metabolites." /> mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/reference/index.html b/docs/dev/reference/index.html index bb030605..d5ec387a 100644 --- a/docs/dev/reference/index.html +++ b/docs/dev/reference/index.html @@ -71,7 +71,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/reference/mean_degparms.html b/docs/dev/reference/mean_degparms.html index f63dbc31..5981c625 100644 --- a/docs/dev/reference/mean_degparms.html +++ b/docs/dev/reference/mean_degparms.html @@ -72,7 +72,7 @@ mkin - 1.0.5 + 1.1.0 diff --git a/docs/dev/reference/mkinmod.html b/docs/dev/reference/mkinmod.html index ac7c2daa..6478cda4 100644 --- a/docs/dev/reference/mkinmod.html +++ b/docs/dev/reference/mkinmod.html @@ -76,7 +76,7 @@ components." /> mkin - 1.0.5 + 1.1.0 @@ -344,7 +344,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media

    parent = mkinsub("SFO", "m1", full_name = "Test compound"), m1 = mkinsub("SFO", full_name = "Metabolite M1"), name = "SFO_SFO", dll_dir = DLL_dir, unload = TRUE, overwrite = TRUE) -
    #> Copied DLL from /tmp/RtmpKZJMFk/file179ba717d15c81.so to /home/jranke/.local/share/mkin/SFO_SFO.so
    # Now we can save the model and restore it in a new session +
    #> Copied DLL from /tmp/RtmpTzKqT5/file7993c266a7f90.so to /home/jranke/.local/share/mkin/SFO_SFO.so
    # Now we can save the model and restore it in a new session saveRDS(SFO_SFO.2, file = "~/SFO_SFO.rds") # Terminate the R session here if you would like to check, and then do library(mkin) @@ -393,7 +393,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media

    #> }) #> return(predicted) #> } -#> <environment: 0x555559c54f78>
    +#> <environment: 0x555559365690>
    # If we have several parallel metabolites # (compare tests/testthat/test_synthetic_data_for_UBA_2014.R) m_synth_DFOP_par <- mkinmod( diff --git a/docs/dev/reference/nlme-1.png b/docs/dev/reference/nlme-1.png index 365aaef0..e4bc2fde 100644 Binary files a/docs/dev/reference/nlme-1.png and b/docs/dev/reference/nlme-1.png differ diff --git a/docs/dev/reference/nlme-2.png b/docs/dev/reference/nlme-2.png index 40841404..31910ce4 100644 Binary files a/docs/dev/reference/nlme-2.png and b/docs/dev/reference/nlme-2.png differ diff --git a/docs/dev/reference/nlme.html b/docs/dev/reference/nlme.html index 55a94443..500ac391 100644 --- a/docs/dev/reference/nlme.html +++ b/docs/dev/reference/nlme.html @@ -75,7 +75,7 @@ datasets. They are used internally by the nlme.mmkin() method." /> mkin - 1.0.5 + 1.1.0
    @@ -216,28 +216,28 @@ datasets. They are used internally by the nlme.m #> Model: value ~ nlme_f(name, time, parent_0, log_k_parent_sink) #> Data: grouped_data #> AIC BIC logLik -#> 300.6824 310.2426 -145.3412 +#> 289.8295 299.4886 -139.9148 #> #> Random effects: #> Formula: list(parent_0 ~ 1, log_k_parent_sink ~ 1) #> Level: ds #> Structure: Diagonal #> parent_0 log_k_parent_sink Residual -#> StdDev: 1.697361 0.6801209 3.666073 +#> StdDev: 1.839278 0.6988919 3.059894 #> #> Fixed effects: parent_0 + log_k_parent_sink ~ 1 #> Value Std.Error DF t-value p-value -#> parent_0 100.99378 1.3890416 46 72.70753 0 -#> log_k_parent_sink -3.07521 0.4018589 46 -7.65246 0 +#> parent_0 100.52780 1.3507449 47 74.42397 0 +#> log_k_parent_sink -3.08477 0.4124053 47 -7.47995 0 #> Correlation: #> prnt_0 -#> log_k_parent_sink 0.027 +#> log_k_parent_sink 0.019 #> #> Standardized Within-Group Residuals: -#> Min Q1 Med Q3 Max -#> -1.9942823 -0.5622565 0.1791579 0.7165038 2.0704781 +#> Min Q1 Med Q3 Max +#> -2.22350411 -0.51546184 0.04803417 0.55987705 3.49178405 #> -#> Number of Observations: 50 +#> Number of Observations: 51 #> Number of Groups: 3
    plot(augPred(m_nlme, level = 0:1), layout = c(3, 1))
    # augPred does not work on fits with more than one state # variable diff --git a/docs/dev/reference/nlme.mmkin.html b/docs/dev/reference/nlme.mmkin.html index db863392..866091ca 100644 --- a/docs/dev/reference/nlme.mmkin.html +++ b/docs/dev/reference/nlme.mmkin.html @@ -74,7 +74,7 @@ have been obtained by fitting the same model to a list of datasets." /> mkin - 1.0.5 + 1.1.0
    diff --git a/docs/dev/reference/nlmixr.mmkin.html b/docs/dev/reference/nlmixr.mmkin.html index 99a7ad14..db114483 100644 --- a/docs/dev/reference/nlmixr.mmkin.html +++ b/docs/dev/reference/nlmixr.mmkin.html @@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." /> mkin - 1.0.5 + 1.1.0 @@ -4416,7 +4416,8 @@ obtained by fitting the same model to a list of datasets using 288.66432 | 94.40 | 0.8038 | 7.793 | 2.283 | #> |.....................| 5.960e-07 | 0.6941 | 1.222 | 1.493 | -#> done
    #> Calculating residuals/tables
    #> done
    #> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
    #> Warning: ETAs were reset to zero during optimization; (Can control by foceiControl(resetEtaP=.))
    #> Warning: last objective function was not at minimum, possible problems in optimization
    #> Warning: parameter estimate near boundary; covariance not calculated +#> done
    #> Calculating residuals/tables
    #> done
    #> Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))
    #> Warning: ETAs were reset to zero during optimization; (Can control by foceiControl(resetEtaP=.))
    #> Warning: last objective function was not at minimum, possible problems in optimization
    #> Warning: parameter estimate near boundary; covariance not calculated: +#> "rsd_high" #> use 'getVarCov' to calculate anyway
    #> Warning: gradient problems with initial estimate; see $scaleInfo
    AIC( f_nlmixr_sfo_saem$nm, f_nlmixr_sfo_focei$nm, @@ -4501,7 +4502,7 @@ obtained by fitting the same model to a list of datasets using k_A1=rx_expr_11; #> f_parent=1/(1+exp(-(ETA[4]+THETA[4]))); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 5.723 0.414 6.136
    f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei") +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 5.579 0.328 5.909
    f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4550,7 +4551,7 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 6.874 0.399 7.27
    f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei") +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 7.125 0.34 7.462
    f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4607,10 +4608,10 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_20); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 14.83 0.382 15.21
    +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 15.03 0.407 15.43
    # Variance by variable is supported by 'saem' and 'focei' f_nlmixr_fomc_sfo_saem_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "saem") -
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> → generate SAEM model
    #> ✔ done
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 1.22 0.146 1.365
    f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei") +
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> → generate SAEM model
    #> ✔ done
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 1.253 0.121 1.373
    f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4659,8 +4660,8 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 6.6 0.416 7.016
    f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem") -
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> → generate SAEM model
    #> ✔ done
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 1.551 0.126 1.673
    f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei") +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 6.487 0.387 6.872
    f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem") +
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> → generate SAEM model
    #> ✔ done
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 1.385 0.1 1.485
    f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4717,7 +4718,7 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_19); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 15.24 0.429 15.67
    +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 15.06 0.434 15.49
    # Identical two-component error for all variables is only possible with # est = 'focei' in nlmixr f_nlmixr_fomc_sfo_focei_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei") @@ -4771,7 +4772,7 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 8.644 0.416 9.058
    f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei") +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 8.599 0.38 8.975
    f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); #> rx_expr_6~ETA[1]+THETA[1]; @@ -4830,12 +4831,12 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_21); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 18.76 0.426 19.18
    +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 17.64 0.453 18.09
    # Two-component error by variable is possible with both estimation methods # Variance by variable is supported by 'saem' and 'focei' f_nlmixr_fomc_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "saem", error_model = "obs_tc") -
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 0.757 0.072 0.829
    f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei", +
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 0.772 0.04 0.813
    f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei", error_model = "obs_tc")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); @@ -4887,9 +4888,9 @@ obtained by fitting the same model to a list of datasets using beta=exp(rx_expr_8); #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 8.417 0.388 8.803
    f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem", +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 8.33 0.419 8.745
    f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem", error_model = "obs_tc") -
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 0.82 0.035 0.857
    f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei", +
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_A1
    #> Timing stopped at: 0.832 0.032 0.866
    f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei", error_model = "obs_tc")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(A1); @@ -4949,7 +4950,7 @@ obtained by fitting the same model to a list of datasets using f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_19); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 17.61 0.452 18.06
    +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_A1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 18.15 0.42 18.57
    AIC( f_nlmixr_sfo_sfo_focei_const$nm, f_nlmixr_fomc_sfo_focei_const$nm, diff --git a/docs/dev/reference/plot.mixed.mmkin.html b/docs/dev/reference/plot.mixed.mmkin.html index 746a8640..9f0eb965 100644 --- a/docs/dev/reference/plot.mixed.mmkin.html +++ b/docs/dev/reference/plot.mixed.mmkin.html @@ -72,7 +72,7 @@ mkin - 1.0.5 + 1.1.0
    @@ -296,10 +296,10 @@ corresponding model prediction lines for the different datasets.

    f_saem <- saem(f, transformations = "saemix")
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:21:52 2021" +#> [1] "Thu Sep 16 14:34:31 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:00 2021"
    plot(f_saem) +#> [1] "Thu Sep 16 14:34:38 2021"
    plot(f_saem)
    f_obs <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE, error_model = "obs") f_nlmix <- nlmix(f_obs) diff --git a/docs/dev/reference/reexports.html b/docs/dev/reference/reexports.html index f5ace044..ac4fa4d9 100644 --- a/docs/dev/reference/reexports.html +++ b/docs/dev/reference/reexports.html @@ -81,7 +81,7 @@ below to see their documentation. mkin - 1.0.5 + 1.1.0
    diff --git a/docs/dev/reference/saem.html b/docs/dev/reference/saem.html index 620173b2..8d986126 100644 --- a/docs/dev/reference/saem.html +++ b/docs/dev/reference/saem.html @@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." /> mkin - 1.0.5 + 1.1.0 @@ -288,27 +288,27 @@ using mmkin.

    state.ini = c(parent = 100), fixed_initials = "parent", quiet = TRUE) f_saem_p0_fixed <- saem(f_mmkin_parent_p0_fixed)
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:05 2021" +#> [1] "Thu Sep 16 14:34:42 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:06 2021"
    +#> [1] "Thu Sep 16 14:34:43 2021"
    f_mmkin_parent <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE) f_saem_sfo <- saem(f_mmkin_parent["SFO", ])
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:08 2021" +#> [1] "Thu Sep 16 14:34:45 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:10 2021"
    f_saem_fomc <- saem(f_mmkin_parent["FOMC", ]) +#> [1] "Thu Sep 16 14:34:47 2021"
    f_saem_fomc <- saem(f_mmkin_parent["FOMC", ])
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:10 2021" +#> [1] "Thu Sep 16 14:34:47 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:12 2021"
    f_saem_dfop <- saem(f_mmkin_parent["DFOP", ]) +#> [1] "Thu Sep 16 14:34:49 2021"
    f_saem_dfop <- saem(f_mmkin_parent["DFOP", ])
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:12 2021" +#> [1] "Thu Sep 16 14:34:49 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:16 2021"
    +#> [1] "Thu Sep 16 14:34:52 2021"
    # The returned saem.mmkin object contains an SaemixObject, therefore we can use # functions from saemix library(saemix) @@ -357,10 +357,10 @@ using mmkin.

    f_mmkin_parent_tc <- update(f_mmkin_parent, error_model = "tc") f_saem_fomc_tc <- saem(f_mmkin_parent_tc["FOMC", ])
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:19 2021" +#> [1] "Thu Sep 16 14:34:55 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:24 2021"
    compare.saemix(f_saem_fomc$so, f_saem_fomc_tc$so) +#> [1] "Thu Sep 16 14:35:00 2021"
    compare.saemix(f_saem_fomc$so, f_saem_fomc_tc$so)
    #> Likelihoods calculated by importance sampling
    #> AIC BIC #> 1 467.7096 464.9757 #> 2 469.6831 466.5586
    @@ -381,15 +381,15 @@ using mmkin.

    # four minutes f_saem_sfo_sfo <- saem(f_mmkin["SFO-SFO", ])
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:27 2021" +#> [1] "Thu Sep 16 14:35:03 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:32 2021"
    f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ]) +#> [1] "Thu Sep 16 14:35:08 2021"
    f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ])
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:33 2021" +#> [1] "Thu Sep 16 14:35:08 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:42 2021"
    # We can use print, plot and summary methods to check the results +#> [1] "Thu Sep 16 14:35:17 2021"
    # We can use print, plot and summary methods to check the results print(f_saem_dfop_sfo)
    #> Kinetic nonlinear mixed-effects model fit by SAEM #> Structural model: @@ -430,10 +430,10 @@ using mmkin.

    #> SD.g_qlogis 0.44816 -1.25437 2.1507
    plot(f_saem_dfop_sfo)
    summary(f_saem_dfop_sfo, data = TRUE)
    #> saemix version used for fitting: 3.1.9000 -#> mkin version used for pre-fitting: 1.0.5 -#> R version used for fitting: 4.1.0 -#> Date of fit: Wed Aug 4 16:22:43 2021 -#> Date of summary: Wed Aug 4 16:22:43 2021 +#> mkin version used for pre-fitting: 1.1.0 +#> R version used for fitting: 4.1.1 +#> Date of fit: Thu Sep 16 14:35:18 2021 +#> Date of summary: Thu Sep 16 14:35:18 2021 #> #> Equations: #> d_parent/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -448,7 +448,7 @@ using mmkin.

    #> #> Model predictions using solution type analytical #> -#> Fitted in 10.143 s using 300, 100 iterations +#> Fitted in 9.349 s using 300, 100 iterations #> #> Variance model: Constant variance #> diff --git a/docs/dev/reference/summary.nlmixr.mmkin.html b/docs/dev/reference/summary.nlmixr.mmkin.html index 70a71683..4831bbdf 100644 --- a/docs/dev/reference/summary.nlmixr.mmkin.html +++ b/docs/dev/reference/summary.nlmixr.mmkin.html @@ -76,7 +76,7 @@ endpoints such as formation fractions and DT50 values. Optionally mkin - 1.0.5 + 1.1.0
    @@ -258,12 +258,12 @@ nlmixr authors for the parts inherited from nlmixr.

    quiet = TRUE, error_model = "tc", cores = 5) f_saemix_dfop_sfo <- mkin::saem(f_mmkin_dfop_sfo)
    #> Running main SAEM algorithm -#> [1] "Wed Aug 4 16:22:46 2021" +#> [1] "Thu Sep 16 14:35:21 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:59 2021"
    f_nlme_dfop_sfo <- mkin::nlme(f_mmkin_dfop_sfo) +#> [1] "Thu Sep 16 14:35:33 2021"
    f_nlme_dfop_sfo <- mkin::nlme(f_mmkin_dfop_sfo)
    #> Warning: Iteration 4, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)
    #> Warning: Iteration 6, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)
    f_nlmixr_dfop_sfo_saem <- nlmixr(f_mmkin_dfop_sfo, est = "saem") -
    #> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> → generate SAEM model
    #> ✔ done
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_m1
    #> Timing stopped at: 1.383 0.12 1.503
    # The following takes a very long time but gives +
    #> With est = 'saem', a different error model is required for each observed variableChanging the error model to 'obs_tc' (Two-component error for each observed variable)
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #>
    #> → generate SAEM model
    #> ✔ done
    #> Error in configsaem(model = model, data = dat, inits = inits, mcmc = .mcmc, ODEopt = .ODEopt, seed = .seed, distribution = .dist, DEBUG = .DEBUG, addProp = .addProp, tol = .tol, itmax = .itmax, type = .type, powRange = .powRange, lambdaRange = .lambdaRange): covariate(s) not found: f_parent_to_m1
    #> Timing stopped at: 1.412 0.101 1.525
    # The following takes a very long time but gives f_nlmixr_dfop_sfo_focei <- nlmixr(f_mmkin_dfop_sfo, est = "focei")
    #> ℹ parameter labels from comments are typically ignored in non-interactive mode
    #> ℹ Need to run with the source intact to parse comments
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → creating full model...
    #> → pruning branches (`if`/`else`)...
    #> ✔ done
    #> → loading into symengine environment...
    #> ✔ done
    #> → calculate jacobian
    #>
    #> → calculate sensitivities
    #>
    #> → calculate ∂(f)/∂(η)
    #>
    #> → calculate ∂(R²)/∂(η)
    #>
    #> → finding duplicate expressions in inner model...
    #>
    #> → optimizing duplicate expressions in inner model...
    #>
    #> → finding duplicate expressions in EBE model...
    #>
    #> → optimizing duplicate expressions in EBE model...
    #>
    #> → compiling inner model...
    #>
    #> ✔ done
    #> → finding duplicate expressions in FD model...
    #>
    #> → optimizing duplicate expressions in FD model...
    #>
    #> → compiling EBE model...
    #>
    #> ✔ done
    #> → compiling events FD model...
    #>
    #> ✔ done
    #> Model:
    #> cmt(parent); #> cmt(m1); @@ -323,7 +323,7 @@ nlmixr authors for the parts inherited from nlmixr.

    #> f_parent=1/(1+exp(-(ETA[3]+THETA[3]))); #> g=1/(rx_expr_21); #> tad=tad(); -#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_m1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 18.43 0.422 18.87
    AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm) +#> dosenum=dosenum();
    #> Needed Covariates:
    #> [1] "f_parent_to_m1" "CMT"
    #> Error in (function (data, inits, PKpars, model = NULL, pred = NULL, err = NULL, lower = -Inf, upper = Inf, fixed = NULL, skipCov = NULL, control = foceiControl(), thetaNames = NULL, etaNames = NULL, etaMat = NULL, ..., env = NULL, keep = NULL, drop = NULL) { set.seed(control$seed) .pt <- proc.time() RxODE::.setWarnIdSort(FALSE) on.exit(RxODE::.setWarnIdSort(TRUE)) loadNamespace("n1qn1") if (!RxODE::rxIs(control, "foceiControl")) { control <- do.call(foceiControl, control) } if (is.null(env)) { .ret <- new.env(parent = emptyenv()) } else { .ret <- env } .ret$origData <- data .ret$etaNames <- etaNames .ret$thetaFixed <- fixed .ret$control <- control .ret$control$focei.mu.ref <- integer(0) if (is(model, "RxODE") || is(model, "character")) { .ret$ODEmodel <- TRUE if (class(pred) != "function") { stop("pred must be a function specifying the prediction variables in this model.") } } else { .ret$ODEmodel <- TRUE model <- RxODE::rxGetLin(PKpars) pred <- eval(parse(text = "function(){return(Central);}")) } .square <- function(x) x * x .ret$diagXformInv <- c(sqrt = ".square", log = "exp", identity = "identity")[control$diagXform] if (is.null(err)) { err <- eval(parse(text = paste0("function(){err", paste(inits$ERROR[[1]], collapse = ""), "}"))) } .covNames <- .parNames <- c() .ret$adjLik <- control$adjLik .mixed <- !is.null(inits$OMGA) && length(inits$OMGA) > 0 if (!exists("noLik", envir = .ret)) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ssAtol <- rep(control$ssAtol, length(RxODE::rxModelVars(model)$state)) .ssRtol <- rep(control$ssRtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = (control$derivMethod == 2L), pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, interaction = (control$interaction == 1L), only.numeric = !.mixed, run.internal = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol .ssAtol <- c(.ssAtol, rep(control$ssAtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssAtol))) .ssRtol <- c(.ssRtol, rep(control$ssRtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.ssRtol))) .ret$control$rxControl$ssAtol <- .ssAtol .ret$control$rxControl$ssRtol <- .ssRtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { if (.ret$noLik) { .atol <- rep(control$atol, length(RxODE::rxModelVars(model)$state)) .rtol <- rep(control$rtol, length(RxODE::rxModelVars(model)$state)) .ret$model <- RxODE::rxSymPySetupPred(model, pred, PKpars, err, grad = FALSE, pred.minus.dv = TRUE, sum.prod = control$sumProd, theta.derivs = FALSE, optExpression = control$optExpression, run.internal = TRUE, only.numeric = TRUE, addProp = control$addProp) if (!is.null(.ret$model$inner)) { .atol <- c(.atol, rep(control$atolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.atol))) .rtol <- c(.rtol, rep(control$rtolSens, length(RxODE::rxModelVars(.ret$model$inner)$state) - length(.rtol))) .ret$control$rxControl$atol <- .atol .ret$control$rxControl$rtol <- .rtol } .covNames <- .parNames <- RxODE::rxParams(.ret$model$pred.only) .covNames <- .covNames[regexpr(rex::rex(start, or("THETA", "ETA"), "[", numbers, "]", end), .covNames) == -1] colnames(data) <- sapply(names(data), function(x) { if (any(x == .covNames)) { return(x) } else { return(toupper(x)) } }) .lhs <- c(names(RxODE::rxInits(.ret$model$pred.only)), RxODE::rxLhs(.ret$model$pred.only)) if (length(.lhs) > 0) { .covNames <- .covNames[regexpr(rex::rex(start, or(.lhs), end), .covNames) == -1] } if (length(.covNames) > 0) { if (!all(.covNames %in% names(data))) { message("Model:") RxODE::rxCat(.ret$model$pred.only) message("Needed Covariates:") nlmixrPrint(.covNames) stop("Not all the covariates are in the dataset.") } message("Needed Covariates:") print(.covNames) } .extraPars <- .ret$model$extra.pars } else { .extraPars <- NULL } } .ret$skipCov <- skipCov if (is.null(skipCov)) { if (is.null(fixed)) { .tmp <- rep(FALSE, length(inits$THTA)) } else { if (length(fixed) < length(inits$THTA)) { .tmp <- c(fixed, rep(FALSE, length(inits$THTA) - length(fixed))) } else { .tmp <- fixed[1:length(inits$THTA)] } } if (exists("uif", envir = .ret)) { .uifErr <- .ret$uif$ini$err[!is.na(.ret$uif$ini$ntheta)] .uifErr <- sapply(.uifErr, function(x) { if (is.na(x)) { return(FALSE) } return(!any(x == c("pow2", "tbs", "tbsYj"))) }) .tmp <- (.tmp | .uifErr) } .ret$skipCov <- c(.tmp, rep(TRUE, length(.extraPars))) .ret$control$focei.mu.ref <- .ret$uif$focei.mu.ref } if (is.null(.extraPars)) { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA))) } else { .nms <- c(sprintf("THETA[%s]", seq_along(inits$THTA)), sprintf("ERR[%s]", seq_along(.extraPars))) } if (!is.null(thetaNames) && (length(inits$THTA) + length(.extraPars)) == length(thetaNames)) { .nms <- thetaNames } .ret$thetaNames <- .nms .thetaReset$thetaNames <- .nms if (length(lower) == 1) { lower <- rep(lower, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { print(inits$THTA) print(lower) stop("Lower must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (length(upper) == 1) { upper <- rep(upper, length(inits$THTA)) } else if (length(lower) != length(inits$THTA)) { stop("Upper must be a single constant for all the THETA lower bounds, or match the dimension of THETA.") } if (!is.null(.extraPars)) { .ret$model$extra.pars <- eval(call(control$diagXform, .ret$model$extra.pars)) if (length(.ret$model$extra.pars) > 0) { inits$THTA <- c(inits$THTA, .ret$model$extra.pars) .lowerErr <- rep(control$atol[1] * 10, length(.ret$model$extra.pars)) .upperErr <- rep(Inf, length(.ret$model$extra.pars)) lower <- c(lower, .lowerErr) upper <- c(upper, .upperErr) } } if (is.null(data$ID)) stop("\"ID\" not found in data") if (is.null(data$DV)) stop("\"DV\" not found in data") if (is.null(data$EVID)) data$EVID <- 0 if (is.null(data$AMT)) data$AMT <- 0 for (.v in c("TIME", "AMT", "DV", .covNames)) { data[[.v]] <- as.double(data[[.v]]) } .ret$dataSav <- data .ds <- data[data$EVID != 0 & data$EVID != 2, c("ID", "TIME", "AMT", "EVID", .covNames)] .w <- which(tolower(names(data)) == "limit") .limitName <- NULL if (length(.w) == 1L) { .limitName <- names(data)[.w] } .censName <- NULL .w <- which(tolower(names(data)) == "cens") if (length(.w) == 1L) { .censName <- names(data[.w]) } data <- data[data$EVID == 0 | data$EVID == 2, c("ID", "TIME", "DV", "EVID", .covNames, .limitName, .censName)] .w <- which(!(names(.ret$dataSav) %in% c(.covNames, keep))) names(.ret$dataSav)[.w] <- tolower(names(.ret$dataSav[.w])) if (.mixed) { .lh <- .parseOM(inits$OMGA) .nlh <- sapply(.lh, length) .osplt <- rep(1:length(.lh), .nlh) .lini <- list(inits$THTA, unlist(.lh)) .nlini <- sapply(.lini, length) .nsplt <- rep(1:length(.lini), .nlini) .om0 <- .genOM(.lh) if (length(etaNames) == dim(.om0)[1]) { .ret$etaNames <- .ret$etaNames } else { .ret$etaNames <- sprintf("ETA[%d]", seq(1, dim(.om0)[1])) } .ret$rxInv <- RxODE::rxSymInvCholCreate(mat = .om0, diag.xform = control$diagXform) .ret$xType <- .ret$rxInv$xType .om0a <- .om0 .om0a <- .om0a/control$diagOmegaBoundLower .om0b <- .om0 .om0b <- .om0b * control$diagOmegaBoundUpper .om0a <- RxODE::rxSymInvCholCreate(mat = .om0a, diag.xform = control$diagXform) .om0b <- RxODE::rxSymInvCholCreate(mat = .om0b, diag.xform = control$diagXform) .omdf <- data.frame(a = .om0a$theta, m = .ret$rxInv$theta, b = .om0b$theta, diag = .om0a$theta.diag) .omdf$lower <- with(.omdf, ifelse(a > b, b, a)) .omdf$lower <- with(.omdf, ifelse(lower == m, -Inf, lower)) .omdf$lower <- with(.omdf, ifelse(!diag, -Inf, lower)) .omdf$upper <- with(.omdf, ifelse(a < b, b, a)) .omdf$upper <- with(.omdf, ifelse(upper == m, Inf, upper)) .omdf$upper <- with(.omdf, ifelse(!diag, Inf, upper)) .ret$control$nomega <- length(.omdf$lower) .ret$control$neta <- sum(.omdf$diag) .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) lower <- c(lower, .omdf$lower) upper <- c(upper, .omdf$upper) } else { .ret$control$nomega <- 0 .ret$control$neta <- 0 .ret$xType <- -1 .ret$control$ntheta <- length(lower) .ret$control$nfixed <- sum(fixed) } .ret$lower <- lower .ret$upper <- upper .ret$thetaIni <- inits$THTA .scaleC <- double(length(lower)) if (is.null(control$scaleC)) { .scaleC <- rep(NA_real_, length(lower)) } else { .scaleC <- as.double(control$scaleC) if (length(lower) > length(.scaleC)) { .scaleC <- c(.scaleC, rep(NA_real_, length(lower) - length(.scaleC))) } else if (length(lower) < length(.scaleC)) { .scaleC <- .scaleC[seq(1, length(lower))] warning("scaleC control option has more options than estimated population parameters, please check.") } } .ret$scaleC <- .scaleC if (exists("uif", envir = .ret)) { .ini <- as.data.frame(.ret$uif$ini)[!is.na(.ret$uif$ini$err), c("est", "err", "ntheta")] for (.i in seq_along(.ini$err)) { if (is.na(.ret$scaleC[.ini$ntheta[.i]])) { if (any(.ini$err[.i] == c("boxCox", "yeoJohnson", "pow2", "tbs", "tbsYj"))) { .ret$scaleC[.ini$ntheta[.i]] <- 1 } else if (any(.ini$err[.i] == c("prop", "add", "norm", "dnorm", "logn", "dlogn", "lnorm", "dlnorm"))) { .ret$scaleC[.ini$ntheta[.i]] <- 0.5 * abs(.ini$est[.i]) } } } for (.i in .ini$model$extraProps$powTheta) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- 1 } .ini <- as.data.frame(.ret$uif$ini) for (.i in .ini$model$extraProps$factorial) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i] + 1)) } for (.i in .ini$model$extraProps$gamma) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- abs(1/digamma(.ini$est[.i])) } for (.i in .ini$model$extraProps$log) { if (is.na(.ret$scaleC[.i])) .ret$scaleC[.i] <- log(abs(.ini$est[.i])) * abs(.ini$est[.i]) } for (.i in .ret$logitThetas) { .b <- .ret$logitThetasLow[.i] .c <- .ret$logitThetasHi[.i] .a <- .ini$est[.i] if (is.na(.ret$scaleC[.i])) { .ret$scaleC[.i] <- 1 * (-.b + .c) * exp(-.a)/((1 + exp(-.a))^2 * (.b + 1 * (-.b + .c)/(1 + exp(-.a)))) } } } names(.ret$thetaIni) <- sprintf("THETA[%d]", seq_along(.ret$thetaIni)) if (is.null(etaMat) & !is.null(control$etaMat)) { .ret$etaMat <- control$etaMat } else { .ret$etaMat <- etaMat } .ret$setupTime <- (proc.time() - .pt)["elapsed"] if (exists("uif", envir = .ret)) { .tmp <- .ret$uif$logThetasList .ret$logThetas <- .tmp[[1]] .ret$logThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasList .ret$logitThetas <- .tmp[[1]] .ret$logitThetasF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListLow .ret$logitThetasLow <- .tmp[[1]] .ret$logitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$logitThetasListHi .ret$logitThetasHi <- .tmp[[1]] .ret$logitThetasHiF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasList .ret$probitThetas <- .tmp[[1]] .ret$probitThetasF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListLow .ret$probitThetasLow <- .tmp[[1]] .ret$probitThetasLowF <- .tmp[[2]] .tmp <- .ret$uif$probitThetasListHi .ret$probitThetasHi <- .tmp[[1]] .ret$probitThetasHiF <- .tmp[[2]] } else { .ret$logThetasF <- integer(0) .ret$logitThetasF <- integer(0) .ret$logitThetasHiF <- numeric(0) .ret$logitThetasLowF <- numeric(0) .ret$logitThetas <- integer(0) .ret$logitThetasHi <- numeric(0) .ret$logitThetasLow <- numeric(0) .ret$probitThetasF <- integer(0) .ret$probitThetasHiF <- numeric(0) .ret$probitThetasLowF <- numeric(0) .ret$probitThetas <- integer(0) .ret$probitThetasHi <- numeric(0) .ret$probitThetasLow <- numeric(0) } if (exists("noLik", envir = .ret)) { if (!.ret$noLik) { .ret$.params <- c(sprintf("THETA[%d]", seq_along(.ret$thetaIni)), sprintf("ETA[%d]", seq(1, dim(.om0)[1]))) .ret$.thetan <- length(.ret$thetaIni) .ret$nobs <- sum(data$EVID == 0) } } .ret$control$printTop <- TRUE .ret$control$nF <- 0 .est0 <- .ret$thetaIni if (!is.null(.ret$model$pred.nolhs)) { .ret$control$predNeq <- length(.ret$model$pred.nolhs$state) } else { .ret$control$predNeq <- 0L } .fitFun <- function(.ret) { this.env <- environment() assign("err", "theta reset", this.env) while (this.env$err == "theta reset") { assign("err", "", this.env) .ret0 <- tryCatch({ foceiFitCpp_(.ret) }, error = function(e) { if (regexpr("theta reset", e$message) != -1) { assign("zeroOuter", FALSE, this.env) assign("zeroGrad", FALSE, this.env) if (regexpr("theta reset0", e$message) != -1) { assign("zeroGrad", TRUE, this.env) } else if (regexpr("theta resetZ", e$message) != -1) { assign("zeroOuter", TRUE, this.env) } assign("err", "theta reset", this.env) } else { assign("err", e$message, this.env) } }) if (this.env$err == "theta reset") { .nm <- names(.ret$thetaIni) .ret$thetaIni <- setNames(.thetaReset$thetaIni + 0, .nm) .ret$rxInv$theta <- .thetaReset$omegaTheta .ret$control$printTop <- FALSE .ret$etaMat <- .thetaReset$etaMat .ret$control$etaMat <- .thetaReset$etaMat .ret$control$maxInnerIterations <- .thetaReset$maxInnerIterations .ret$control$nF <- .thetaReset$nF .ret$control$gillRetC <- .thetaReset$gillRetC .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillRet <- .thetaReset$gillRet .ret$control$gillDf <- .thetaReset$gillDf .ret$control$gillDf2 <- .thetaReset$gillDf2 .ret$control$gillErr <- .thetaReset$gillErr .ret$control$rEps <- .thetaReset$rEps .ret$control$aEps <- .thetaReset$aEps .ret$control$rEpsC <- .thetaReset$rEpsC .ret$control$aEpsC <- .thetaReset$aEpsC .ret$control$c1 <- .thetaReset$c1 .ret$control$c2 <- .thetaReset$c2 if (this.env$zeroOuter) { message("Posthoc reset") .ret$control$maxOuterIterations <- 0L } else if (this.env$zeroGrad) { message("Theta reset (zero gradient values); Switch to bobyqa") RxODE::rxReq("minqa") .ret$control$outerOptFun <- .bobyqa .ret$control$outerOpt <- -1L } else { message("Theta reset (ETA drift)") } } } if (this.env$err != "") { stop(this.env$err) } else { return(.ret0) } } .ret0 <- try(.fitFun(.ret)) .n <- 1 while (inherits(.ret0, "try-error") && control$maxOuterIterations != 0 && .n <= control$nRetries) { message(sprintf("Restart %s", .n)) .ret$control$nF <- 0 .estNew <- .est0 + 0.2 * .n * abs(.est0) * stats::runif(length(.est0)) - 0.1 * .n .estNew <- sapply(seq_along(.est0), function(.i) { if (.ret$thetaFixed[.i]) { return(.est0[.i]) } else if (.estNew[.i] < lower[.i]) { return(lower + (.Machine$double.eps)^(1/7)) } else if (.estNew[.i] > upper[.i]) { return(upper - (.Machine$double.eps)^(1/7)) } else { return(.estNew[.i]) } }) .ret$thetaIni <- .estNew .ret0 <- try(.fitFun(.ret)) .n <- .n + 1 } if (inherits(.ret0, "try-error")) stop("Could not fit data.") .ret <- .ret0 if (exists("parHistData", .ret)) { .tmp <- .ret$parHistData .tmp <- .tmp[.tmp$type == "Unscaled", names(.tmp) != "type"] .iter <- .tmp$iter .tmp <- .tmp[, names(.tmp) != "iter"] .ret$parHistStacked <- data.frame(stack(.tmp), iter = .iter) names(.ret$parHistStacked) <- c("val", "par", "iter") .ret$parHist <- data.frame(iter = .iter, .tmp) } if (.mixed) { .etas <- .ret$ranef .thetas <- .ret$fixef .pars <- .Call(`_nlmixr_nlmixrParameters`, .thetas, .etas) .ret$shrink <- .Call(`_nlmixr_calcShrinkOnly`, .ret$omega, .pars$eta.lst, length(.etas$ID)) .updateParFixed(.ret) } else { .updateParFixed(.ret) } if (!exists("table", .ret)) { .ret$table <- tableControl() } if (control$calcTables) { .ret <- addTable(.ret, updateObject = "no", keep = keep, drop = drop, table = .ret$table) } .ret})(data = dat, inits = .FoceiInits, PKpars = .pars, model = .mod, pred = function() { return(nlmixr_pred) }, err = uif$error, lower = uif$focei.lower, upper = uif$focei.upper, fixed = uif$focei.fixed, thetaNames = uif$focei.names, etaNames = uif$eta.names, control = control, env = env, keep = .keep, drop = .drop): Not all the covariates are in the dataset.
    #> Timing stopped at: 18.28 0.455 18.73
    AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm)
    #> Error in AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm): object 'f_nlmixr_dfop_sfo_saem' not found
    summary(f_nlmixr_dfop_sfo_sfo, data = TRUE)
    #> Error in h(simpleError(msg, call)): error in evaluating the argument 'object' in selecting a method for function 'summary': object 'f_nlmixr_dfop_sfo_sfo' not found
    # } diff --git a/docs/dev/reference/tffm0.html b/docs/dev/reference/tffm0.html index d993e8ff..67f26b85 100644 --- a/docs/dev/reference/tffm0.html +++ b/docs/dev/reference/tffm0.html @@ -81,7 +81,7 @@ from RxODE." /> mkin - 1.0.5 + 1.1.0
    diff --git a/test.log b/test.log index 90719917..f68ec45a 100644 --- a/test.log +++ b/test.log @@ -3,7 +3,7 @@ Loading required package: parallel ℹ Testing mkin ✔ | OK F W S | Context ✔ | 5 | AIC calculation -✔ | 5 | Analytical solutions for coupled models [3.3 s] +✔ | 5 | Analytical solutions for coupled models [3.4 s] ✔ | 5 | Calculation of Akaike weights ✔ | 2 | Export dataset for reading into CAKE ✔ | 12 | Confidence intervals and p-values [1.0 s] @@ -13,7 +13,7 @@ Loading required package: parallel ✔ | 14 | Results for FOCUS D established in expertise for UBA (Ranke 2014) [0.8 s] ✔ | 4 | Test fitting the decline of metabolites from their maximum [0.3 s] ✔ | 1 | Fitting the logistic model [0.2 s] -✔ | 35 1 | Nonlinear mixed-effects models [26.6 s] +✔ | 35 1 | Nonlinear mixed-effects models [26.3 s] ──────────────────────────────────────────────────────────────────────────────── Skip (test_mixed.R:161:3): saem results are reproducible for biphasic fits Reason: Fitting with saemix takes around 10 minutes when using deSolve @@ -36,7 +36,7 @@ Reason: Fitting with saemix takes around 10 minutes when using deSolve ✔ | 4 | Calculation of maximum time weighted average concentrations (TWAs) [2.3 s] ══ Results ═════════════════════════════════════════════════════════════════════ -Duration: 67.8 s +Duration: 67.6 s ── Skipped tests ────────────────────────────────────────────────────────────── • Fitting with saemix takes around 10 minutes when using deSolve (1) diff --git a/vignettes/FOCUS_D.html b/vignettes/FOCUS_D.html index 0e983b98..ba514c18 100644 --- a/vignettes/FOCUS_D.html +++ b/vignettes/FOCUS_D.html @@ -360,7 +360,7 @@ pre code {

    Example evaluation of FOCUS Example Dataset D

    Johannes Ranke

    -

    Last change 31 January 2019 (rebuilt 2021-09-15)

    +

    Last change 31 January 2019 (rebuilt 2021-09-16)

    @@ -434,10 +434,10 @@ print(FOCUS_2006_D)

    A comprehensive report of the results is obtained using the summary method for mkinfit objects.

    summary(fit)
    -
    ## mkin version used for fitting:    1.0.5 
+
    ## mkin version used for fitting:    1.1.0 
 ## R version used for fitting:       4.1.1 
-## Date of fit:     Wed Sep 15 17:39:28 2021 
-## Date of summary: Wed Sep 15 17:39:28 2021 
+## Date of fit:     Thu Sep 16 13:57:32 2021 
+## Date of summary: Thu Sep 16 13:57:33 2021 
 ## 
 ## Equations:
 ## d_parent/dt = - k_parent * parent
@@ -445,7 +445,7 @@ print(FOCUS_2006_D)
    
 ## 
 ## Model predictions using solution type analytical 
 ## 
-## Fitted using 401 model solutions performed in 0.143 s
+## Fitted using 401 model solutions performed in 0.149 s
 ## 
 ## Error model: Constant variance 
 ## 
diff --git a/vignettes/FOCUS_L.html b/vignettes/FOCUS_L.html
index 717a01be..b6ebb606 100644
--- a/vignettes/FOCUS_L.html
+++ b/vignettes/FOCUS_L.html
@@ -27,11 +27,8 @@ document.addEventListener('DOMContentLoaded', function(e) {
   }
 });
 
-